用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