''標準對話(huà)框(SmDialog)
''
Option Explicit
''''定義一個(gè)全局變量,用于保存字體的各種屬性
Public Type SmFontAttr
FontName As String ''字體名
FontSize As Integer ''字體大小
FontBod As Boolean ''是否黑體
FontItalic As Boolean ''是否斜體
FontUnderLine As Boolean ''是否下劃線(xiàn)
FontStrikeou As Boolean
FontColor As Long
WinHwnd As Long
End Type
Dim M_GetFont As SmFontAttr
''''**系統常量------------------------------------------
Private Const SWP_NOOWNERZORDER = &H200
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_SHOWWINDOW = &H40
Private Const RESOURCETYPE_DISK = &H1 ''網(wǎng)絡(luò )驅動(dòng)器
Private Const RESOURCETYPE_PRINT = &H2 ''網(wǎng)絡(luò )打印機
''/------------------------------------------------------------
Private Const NoError = 0
Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const LF_FACESIZE = 32
Private Const MAX_PATH = 260
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_EFFECTS = &H100&
Private Const ITALIC_FONTTYPE = &H200
Private Const BOLD_FONTTYPE = &H100
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_SCREENFONTS = &H1
Private Const CF_SHOWHELP = &H4&
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
''/------------------------------------------
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
''/-----------------------------------------------------------
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hdc As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
''/--------------
Private Type SHITEMID
cb As Long
abID() As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
''/------------------------------------------
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, _
Pidl As ITEMIDLIST) As Long
''/------------------------------------------
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA"
(pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA"
(pOpenfilename As OPENFILENAME) As Long
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA"
(pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function WNetConnectionDialog Lib "mpr.dll" (ByVal hWnd As Long,
ByVal dwType As Long) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA"
(pChooseFont As CHOOSEFONT) As Long
''/=======顯示斷開(kāi)網(wǎng)絡(luò )資源對話(huà)框============
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" _
(ByVal hWnd As Long, ByVal dwType As Long) As Long
''/================================================================================
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
''/結構說(shuō)明: _
hOwner 調用這個(gè)對話(huà)框的窗口的句柄 _
pidlRoot 指向你希望瀏覽的最上面的文件夾的符列表 _
pszDisplayName 用于保存用戶(hù)所選擇的文件夾的顯示名的緩沖區 _
lpszTitle 瀏覽對話(huà)框的標題 _
ulFlags 決定瀏覽什么的標志(見(jiàn)下) _
lpfn 當事件發(fā)生時(shí)對話(huà)框調用的回調函數的地址.可將它設定為NULL _
lparam 若定義了回調函數,則為傳遞給回調函數的值 _
iImage As Long 保存所選文件夾映像索引的緩沖區 _
ulFlags參數(見(jiàn)下:)
Private Const BIF_RETURNONLYFSDIRS = &H1 ''僅允許瀏覽文件系統文件夾
Private Const BIF_DONTGOBELOWDOMAIN = &H2 ''利用這個(gè)值強制用戶(hù)儀在網(wǎng)上鄰居的域級別
中
Private Const BIF_STATUSTEXT = &H4 ''在選擇對話(huà)中顯示狀態(tài)欄
Private Const BIF_RETURNFSANCESTORS = &H8 ''返回文件系統祖先
Private Const BIF_BROWSEFORCOMPUTER = &H1000 ''允許瀏覽計算機
Private Const BIF_BROWSEFORPRINTER = &H2000 ''允許游覽打印機文件夾
''/--------------------------------------------------------------------------------
Dim FontInfo As SmFontAttr ''字體
''/--------------------------------------------------------------------------------
Private Function GetFolderValue(wIdx As Integer) As Long
If wIdx < 2 Then
GetFolderValue = 0
ElseIf wIdx < 12 Then
GetFolderValue = wIdx
Else
GetFolderValue = wIdx + 4
End If
End Function
''
Private Function GetReturnType() As Long
Dim dwRtn As Long
dwRtn = dwRtn Or BIF_RETURNONLYFSDIRS
GetReturnType = dwRtn
End Function
''
''文件夾選擇對話(huà)框
''函數:SaveFile
''參數:Title 設置對話(huà)框的標簽.
'' hWnd 調用此函數的HWND
'' FolderID SmBrowFolder枚舉(默認:我的電腦).
''返回值:String 文件夾路徑.
''例子：
Public Function GetFolder(Optional Title As String, _
Optional hWnd As Long, _
Optional FolderID As SmBrowFolder = MyComputer) As String
Dim Bi As BROWSEINFO
Dim Pidl As Long
Dim Folder As String
Dim IDL As ITEMIDLIST
Dim nFolder As Long
Dim ReturnFol As String
Dim Fid As Integer
Fid = FolderID
Folder = String$(255, Chr$(0))
With Bi
.hOwner = hWnd
nFolder = GetFolderValue(Fid)
If SHGetSpecialFolderLocation(ByVal hWnd, ByVal nFolder, IDL) = NoError Then
.pidlRoot = IDL.mkid.cb
End If
.pszDisplayName = String$(MAX_PATH, Fid)
If Len(Title) > 0 Then
.lpszTitle = Title & Chr$(0)
Else
.lpszTitle = "請選擇文件夾:" & Chr$(0)
End If
.ulFlags = GetReturnType()
End With
Pidl = SHBrowseForFolder(Bi)
''/返回所選的文件夾路徑
If SHGetPathFromIDList(ByVal Pidl, ByVal Folder) Then
ReturnFol = Left$(Folder, InStr(Folder, Chr$(0)) - 1)
If Right$(Trim$(ReturnFol), 1) <> "\" Then ReturnFol = ReturnFol & "\"
GetFolder = ReturnFol
Else
GetFolder = ""
End If
End Function
''
''文件保存對話(huà)框
''函數:SaveFile
''參數:WinHwnd 調用此函數的HWND
'' BoxLabel 設置對話(huà)框的標簽.
'' StartPath 設置初始化路徑.
'' FilterStr 文件過(guò)濾.
'' Flag 標志.(參考MSDN)
''返回值:String 文件名.
''例子：
Public Function SaveFile(WinHwnd As Long, _
Optional BoxLabel As String = "", _
Optional StartPath As String = "", _
Optional FilterStr = "*.*|*.*", _
Optional Flag As Variant = &H4 Or &H200000) As String
Dim Rc As Long
Dim pOpenfilename As OPENFILENAME
Dim Fstr1() As String
Dim Fstr As String
Dim I As Long
Const MAX_Buffer_LENGTH = 256
On Error Resume Next
If Len(Trim$(StartPath)) > 0 Then
If Right$(StartPath, 1) <> "\" Then StartPath = StartPath & "\"
If Dir$(StartPath, vbDirectory + vbHidden) = "" Then
StartPath = App.Path
End If
Else
StartPath = App.Path
End If
If Len(Trim$(FilterStr)) = 0 Then
Fstr = "*.*|*.*"
End If
Fstr1 = Split(FilterStr, "|")
For I = 0 To UBound(Fstr1)
Fstr = Fstr & Fstr1(I) & vbNullChar
Next
''/--------------------------------------------------
With pOpenfilename
.hwndOwner = WinHwnd
.hInstance = App.hInstance
.lpstrTitle = BoxLabel
.lpstrInitialDir = StartPath
.lpstrFilter = Fstr
.nFilterIndex = 1
.lpstrDefExt = vbNullChar & vbNullChar
.lpstrFile = String(MAX_Buffer_LENGTH, 0)
.nMaxFile = MAX_Buffer_LENGTH - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = MAX_Buffer_LENGTH
.lStructSize = Len(pOpenfilename)
.flags = Flag
End With
Rc = GetSaveFileName(pOpenfilename)
If Rc Then
SaveFile = Left$(pOpenfilename.lpstrFile, pOpenfilename.nMaxFile)
Else
SaveFile = ""
End If
End Function
''
''文件打開(kāi)對話(huà)框
''函數:OpenFile
''參數:WinHwnd 調用此函數的HWND
'' BoxLabel 設置對話(huà)框的標簽.
'' StartPath 設置初始化路徑.
'' FilterStr 文件過(guò)濾.
'' Flag 標志.(參考MSDN)
''返回值:String 文件名.
''例子：
Public Function OpenFile(WinHwnd As Long, _
Optional BoxLabel As String = "", _
Optional StartPath As String = "", _
Optional FilterStr = "*.*|*.*", _
Optional Flag As Variant = &H8 Or &H200000) As String
Dim Rc As Long
Dim pOpenfilename As OPENFILENAME
Dim Fstr1() As String
Dim Fstr As String
Dim I As Long
Const MAX_Buffer_LENGTH = 256
On Error Resume Next
If Len(Trim$(StartPath)) > 0 Then
If Right$(StartPath, 1) <> "\" Then StartPath = StartPath & "\"
If Dir$(StartPath, vbDirectory + vbHidden) = "" Then
StartPath = App.Path
End If
Else
StartPath = App.Path
End If
If Len(Trim$(FilterStr)) = 0 Then
Fstr = "*.*|*.*"
End If
Fstr = ""
Fstr1 = Split(FilterStr, "|")
For I = 0 To UBound(Fstr1)
Fstr = Fstr & Fstr1(I) & vbNullChar
Next
With pOpenfilename
.hwndOwner = WinHwnd
.hInstance = App.hInstance
.lpstrTitle = BoxLabel
.lpstrInitialDir = StartPath
.lpstrFilter = Fstr
.nFilterIndex = 1
.lpstrDefExt = vbNullChar & vbNullChar
.lpstrFile = String(MAX_Buffer_LENGTH, 0)
.nMaxFile = MAX_Buffer_LENGTH - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = MAX_Buffer_LENGTH
.lStructSize = Len(pOpenfilename)
.flags = Flag
End With
Rc = GetOpenFileName(pOpenfilename)
If Rc Then
OpenFile = Left$(pOpenfilename.lpstrFile, pOpenfilename.nMaxFile)
Else
OpenFile = ""
End If
End Function
''
''顏色對話(huà)框
''函數:GetColor
''參數:
''返回值:Long,用戶(hù)所選擇的顏色.
''例子：
Public Function GetColor() As Long
Dim Rc As Long
Dim pChoosecolor As CHOOSECOLOR
Dim CustomColor() As Byte
With pChoosecolor
.hwndOwner = 0
.hInstance = App.hInstance
.lpCustColors = StrConv(CustomColor, vbUnicode)
.flags = 0
.lStructSize = Len(pChoosecolor)
End With
Rc = CHOOSECOLOR(pChoosecolor)
If Rc Then
GetColor = pChoosecolor.rgbResult
Else
GetColor = -1
End If
End Function
''
''顯示映射網(wǎng)絡(luò )驅動(dòng)器對話(huà)框
''函數:ConnectDisk
''參數:hWnd 調用此函數的窗口HWND.(ME.HWN)
''返回值:=0,成功,<>0,失敗.
''例子：
Public Function ConnectDisk(Optional hWnd As Long) As Long
Dim Rc As Long
If IsNumeric(hWnd) Then
Rc = WNetConnectionDialog(hWnd, RESOURCETYPE_DISK)
Else
Rc = WNetConnectionDialog(0, RESOURCETYPE_DISK)
End If
ConnectDisk = Rc
End Function
''
''顯示映射網(wǎng)絡(luò )打印機對話(huà)框
''函數:ConnectPrint
''參數:hWnd 調用此函數的窗口HWND.(ME.HWN)
''返回值:=0,成功,<>0,失敗.
''例子：
Public Function ConnectPrint(Optional hWnd As Long) As Long
Dim Rc As Long
If IsNumeric(hWnd) Then
Rc = WNetConnectionDialog(hWnd, RESOURCETYPE_PRINT)
Else
Rc = WNetConnectionDialog(0, RESOURCETYPE_PRINT)
End If
End Function
''
''斷開(kāi)映射網(wǎng)絡(luò )驅動(dòng)器對話(huà)框
''函數:DisconnectDisk
''參數:hWnd 調用此函數的窗口HWND.(ME.HWN)
''返回值:=0,成功,<>0,失敗.
''例子：
Public Function DisconnectDisk(Optional hWnd As Long) As Long
Dim Rc As Long
If IsNumeric(hWnd) Then
Rc = WNetDisconnectDialog(hWnd, RESOURCETYPE_DISK)
Else
Rc = WNetDisconnectDialog(0, RESOURCETYPE_DISK)
End If
End Function
''
''斷開(kāi)映射網(wǎng)絡(luò )打印機關(guān)話(huà)框
''函數:DisconnectPrint
''參數:hWnd 調用此函數的窗口HWND.(ME.HWN)
''返回值:=0,成功,<>0,失敗.
''例子：
Public Function DisconnectPrint(Optional hWnd As Long) As Long
Dim Rc As Long
If IsNumeric(hWnd) Then
Rc = WNetDisconnectDialog(hWnd, RESOURCETYPE_PRINT)
Else
Rc = WNetDisconnectDialog(0, RESOURCETYPE_PRINT)
End If
End Function
''
''字體選擇對話(huà)框
''函數:GetFont
''參數:WinHwnd 調用此函數的窗口HWND.(ME.HWN)
''返回值:SmFontAttr 結構變量.
''例子：
'' Dim mDialog As New SmDialog
'' Dim mFontInfo As SmFontAttr
'' mFontInfo = mDialog.GetFont(Me.hWnd)
'' Set mDialog = Nothing
Public Function GetFont(WinHwnd As Long) As SmFontAttr
Dim Rc As Long
Dim pChooseFont As CHOOSEFONT
Dim pLogFont As LOGFONT
With pLogFont
.lfFaceName = StrConv(FontInfo.FontName, vbFromUnicode)
.lfItalic = FontInfo.FontItalic
.lfUnderline = FontInfo.FontUnderLine
.lfStrikeOut = FontInfo.FontStrikeou
End With
With pChooseFont
.hInstance = App.hInstance
If IsNumeric(WinHwnd) Then .hwndOwner = WinHwnd
.flags = CF_BOTH + CF_INITTOLOGFONTSTRUCT + CF_EFFECTS + CF_NOSCRIPTSEL
If IsNumeric(FontInfo.FontSize) Then .iPointSize = FontInfo.FontSize *
10
If FontInfo.FontBod Then .nFontType = .nFontType + BOLD_FONTTYPE
If IsNumeric(FontInfo.FontColor) Then .rgbColors = FontInfo.FontColor
.lStructSize = Len(pChooseFont)
.lpLogFont = VarPtr(pLogFont)
End With
Rc = CHOOSEFONT(pChooseFont)
If Rc Then
FontInfo.FontName = StrConv(pLogFont.lfFaceName, vbUnicode)
FontInfo.FontName = Left$(FontInfo.FontName, InStr(FontInfo.FontName,
vbNullChar) - 1)
With pChooseFont
FontInfo.FontSize = .iPointSize / 10 ''返回字體大
小
FontInfo.FontBod = (.nFontType And BOLD_FONTTYPE) ''返回是/否黑
體
FontInfo.FontItalic = (.nFontType And ITALIC_FONTTYPE) ''是/否斜體
FontInfo.FontUnderLine = (pLogFont.lfUnderline) ''是/否下劃線(xiàn)
FontInfo.FontStrikeou = (pLogFont.lfStrikeOut)
FontInfo.FontColor = .rgbColors
End With
End If
GetFont = FontInfo
End Function
''
''文件打開(kāi).(帶預覽文件功能)
''函數:BrowFile
''參數:Pattern 文件類(lèi)型字符串,StarPath 開(kāi)始路徑,IsBrow 是否生成預覽
''返回值:[確定] 文件路徑.[取消] 空字符串
''例:Me.Caption =
FileBrow.BrowFile("圖片文件|*.JPG;*.GIF;*.BMP|媒體文件|*.DAT;*.MPG;*.SWF;*.MP3;*.MP2
")
Public Function BrowFile(Optional Pattern As String = "*,*|*.*", _
Optional StarPath As String = "C:\", _
Optional IsBrow As Boolean = True) As String
On Error Resume Next
If Len(Trim$(Pattern)) = 0 Then Pattern = "*.*|*.*"
P_FilePart = Pattern
P_StarPath = StarPath
P_IsBrow = IsBrow
FrmBrowFile.Show 1
BrowFile = P_FullFileName
End Function
''
''顯示網(wǎng)上鄰居
''函數:ShowNetWork
''參數:FrmCap 窗口標題,Labction 提示標簽名.
''返回值:[確定] 所選計算機名稱(chēng).[取消] 空字符串.
''例:
Public Function ShowNetWork(Optional FrmCap As String = "網(wǎng)上鄰居", _
Optional Labction As String = "選擇計算機名稱(chēng).") As
String
ShowLan.Hide
ShowLan.Caption = FrmCap
ShowLan.LabNNCaption = Labction
ShowLan.Show 1
ShowNetWork = P_NetReturnVal
End Function
