VB用API实现各种对话框(总结)

各种对话框(总结)
  '
'标准对话框(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