用API实现WINDOWS下的通用对话框!

　　大家在写程序的时候，难免会用到ＷＩＮＤＯＷＳ的通用对话框，如打开、保存、字体、颜色、打印等。这些通用对话框在外部控件里可以加载，不过打包的时候还要带上控件，所以会很麻烦，并且会加大安装程序的大小。笔者通过实践，总结出了通过ＡＰＩ实现这些对话框的方法，写出来与大家分享。

程序源码可以到本人的网站上去下载：http://www.j2soft.cn/

　　　　　　　　　　　　　　　　　　　　　　　　　　崔占民

　　　　　　　　　　　　　　　　　　　　　　EMAIL:[email protected]

 

定义一个类模块，方法：工程－>添加类模块。代码如下：

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
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 PRINTDLG
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    hdc As Long
    Flags As Long
    nFromPage As Integer
    nToPage As Integer
    nMinPage As Integer
    nMaxPage As Integer
    nCopies As Integer
    hInstance As Long
    lCustData As Long
    lpfnPrintHook As Long
    lpfnSetupHook As Long
    lpPrintTemplateName As String
    lpSetupTemplateName As String
    hPrintTemplate As Long
    hSetupTemplate As Long
End Type

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 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 * 31
End Type

Private Type CHOOSEFONT
    lStructSize As Long
    hwndOwner As Long          '  caller's window handle
    hdc As Long                '  printer DC/IC or NULL
    lpLogFont As Long
    iPointSize As Long         '  10 * size in points of selected font
    Flags As Long              '  enum. type flags
    rgbColors As Long          '  returned text color
    lCustData As Long          '  data passed to hook fn.
    lpfnHook As Long           '  ptr. to hook function
    lpTemplateName As String     '  custom template name
    hInstance As Long          '  instance handle of.EXE that
                                   '    contains cust. dlg. template
    lpszStyle As String          '  return the style field here
                                   '  must be LF_FACESIZE or bigger
    nFontType As Integer          '  same value reported to the EnumFonts
                                   '    call back with the extra FONTTYPE_
                                   '    bits added
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long           '  minimum pt size allowed &
    nSizeMax As Long           '  max pt size allowed if
                                       '    CF_LIMITSIZE is used
End Type

Private Type FINDREPLACE
    lStructSize As Long        '  size of this struct 0x20
    hwndOwner As Long          '  handle to owner's window
    hInstance As Long          '  instance handle of.EXE that
                                '    contains cust. dlg. template
    Flags As Long              '  one or more of the FR_ 
    lpstrFindWhat As String      '  ptr. to search string
    lpstrReplaceWith As String   '  ptr. to replace string
    wFindWhatLen As Integer       '  size of find buffer
    wReplaceWithLen As Integer    '  size of replace buffer
    lCustData As Long          '  data passed to hook fn.
    lpfnHook As Long            '  ptr. to hook fn. or NULL
    lpTemplateName As String     '  custom template name
End Type

Private Type PAGESETUPDLG
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    Flags As Long
    ptPaperSize As POINTAPI
    rtMinMargin As RECT
    rtMargin As RECT
    hInstance As Long
    lCustData As Long
    lpfnPageSetupHook As Long
    lpfnPagePaintHook As Long
    lpPageSetupTemplateName As String
    hPageSetupTemplate As Long
End Type

