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

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