调用公用对话框的四种方法

　　很多程序都要调用公用对话框，比如：打开文件、保存文件、修改颜色、选择字体等等。下面就介绍调用公用对话框的方法。第一种需要在窗体上添加COMDLG32.OCX控件，后面三种都不需要，从此就不用再带着COMDLG32.OCX文件满世界跑了！

一、直接使用COMDLG32.OCX控件
　　这是用得最多的办法，但使得我们发布程序时都要带上COMDLG32.OCX文件，不大方便。
　　首先在【工程→部件→控件】对话框中勾选“Microsoft Common Dialog Control 6.0”，然后在工具箱中选取CommonDialog控件放到窗体上。这个控件的使用代码就从略了。

二、添加许可证
　　此方法的代码较简单，适用于程序有多个窗体都需要调用对话框时。代码：

　　Form1（或启动窗体）中的代码：

Private Sub Form_Load()
Licenses.Add "MSComDlg.CommonDialog"
End Sub

　　应用窗体中的代码：

Option Explicit

Dim WithEvents Dlg As VBControlExtender

Private Sub Form_Load()
Set Dlg = Controls.Add("MSComDlg.CommonDialog", "Dlg")
End Sub

Private Sub 打开_Click()
On Error GoTo 100
Dim OpenName As String
With Dlg.object
  .DialogTitle = "打开文件"
  .flags = &H1808
  .CancelError = True
  .Filter = "*.*|*.*"
  .showopen  '这里改为 .showsave 就是保存
  OpenName = .FileName
End With
Debug.Print OpenName
100
End Sub

Private Sub 字体_Click()
Me.AutoRedraw = True
With Dlg.object
  .FontName = Me.FontName
  .FontSize = Me.FontSize
  .FontStrikethru = Me.FontStrikethru
  .FontUnderline = Me.FontUnderline
  .FontBold = Me.FontBold
  .FontItalic = Me.FontItalic
  .Color = Me.ForeColor
  .flags = &H103 '&H2143
  .ShowFont
  Me.FontSize = .FontSize
  Me.FontName = .FontName
  Me.FontStrikethru = .FontStrikethru
  Me.FontUnderline = .FontUnderline
  Me.FontBold = .FontBold
  Me.FontItalic = .FontItalic
  Me.ForeColor = .Color
End With
AutoRedraw = True
Cls
Print "中华人民共和国"
End Sub

Private Sub 颜色_Click()
With Dlg.object
  .flags = 3
  .Color = Me.BackColor
  .ShowColor
  Me.BackColor = .Color
End With
End Sub

三、在程序运行中添加控件
　　本方法对于没有窗体但又需要调用公用对话框的程序特别有用，代码很简单。缺点是在没有装VB的机器上运行可能会发生错误。
　　注意第二种方法调用是 Dlg.object，本方法是Dlg。
　　应用过程中的代码如下：

Private Sub 保存()
On Error GoTo 100
Dim NewName As String, dlg As Object
Set dlg = CreateObject("MSComDlg.CommonDialog")
With dlg
  .DialogTitle = "图像另存为"
  .flags = &H802
  .CancelError = True
  .Filter = "bmp 图片文件|*.bmp|jpg 图片文件|*.jpg"
  .showsave  '这里改为 .showopen 就是打开
  NewName = .FileName
End With
Debug.Print NewName
100
End Sub

Private Sub 字体()
Dim Dlg As Object
Set Dlg = CreateObject("MSComDlg.CommonDialog")
With Dlg
  .FontName = Me.FontName
  .FontSize = Me.FontSize
  .FontStrikethru = Me.FontStrikethru
  .FontUnderline = Me.FontUnderline
  .FontBold = Me.FontBold
  .FontItalic = Me.FontItalic
  .Color = Me.ForeColor
  .flags = &H103
  .ShowFont
  Me.FontSize = .FontSize
  Me.FontName = .FontName
  Me.FontStrikethru = .FontStrikethru
  Me.FontUnderline = .FontUnderline
  Me.FontBold = .FontBold
  Me.FontItalic = .FontItalic
  Me.ForeColor = .Color
End With
AutoRedraw = True
Cls
Print "中华人民共和国"
End Sub

Private Sub 颜色()
Dim Dlg As Object
Set Dlg = CreateObject("MSComDlg.CommonDialog")
With Dlg
  .flags = 3
  .Color = Me.BackColor
  .ShowColor
  Me.BackColor = .Color
End With
End Sub