Public Enum FileFlags
    OFN_ALLOWMULTISELECT = &H200
    OFN_CREATEPROMPT = &H2000
    OFN_ENABLEHOOK = &H20
    OFN_ENABLETEMPLATE = &H40
    OFN_ENABLETEMPLATEHANDLE = &H80
    OFN_EXPLORER = &H80000                         '  new look commdlg
    OFN_EXTENSIONDIFFERENT = &H400
    OFN_FILEMUSTEXIST = &H1000
    OFN_HIDEREADONLY = &H4
    OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules
    OFN_NOCHANGEDIR = &H8
    OFN_NODEREFERENCELINKS = &H100000
    OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules
    OFN_NONETWORKBUTTON = &H20000
    OFN_NOREADONLYRETURN = &H8000
    OFN_NOTESTFILECREATE = &H10000
    OFN_NOVALIDATE = &H100
    OFN_OVERWRITEPROMPT = &H2
    OFN_PATHMUSTEXIST = &H800
    OFN_READONLY = &H1
    OFN_SHAREAWARE = &H4000
    OFN_SHAREFALLTHROUGH = 2
    OFN_SHARENOWARN = 1
    OFN_SHAREWARN = 0
    OFN_SHOWHELP = &H10
   
    PD_ALLPAGES = &H0
    PD_COLLATE = &H10
    PD_DISABLEPRINTTOFILE = &H80000
    PD_ENABLEPRINTHOOK = &H1000
    PD_ENABLEPRINTTEMPLATE = &H4000
    PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
    PD_ENABLESETUPHOOK = &H2000
    PD_ENABLESETUPTEMPLATE = &H8000
    PD_ENABLESETUPTEMPLATEHANDLE = &H20000
    PD_HIDEPRINTTOFILE = &H100000
    PD_NONETWORKBUTTON = &H200000
    PD_NOPAGENUMS = &H8
    PD_NOSELECTION = &H4
    PD_NOWARNING = &H80
    PD_PAGENUMS = &H2
    PD_PRINTSETUP = &H40
    PD_PRINTTOFILE = &H20
    PD_RETURNDC = &H100
    PD_RETURNDEFAULT = &H400
    PD_RETURNIC = &H200
    PD_SELECTION = &H1
    PD_SHOWHELP = &H800
    PD_USEDEVMODECOPIES = &H40000
    PD_USEDEVMODECOPIESANDCOLLATE = &H40000
End Enum

Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function PrintDialog Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG) As Long
Private Declare Function ChooseColorDialog Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Function FindText Lib "comdlg32.dll" Alias "FindTextA " (pFindreplace As FINDREPLACE) As Long
Private Declare Function PAGESETUPDLG Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long
Private Declare Function ReplaceText Lib "comdlg32.dll" Alias "ReplaceTextA" (pFindreplace As FINDREPLACE) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

' FileOpen 类成员变量 =====================================================
Private m_lngHwnd As Long
Private m_lngInstance As Long
Private m_strFileName As String
Private m_strFileTitle As String
Private m_strInitDir As String
Private m_strDialogTitle As String
Private m_strFilter As String
Private m_lngFlags As Long

' Print 类成员变量 =====================================================
Private m_lngCopies As Long
Private m_lngFromPage As Long
Private m_lngToPage As Long
Private m_lngMaxPage As Long
Private m_lngMinPage As Long

' Print 类成员变量 =====================================================
Private m_lngColor As Long

' Font 类成员变量 =====================================================
Private m_strFontName As String
Private m_lngFontColor As Long
Private m_lngFontSize As Long
Private m_lngCharSet As Long
Private m_bolItalic As Boolean
Private m_bolStrikeOut As Boolean
Private m_bolUnderline As Boolean
Private m_bolBlob As Boolean

' PageSetup 类成员变量 =====================================================
Private m_lngPaperWidth As Long
Private m_lngPaperHeight As Long
Private m_lngMarginLeft As Long
Private m_lngMarginTop As Long
Private m_lngMarginRight As Long
Private m_lngMarginBottom As Long

' FileOpen 类实现 =========================================================
Public Function ShowOpen() As Boolean
    Dim fName As String, sName As String, OfName As OPENFILENAME
   
    OfName.lStructSize = Len(OfName)
    OfName.hwndOwner = m_lngHwnd
    OfName.hInstance = m_lngInstance
    OfName.lpstrInitialDir = m_strInitDir
    OfName.lpstrFilter = m_strFilter
    OfName.lpstrFile = Space(255) & Chr(0)
    OfName.nMaxFile = 256
    OfName.lpstrFileTitle = Space(255) & Chr(0)
    OfName.nMaxFileTitle = 256
    OfName.lpstrTitle = m_strDialogTitle
    OfName.Flags = m_lngFlags
   
    If GetOpenFileName(OfName) Then
        m_strFileName = OfName.lpstrFile
        m_strFileTitle = OfName.lpstrFileTitle

        ShowOpen = True
    Else
        ShowOpen = False
    End If
