用API函数调用公用对话框

用API函数调用公用对话框

　　很多程序都要调用公用对话框，比如：打开文件、保存文件、修改颜色、选择字体等等，
这就使得我们发布程序时都要带上COMDLG32.OCX文件，不大方便。笔者在网上收集了用API函
数调用公用对话框的代码，进行了验证，并去伪存真，改正了以讹传讹的错误，适当地添加了
注释，在此发表，供各位使用。对于程序中只用了某一个对话功能（例如只用到了打开文件）
的程序来说，特别有用：从此就不用再带着COMDLG32.OCX文件满世界跑了！你可以根据情况，
选用其中某一个调用的有关代码。

　　测试时，请在窗体上添加一个文本框，四个按纽。

代码如下：

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 控件相同
  nFileOffset As Integer    '路径长度（包括最后的反斜杠）
  nFileExtension As Integer '全路径文件名长度（不计算前面 3 个表示盘符的字符，如 D:\）
  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 函数及结构==========================
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)
'=========================================================================

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, i As Long
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 Sub AlterFont(lObject As Object)
Dim cf As ChooseFont, lFont As LOGFONT

'-----字体、字形、字号 3 个下拉框预设值-----------------
lFont.lfHeight = -(lObject.Font.Size * (20 / 15))
lFont.lfWeight = lObject.Font.Weight
lFont.lfItalic = lObject.Font.Italic
lFont.lfUnderline = lObject.Font.Underline
lFont.lfStrikeOut = lObject.Font.Strikethrough
lObject.Font.Name = LeftB(lObject.Font.Name & String(32, 0), 32)
CopyMemoryStr lFont.lfFaceName(1), lObject.Font.Name, 32
'--------------------------------------------------------

cf.flags = &H2143       '其中 &H40 决定是否定位在预设值上
cf.lStructSize = Len(cf)
cf.hwndOwner = Me.hWnd 'lObject.hWnd
cf.iPointSize = lObject.Font.Size * 10
cf.hInstance = App.hInstance
cf.nSizeMax = 72
cf.nSizeMin = 8
cf.rgbColors = lObject.ForeColor
cf.lpLogFont = VarPtr(lFont)

If ChooseFont(cf) Then
  lObject.Font.Name = StrConv(lFont.lfFaceName, vbUnicode)
  lObject.Font.Size = cf.iPointSize / 10
  lObject.Font.Weight = lFont.lfWeight
  lObject.Font.Italic = lFont.lfItalic
  lObject.Font.Strikethrough = lFont.lfStrikeOut
  lObject.Font.Underline = lFont.lfUnderline
  lObject.ForeColor = cf.rgbColors
End If
End Sub

'返回选择的全路径文件名。输入参数：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 InitialDir As String, Optional ByVal Filename As String) As Variant
  
On Error GoTo CmdDlg_Error
Dim ofn As tagOPENFILENAME
Dim fResult As Boolean
If InitialDir = "" Then InitialDir = CurDir
If Len(Filter) > 0 Then Filter = Replace(Filter, "|", vbNullChar) 'Filter以Chr(0)为分隔符

With ofn
  .lStructSize = Len(ofn)
  .hwndOwner = 0                                    '0为屏幕句柄
  .strFilter = Filter
  .nFilterIndex = FilterIndex
  .strFile = Left(Filename & String$(255, 0), 255)  '用空字符补足全路径文件名255字节
  .nMaxFile = 255                                   '全路径文件名长度
  .strFileTitle = String$(255, 0)                   '用空字符填充(去掉路径的)文件名
  .nMaxFileTitle = 255                              '(去掉路径的)文件名长度
  .strTitle = DialogTitle                           '对话框标题
  .flags = flags
  .strDefExt = ""
  .strInitialDir = InitialDir
  .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