四、用API函数调用公用对话框
　　笔者在网上收集了用 API函数调用公用对话框的代码，进行了验证，并去伪存真去芜存精，改正了以讹传讹的错误，适当地添加了注释，在此发表，供各位使用。对于程序中只用了某一个对话功能（例如只用到了打开文件）的程序来说，特别有用，你可以根据情况，选用其中某一个调用的有关代码。但是有一个问题要注意：原来使用CommonDialog控件时一般会选择“‘取消’引发错误”，那么用户点击“取消”后程序就会转到错误陷阱去处理；而使用API函数调用公用对话框时，用户点击“取消”不会引发错误，只是函数的返回值为空值或０值。
　　测试时，请在窗体上添加一个文本框，四个按纽。
　　代码如下：

Option Explicit

'========================打开/保存对话框 API 函数及结构===================
Private Type tagOPENFILENAME
  lStructSize As Long       '结构大小
  hwndOwner As Long         '窗体句柄
  hInstance As Long         '当前应用程序实例的句柄
  strFilter As String       '过滤器字符串
  strCustomFilter As String '选中的过滤器（过滤器索引所指的过滤器）字符串
  nMaxCustFilter As Long    '过滤器最大长度
  nFilterIndex As Long      '选中的过滤器索引，意义与 CommonDialog 控件相同
  strFile As String         '选中的全路径文件名
  nMaxFile As Long          '全路径文件名的缓冲区大小，须预先定义
  strFileTitle As String    '去掉了路径的文件名（多选时＝空）
  nMaxFileTitle As Long     '去掉路径的文件名缓冲区大小，须预先定义
  strInitialDir As String   '去掉了文件名的路径（没有最后的反斜杠）
  strTitle As String        '对话框标题，意义与 CommonDialog 控件相同
  flags As Long             '标志，意义与 CommonDialog 控件相同（&H204为多选打开对话框）
  nFileOffset As Integer    '路径长度（包括最后的反斜杠）
  nFileExtension As Integer '全路径文件名长度（不计算前面３个表示盘符的字符，如 D:\ ，多选时＝0）
  strDefExt As String       '默认提取
  lCustData As Long         '
  lpfnHook As Long          '勾子函数地址
  lpTemplateName As String  '选中的全路径文件名（备用）
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (ofn As tagOPENFILENAME) As Boolean

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (ofn As tagOPENFILENAME) As Boolean

'========================颜色对话框 API 函数及结构==========================

'对话框不支持彩色调色板，对话框提供的颜色的选择仅限于系统颜色和这些颜色的混合值，但可以为
'对话框提供一个CCHOOKProc程序，此钩子程序能处理发送给对话框的信息。通过建立CHOOSECOLOR结
'构中Flags成员的CC_ENABLEHOOK标志和指定IpfnHook成员中挂钩程序的地址，可使挂钩程序生效。

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 Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long

'========================字体对话框 API 函数及结构==========================
Private Type ChooseFont
  lStructSize As Long       '结构大小
  hwndOwner As Long         '窗体句柄
  hdc As Long               '与打印机相关的设备描述体
  lpLogFont As Long         '指向 LOGFONT 结构的指针
  iPointSize As Long        '字号，是正常值的 10 倍
  flags As Long             '标记
  rgbColors As Long         '字符颜色
  lCustData As Long         '勾子通道数据
  lpfnHook As Long          '勾子函数地址
  lpTemplateName As String  '自定义模板名称
  hInstance As Long         '当前应用程序实例的句柄
  lpszStyle As String       '字域样式
  nFontType As Integer      '字体类型值：常规=&H2404，斜体=&HA604，粗体=&HA504，粗斜体=&HA704
  MISSING_ALIGNMENT As Integer
  nSizeMin As Long          '最小字号
  nSizeMax As Long          '最大字号
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(1 To 32) As Byte '字体名称
End Type

Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As ChooseFont) As Long
Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As String, ByVal cbCopy As Long)

'========================打印对话框 API 函数及结构==========================
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG) As Long
Private Declare Function PageSetupDlg Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long
'=========================================================================

Dim fName As String

Private Sub Command1_Click() '打开
Dim OpenName As String, st As String, z As String
OpenName = CmdDlg(1, , "文本文件(*.txt,*.htm)|*.TXT;*.htm|所有文件(*.*)|*.*", , &H200C, fName)
If InStr(OpenName, ".") Then
  Open OpenName For Input As #1
  Do Until EOF(1)
    Line Input #1, z
    st = st & z & vbCrLf
  Loop
  Close #1
  fName = OpenName
  Text1 = st