End Function

Public Property Get Filter() As String
    Filter = m_strFilter
End Property

Public Property Let Filter(ByVal vNewValue As String)
    m_strFilter = Replace(vNewValue, "|", Chr(0)) & Chr(0)
End Property

Public Property Get Flags() As FileFlags
    Flags = m_lngFlags
End Property

Public Property Let Flags(ByVal vNewValue As FileFlags)
    m_lngFlags = vNewValue
End Property

Public Property Get DialogTitle() As String
    DialogTitle = m_strDialogTitle
End Property

Public Property Let DialogTitle(ByVal vNewValue As String)
    m_strDialogTitle = vNewValue
End Property

Public Property Get InitDir() As String
    InitDir = m_strInitDir
End Property

Public Property Let InitDir(ByVal vNewValue As String)
    m_strInitDir = vNewValue
End Property

Public Property Get FileTitle() As String
    FileTitle = m_strFileTitle
End Property

Public Property Let FileTitle(ByVal vNewValue As String)
    m_strFileTitle = vNewValue
End Property

Public Property Get FileName() As String
    FileName = m_strFileName
End Property

Public Property Let FileName(ByVal vNewValue As String)
    m_strFileName = vNewValue
End Property

Public Property Get Hwnd() As Long
    Hwnd = m_lngHwnd
End Property

Public Property Let Hwnd(ByVal vNewValue As Long)
    m_lngHwnd = vNewValue
End Property

Public Property Get Instance() As Long
    Instance = m_lngInstance
End Property

Public Property Let Instance(ByVal vNewValue As Long)
    m_lngInstance = vNewValue
End Property

' FileSave 类实现 =========================================================
Public Function ShowSave() As Boolean
    Dim fName As String, sName As String, OfName As OPENFILENAME
   
    OfName.lStructSize = Len(OfName)
    OfName.hwndOwner = m_lngHwnd
    OfName.hInstance = m_lngInstance
    OfName.lpstrInitialDir = m_strInitDir
    OfName.lpstrFilter = m_strFilter
    OfName.lpstrFile = Space(255) & Chr(0)
    OfName.nMaxFile = 256
    OfName.lpstrFileTitle = Space(255) & Chr(0)
    OfName.nMaxFileTitle = 256
    OfName.lpstrTitle = m_strDialogTitle
    OfName.Flags = m_lngFlags
   
    If GetSaveFileName(OfName) Then
        m_strFileName = OfName.lpstrFile
        m_strFileTitle = OfName.lpstrFileTitle

        ShowSave = True
    Else
        ShowSave = False
    End If
End Function

' Print 类实现 =========================================================
Public Function ShowPrint() As Boolean
    Dim PrtDlg As PRINTDLG
   
    PrtDlg.lStructSize = Len(PrtDlg)
    PrtDlg.hwndOwner = m_lngHwnd
    PrtDlg.hInstance = m_lngInstance
    PrtDlg.nCopies = m_lngCopies
    PrtDlg.nFromPage = m_lngFromPage
    PrtDlg.nMaxPage = m_lngMaxPage
    PrtDlg.nMinPage = m_lngMinPage
    PrtDlg.nToPage = m_lngToPage
    PrtDlg.Flags = m_lngFlags
       
    If PrintDialog(PrtDlg) Then
        m_lngCopies = PrtDlg.nCopies
        m_lngFromPage = PrtDlg.nFromPage
        m_lngMaxPage = PrtDlg.nMaxPage
        m_lngMinPage = PrtDlg.nMinPage
        m_lngToPage = PrtDlg.nToPage

        ShowPrint = True
    Else
        ShowPrint = False
    End If
End Function

Public Property Get Copies() As Long
    Copies = m_lngCopies
End Property

Public Property Let Copies(ByVal vNewValue As Long)
    m_lngCopies = vNewValue
End Property

Public Property Get FromPage() As Long
    FromPage = m_lngFromPage
End Property

Public Property Let FromPage(ByVal vNewValue As Long)
    m_lngFromPage = vNewValue
