''標準對話框(SmDialog)
?? ''
?? Option Explicit
?? ''''定義一個全局變量,用于保存字體的各種屬性
?? Public Type SmFontAttr
?? FontName As String ''字體名
?? FontSize As Integer ''字體大小
?? FontBod As Boolean ''是否黑體
?? FontItalic As Boolean ''是否斜體
?? FontUnderLine As Boolean ''是否下劃線
?? 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 ''網絡驅動器
?? Private Const RESOURCETYPE_PRINT = &H2 ''網絡打印機
?? ''/------------------------------------------------------------
?? 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
?? ''/=======顯示斷開網絡資源對話框============
?? 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
?? ''/結構說明: _
?? hOwner 調用這個對話框的窗口的句柄 _
?? pidlRoot 指向你希望瀏覽的最上面的文件夾的符列表 _
?? pszDisplayName 用于保存用戶所選擇的文件夾的顯示名的緩沖區 _
?? lpszTitle 瀏覽對話框的標題 _
?? ulFlags 決定瀏覽什么的標志(見下) _
?? lpfn 當事件發生時對話框調用的回調函數的地址.可將它設定為NULL _
?? lparam 若定義了回調函數,則為傳遞給回調函數的值 _
?? iImage As Long 保存所選文件夾映像索引的緩沖區 _
?? ulFlags參數(見下:)
?? Private Const BIF_RETURNONLYFSDIRS = &H1 ''僅允許瀏覽文件系統文件夾
?? Private Const BIF_DONTGOBELOWDOMAIN = &H2 ''利用這個值強制用戶儀在網上鄰居的域級別
?? 中
?? Private Const BIF_STATUSTEXT = &H4 ''在選擇對話中顯示狀態欄
?? 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
?? ''
?? ''文件夾選擇對話框
?? ''函數:SaveFile
?? ''參數:Title 設置對話框的標簽.
?? '' 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
?? ''
?? ''文件保存對話框
?? ''函數:SaveFile
?? ''參數:WinHwnd 調用此函數的HWND
?? '' BoxLabel 設置對話框的標簽.
?? '' StartPath 設置初始化路徑.
?? '' FilterStr 文件過濾.
?? '' 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
?? ''
?? ''文件打開對話框
?? ''函數:OpenFile
?? ''參數:WinHwnd 調用此函數的HWND
?? '' BoxLabel 設置對話框的標簽.
?? '' StartPath 設置初始化路徑.
?? '' FilterStr 文件過濾.
?? '' 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
?? ''
?? ''顏色對話框
?? ''函數:GetColor
?? ''參數:
?? ''返回值:Long,用戶所選擇的顏色.
?? ''例子：
?? 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
?? ''
?? ''顯示映射網絡驅動器對話框
?? ''函數: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
?? ''
?? ''顯示映射網絡打印機對話框
?? ''函數: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
?? ''
?? ''斷開映射網絡驅動器對話框
?? ''函數: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
?? ''
?? ''斷開映射網絡打印機關話框
?? ''函數: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
?? ''
?? ''字體選擇對話框
?? ''函數: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) ''是/否下劃線
?? FontInfo.FontStrikeou = (pLogFont.lfStrikeOut)
?? FontInfo.FontColor = .rgbColors
?? End With
?? End If
?? GetFont = FontInfo
?? End Function
?? ''
?? ''文件打開.(帶預覽文件功能)
?? ''函數:BrowFile
?? ''參數:Pattern 文件類型字符串,StarPath 開始路徑,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
?? ''
?? ''顯示網上鄰居
?? ''函數:ShowNetWork
?? ''參數:FrmCap 窗口標題,Labction 提示標簽名.
?? ''返回值:[確定] 所選計算機名稱.[取消] 空字符串.
?? ''例:
?? Public Function ShowNetWork(Optional FrmCap As String = "網上鄰居", _
?? Optional Labction As String = "選擇計算機名稱.") As
?? String
?? ShowLan.Hide
?? ShowLan.Caption = FrmCap
?? ShowLan.LabNNCaption = Labction
?? ShowLan.Show 1
?? ShowNetWork = P_NetReturnVal
?? End Function

轉載于:https://www.cnblogs.com/bennylam/archive/2009/10/28/1591498.html

總結

以上是生活随笔為你收集整理的VB用API实现各种对话框(总结)（转载）的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。