End If
End Sub

Private Sub Command2_Click() '保存
Dim SaveName As String, st As String
SaveName = CmdDlg(0, , "文本文件(*.txt,*.htm)|*.TXT;*.htm|所有文件(*.*)|*.*", , &H200A, fName)
If InStr(SaveName, ".") Then
  st = Text1
  Open SaveName For Output As #1
  Print #1, st
  Close #1
  fName = SaveName
End If
End Sub

Private Sub Command3_Click() '颜色
Dim cc As ChooseColor
cc.lStructSize = Len(cc)
cc.hwndOwner = Me.hWnd
cc.hInstance = App.hInstance '返回当前应用程序实例的句柄
cc.flags = 0
cc.lpCustColors = 0 'RGB(255, 124, 255)
If ChooseColor(cc) Then Text1.BackColor = cc.rgbResult
End Sub

Private Sub Command4_Click() '字体
AlterFont Text1
End Sub

Private Function AlterFont(lObject As Object) As Boolean
Dim cf As ChooseFont, lFont As LOGFONT
'-----字体、字形、字号 3 个下拉框预设值-----------------
With lObject.Font
  lFont.lfHeight = -(.Size * (20 / 15))
  lFont.lfWeight = .Weight
  lFont.lfItalic = .Italic
  lFont.lfUnderline = .Underline
  lFont.lfStrikeOut = .Strikethrough
  .Name = LeftB(.Name & String(32, 0), 32)
  CopyMemoryStr lFont.lfFaceName(1), .Name, 32
'--------------------------------------------------------
  cf.flags = &H2143       '其中 &H40 决定是否定位在预设值上
  cf.lStructSize = Len(cf)
  cf.hwndOwner = lObject.hWnd
  cf.iPointSize = .Size * 10
  cf.hInstance = App.hInstance
  cf.nSizeMax = 72
  cf.nSizeMin = 8
  cf.rgbColors = lObject.ForeColor
  cf.lpLogFont = VarPtr(lFont)
 
  If ChooseFont(cf) Then
    .Name = StrConv(lFont.lfFaceName, vbUnicode)
    .Size = cf.iPointSize / 10
    .Weight = lFont.lfWeight
    .Italic = lFont.lfItalic
    .Strikethrough = lFont.lfStrikeOut
    .Underline = lFont.lfUnderline
    lObject.ForeColor = cf.rgbColors
    AlterFont = True
  End If
End With
End Function

'返回选择的全路径文件名
'参数：1.对话框类型(0保存，1打开)；2.对话框标题；3.过滤器字符串；4.过滤器索引；5.标志；6.文件名；7.文件名缓冲区大小
Private Function CmdDlg(Optional ByVal DlgType As Boolean = True, _
  Optional ByVal DialogTitle As String, Optional ByVal Filter As String, _
  Optional FilterIndex As Long = 1, Optional flags As Long, _
  Optional ByVal Filename As String, Optional ByVal MaxFile As Long = 255) As Variant
 
On Error GoTo CmdDlg_Error
Dim ofn As tagOPENFILENAME
Dim fResult As Boolean

If Len(Filter) Then Filter = Replace(Filter, "|", vbNullChar) 'Filter以Chr(0)为分隔符

With ofn
  .lStructSize = Len(ofn)
  .hwndOwner = 0                        '0为屏幕句柄
  .strFilter = Filter
  .nFilterIndex = FilterIndex
  .strFile = Left(Filename & String$(MaxFile, 0), MaxFile) '用空字符补足全路径文件名
  .nMaxFile = MaxFile                   '全路径文件名长度
  .strFileTitle = String$(MaxFile, 0)   '用空字符填充(去掉路径的)文件名
  .nMaxFileTitle = MaxFile              '(去掉路径的)文件名长度
  .strTitle = DialogTitle               '对话框标题
  .flags = flags
  .strDefExt = ""
  .strInitialDir = CurDir
  .hInstance = 0
  .strCustomFilter = String(255, 0)     '用空字符补足选中的过滤器
  .nMaxCustFilter = 255                 '选中的过滤器长度
  .lpfnHook = 0
End With
If DlgType Then fResult = GetOpenFileName(ofn) Else fResult = GetSaveFileName(ofn)
If fResult Then
  CmdDlg = Left(ofn.strFile, InStr(ofn.strFile, vbNullChar) - 1)
  FilterIndex = ofn.nFilterIndex        '返回选中的过滤器索引
Else
  CmdDlg = vbNullChar
End If
CmdDlg_Error:
End Function