End Property

Public Property Get ToPage() As Long
    ToPage = m_lngToPage
End Property

Public Property Let ToPage(ByVal vNewValue As Long)
    m_lngToPage = vNewValue
End Property

Public Property Get MaxPage() As Long
    MaxPage = m_lngMaxPage
End Property

Public Property Let MaxPage(ByVal vNewValue As Long)
    m_lngMaxPage = vNewValue
End Property

Public Property Get MinPage() As Long
    MinPage = m_lngMinPage
End Property

Public Property Let MinPage(ByVal vNewValue As Long)
    m_lngMinPage = vNewValue
End Property

' ChooseColorDialog 类实现 =========================================================
Public Function ShowColor() As Boolean
    Dim i As Integer
    Dim ClrDlg As CHOOSECOLOR, CustomColors() As Byte

    ReDim CustomColors(0 To 63) As Byte
    For i = LBound(CustomColors) To UBound(CustomColors)
        CustomColors(i) = 0
    Next i

    ClrDlg.lStructSize = Len(ClrDlg)
    ClrDlg.hwndOwner = m_lngHwnd
    ClrDlg.hInstance = m_lngInstance
    ClrDlg.lpCustColors = StrConv(CustomColors, vbUnicode)
 
    If ChooseColorDialog(ClrDlg) Then
        m_lngColor = ClrDlg.rgbResult
        CustomColors = StrConv(ClrDlg.lpCustColors, vbFromUnicode)

        ShowColor = True
    Else
        ShowColor = False
    End If
End Function

Public Property Get Color() As Long
    Color = m_lngColor
End Property

Public Property Let Color(ByVal vNewValue As Long)
    m_lngColor = vNewValue
End Property

' Font 类实现 =========================================================
Public Function ShowFont() As Boolean
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim FontName As String, retval As Long
   
    lfont.lfHeight = 0  ' determine default height
    lfont.lfWidth = 0  ' determine default width
    lfont.lfEscapement = 0  ' angle between baseline and escapement vector
    lfont.lfOrientation = 0  ' angle between baseline and orientation vector
    lfont.lfWeight = FW_NORMAL  ' normal weight I.e. Not bold
    lfont.lfCharSet = DEFAULT_CHARSET  ' use default character set
    lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
    lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
    lfont.lfQuality = DEFAULT_QUALITY  ' default quality setting
    lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
    lfont.lfFaceName = "Times New Roman" & vbNullChar  ' string must be null-terminated
    ' Create the memory block which will act as the LOGFONT structure buffer.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)  ' lock and get pointer
    CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
   
    ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
    cf.lStructSize = Len(cf)  ' size of structure
    cf.hwndOwner = m_lngHwnd  ' window Form1 is opening this dialog box
    cf.hdc = Printer.hdc  ' device context of default printer (using VB's mechanism)
    cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
    cf.iPointSize = 120  ' 12 point font (in units of 1/10 point)
    cf.Flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.rgbColors = RGB(0, 0, 0)  ' black
    cf.nFontType = REGULAR_FONTTYPE  ' regular font type I.e. Not bold or anything
    cf.nSizeMin = 1  ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
    ' and then print out the attributes we mentioned earlier that the user selected.
   
    If CHOOSEFONT(cf) Then  ' success
        CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
        ' Now make the fixed-length string holding the font name into a "normal" string.
        m_strFontName = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
        m_lngFontColor = cf.rgbColors
        m_lngFontSize = cf.iPointSize / 10
        m_lngCharSet = lfont.lfCharSet
        m_bolItalic = lfont.lfItalic = 255
        m_bolStrikeOut = lfont.lfStrikeOut = 1
        m_bolUnderline = lfont.lfUnderline = 1
        m_bolBlob = lfont.lfWeight >= 700
        ShowFont = True
    Else
        ShowFont = False
    End If
    ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    retval = GlobalFree(hMem)  ' free the allocated memory
End Function

Public Property Get FontName() As String
    FontName = m_strFontName
End Property

Public Property Let FontName(ByVal vNewValue As String)
    m_strFontName = vNewValue
End Property

Public Property Get FontColor() As Long
    FontColor = m_lngFontColor
End Property

Public Property Let FontColor(ByVal vNewValue As Long)
    m_lngFontColor = vNewValue
End Property

Public Property Get FontSize() As Long
    FontSize = m_lngFontSize
End Property

Public Property Let FontSize(ByVal vNewValue As Long)
    m_lngFontSize = vNewValue
End Property

Public Property Get CharSet() As Long
    CharSet = m_lngCharSet
End Property

Public Property Let CharSet(ByVal vNewValue As Long)
    m_lngCharSet = vNewValue
End Property

Public Property Get Italic() As Boolean
    Italic = m_bolItalic
End Property

Public Property Let Italic(ByVal vNewValue As Boolean)
    m_bolItalic = vNewValue
End Property

Public Property Get StrikeOut() As Boolean
    StrikeOut = m_bolStrikeOut
End Property

Public Property Let StrikeOut(ByVal vNewValue As Boolean)
    m_bolStrikeOut = vNewValue
End Property

Public Property Get Underline() As Boolean
    Underline = m_bolUnderline
End Property

Public Property Let Underline(ByVal vNewValue As Boolean)
    m_bolUnderline = vNewValue
End Property

Public Property Get FontBlob() As Boolean
    FontBlob = m_bolBlob
End Property

Public Property Let FontBlob(ByVal vNewValue As Boolean)
    m_bolBlob = vNewValue
End Property

' Find 类实现 =========================================================
Public Function ShowFind() As Boolean
    Dim lFind As FINDREPLACE

    lFind.lStructSize = Len(lFind)
    lFind.hwndOwner = m_lngHwnd
    lFind.hInstance = m_lngInstance
    lFind.wFindWhatLen = 255
   
'    If FindText(lFind) Then
'        ShowFind = True
'    Else
'        ShowFind = False
'    End If
End Function

' Replace 类实现 =========================================================
Public Function ShowReplace() As Boolean
    Dim lFind As FINDREPLACE

    lFind.lStructSize = Len(lFind)
    lFind.hwndOwner = m_lngHwnd
    lFind.hInstance = m_lngInstance
    lFind.wFindWhatLen = 255
   
    If ReplaceText(lFind) Then
        ShowReplace = True
    Else
        ShowReplace = False
    End If
End Function

' Replace 类实现 =========================================================
Public Function ShowPageSetup() As Boolean
    Dim lPageSetup As PAGESETUPDLG

    lPageSetup.lStructSize = Len(lPageSetup)
    lPageSetup.hwndOwner = m_lngHwnd
    lPageSetup.hInstance = m_lngInstance

    If PAGESETUPDLG(lPageSetup) Then
        m_lngPaperWidth = lPageSetup.ptPaperSize.x
        m_lngPaperHeight = lPageSetup.ptPaperSize.y
        m_lngMarginLeft = lPageSetup.rtMargin.Left
        m_lngMarginTop = lPageSetup.rtMargin.Top
        m_lngMarginRight = lPageSetup.rtMargin.Right
        m_lngMarginBottom = lPageSetup.rtMargin.Bottom
       
        ShowPageSetup = True
    Else
        ShowPageSetup = False
    End If
End Function

Public Property Get PaperWidth() As Long
    PaperWidth = m_lngPaperWidth
End Property

Public Property Let PaperWidth(ByVal vNewValue As Long)
    m_lngPaperWidth = vNewValue
End Property

Public Property Get PaperHeight() As Long
    PaperHeight = m_lngPaperHeight
End Property

Public Property Let PaperHeight(ByVal vNewValue As Long)
    m_lngPaperHeight = vNewValue
End Property

Public Property Get MarginLeft() As Long
    MarginLeft = m_lngMarginLeft
End Property

Public Property Let MarginLeft(ByVal vNewValue As Long)
    m_lngMarginLeft = vNewValue
End Property

Public Property Get MarginTop() As Long
    MarginTop = m_lngMarginTop
End Property

Public Property Let MarginTop(ByVal vNewValue As Long)
    m_lngMarginTop = vNewValue
End Property

Public Property Get MarginRight() As Long
    MarginRight = m_lngMarginRight
End Property

Public Property Let MarginRight(ByVal vNewValue As Long)
    m_lngMarginRight = vNewValue
End Property

Public Property Get MarginBottom() As Long
    MarginBottom = m_lngMarginBottom
End Property

Public Property Let MarginBottom(ByVal vNewValue As Long)
    m_lngMarginBottom = vNewValue
End Property

在窗口中添加六个按钮，分别用来实现调用这几个通用对话框，代码如下：

Option Explicit

Dim dlg As CDialog

Private Sub Command1_Click()
    dlg.Hwnd = Hwnd
    dlg.Filter = "WORD文档|*.doc;*.html"
    dlg.Flags = OFN_ALLOWMULTISELECT + OFN_EXPLORER + OFN_PATHMUSTEXIST
    dlg.InitDir = "D:/"
    dlg.DialogTitle = "(昱豪)打开文件..."
   
    If dlg.ShowOpen Then
        MsgBox dlg.FileName
        MsgBox dlg.FileTitle
    End If
End Sub

Private Sub Command2_Click()
    dlg.Hwnd = Hwnd
    dlg.Filter = "WORD文档|*.doc;*.html"
    dlg.Flags = OFN_ALLOWMULTISELECT + OFN_EXPLORER + OFN_PATHMUSTEXIST
    dlg.InitDir = "D:/"
    dlg.DialogTitle = "(昱豪)保存文件..."
   
    If dlg.ShowSave Then
        MsgBox dlg.FileName
        MsgBox dlg.FileTitle
    End If
End Sub

Private Sub Command3_Click()
    dlg.Hwnd = Hwnd
    dlg.Flags = PD_SELECTION + PD_USEDEVMODECOPIES
   
    If dlg.ShowPrint Then
        MsgBox "Copies:" & dlg.Copies & vbCrLf & _
            "FromPage:" & dlg.FromPage & vbCrLf & _
            "ToPage:" & dlg.ToPage & vbCrLf & _
            "MaxPage:" & dlg.MaxPage & vbCrLf & _
            "MinPage:" & dlg.MinPage
    End If
End Sub

Private Sub Command4_Click()
    dlg.Hwnd = Hwnd
   
    If dlg.ShowColor Then
        BackColor = dlg.Color
    End If
End Sub

Private Sub Command5_Click()
    dlg.Hwnd = Hwnd
   
    If dlg.ShowFont Then
        MsgBox "FontName:" & dlg.FontName & vbCrLf & _
            "FontColor:" & dlg.FontColor & vbCrLf & _
            "FontSize:" & dlg.FontSize & vbCrLf & _
            "CharSet:" & dlg.CharSet & vbCrLf & _
            "Italic:" & dlg.Italic & vbCrLf & _
            "StrikeOut:" & dlg.StrikeOut & vbCrLf & _
            "Underline:" & dlg.Underline & vbCrLf & _
            "Blob:" & dlg.FontBlob
    End If
End Sub

Private Sub Command6_Click()
    dlg.Hwnd = Hwnd
    If dlg.ShowFind Then
       
    End If
End Sub

Private Sub Command7_Click()
    dlg.Hwnd = Hwnd
   
    If dlg.ShowPageSetup Then
        MsgBox "PageWeight:" & dlg.PaperWidth & vbCrLf & _
            "PageHeight:" & dlg.PaperHeight & vbCrLf & _
            "MarginLeft:" & dlg.MarginLeft & vbCrLf & _
            "MarginTop:" & dlg.MarginTop & vbCrLf & _
            "MarginRight:" & dlg.MarginRight & vbCrLf & _
            "MarginBottom:" & dlg.MarginBottom
    End If
End Sub

Private Sub Command8_Click()
    dlg.Hwnd = Hwnd
   
    If dlg.ShowReplace Then
       
    End If
End Sub

Private Sub Form_Load()
    Set dlg = New CDialog
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Set dlg = Nothing
End Sub

　　只要在工程中把这前面介绍的类文件加进去就可以使用了，不用外部的控件，安装的时候也省了一些控件，结省了空间！！