VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DialogCls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Private hWnds As Long 'hWnd 窗口的句柄                                      >
Private Flagss As Long 'sFlags 是可选的，与通用对话框一样，请参阅有关资料   >
Private Colors As Long '颜色对话框和文字对话框Color　属性                   >
Private Mins As Long '字体对话框和打印对话框的Min 属性           >
Private Maxs As Long '字体对话框和打印对话框的Max 属性            >
Private FileNames As String '返回文件的路径                 >
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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy 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 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 GetOpenFileNamePreview Lib "msvfw32.dll" (ByRef lpofn As OPENFILENAME) As Long
Private Declare Function GetSaveFileNamePreview Lib "msvfw32.dll" Alias "GetSaveFileNamePreviewA" (ByRef lpofn As OPENFILENAME) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long


'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$打开和保存列表对话框公用$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

'***************************************************打开和保存对话框公用*********************************************************************************************************************************
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 Filters As String 'sFilter　是可选的，返回或设置在对话框的类型列表框中所显示的过滤器，与通用框对话一样!
Private Filterss As String '为了返回用户原先的值（不改变Filtersr的值）而设

Private InitDirs As String ''InitDir 是可选的，设置开始的路径

Private DialogTitles As String 'DialogTitle　是可选的，是对话框的标题
Private FileTitles As String 'FileTitle 返回文件名，没有路径

'***************************************************打开和保存对话框公用*********************************************************************************************************************************

'===================================================颜色对话框======================================================================================================
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
'调用颜色对话框
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


Dim CustomColors() As Byte
'===================================================颜色对话框======================================================================================================

'#################################################字体对话框##################################################################################################
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long

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          ' ptr. to a LOGFONT struct
        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

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 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
Const LF_FACESIZE = 32
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const DM_DUPLEX = &H1000&
Const DM_ORIENTATION = &H1&
Const PD_PRINTSETUP = &H40
Const PD_DISABLEPRINTTOFILE = &H80000

Private FontBolds As Boolean   '粗体
Private FontItalics As Boolean   '斜体
Private FontNames As String '字体名称
Private FontSizes As Long '字体大小
Private FontStrikethrus As Boolean '删除线
Private FontUnderlines As Boolean '下划线
'#################################################字体对话框##################################################################################################
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!打印设置对话框!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Private Declare Function PAGESETUPDLG Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long
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

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!打印设置对话框!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&打印对话框&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

Private Declare Function PrintDialog Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG_TYPE) As Long
Private Type PRINTDLG_TYPE
    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 DEVNAMES_TYPE
    wDriverOffset As Integer
    wDeviceOffset As Integer
    wOutputOffset As Integer
    wDefault As Integer
    extra As String * 100
End Type
Private Type DEVMODE_TYPE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&打印对话框&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

Property Get Color() As Long
'返回颜色对话框中所选中的颜色
      Color = Colors
End Property


Property Get flags() As Long
'返回包括了：颜色、打开、保存、打印设置、打印对话框的多种选项CommDialog 的 Flags　属性，与它一样
        flags = Flagss
        
End Property
Property Let flags(ByVal sFlags As Long)
'设置包括了：颜色、打开、保存、打印设置、打印对话框的多种选项CommDialog 的 Flags　属性，与它一样
            Flagss = sFlags
End Property

Public Property Get DialogTitle() As String
'返回打开、保存对话框的标题
        DialogTitle = DialogTitles

End Property

Property Let DialogTitle(ByVal sDialogTitle As String)
'设置打开、保存对话框的标题
            DialogTitles = sDialogTitle
End Property
Property Get InitDir() As String
'返回打开、保存对话框的的初始化路径
             InitDir = InitDirs
End Property
Property Let InitDir(ByVal sInitDir As String)
'设置打开、保存对话框的的初始化路径
        InitDirs = sInitDir
End Property


Property Get Filter() As String
'返回打开、保存对话框的过滤器
            Filter = Filterss
End Property

Property Let Filter(ByVal sFilter As String)
'设置打开、保存对话框的过滤器
Dim S As String
Filterss = sFilter
S = sFilter
sFilter = SwapeStr(S, "|", Chr(0))
               
            Filters = sFilter
             
End Property

Property Get FileName() As String
'返回打开、保存对话框的文件名（包含路径）
            FileName = FileNames
End Property

Property Let FileName(ByVal sFileName As String)
'设置打开、保存对话框的文件名（包含路径）
       If sFileName <> "" Then
          InitDirs = sFileName
       End If
             FileNames = sFileName
End Property
Property Get hWnd() As Long
'返回用户所设置的hWnd　属性值
          hWnd = hWnds
End Property

Property Let hWnd(ByVal shWnd As Long)
'给各API　中所需的句柄（hWnd）赋值（我发现可设为　0）
        hWnds = shWnd
End Property
Public Sub ShowPrinter()
'打开“打印”对话框
    '-> Code by Donald Grover
    Dim PrintDlg As PRINTDLG_TYPE
    Dim DevMode As DEVMODE_TYPE
    Dim DevName As DEVNAMES_TYPE

    Dim lpDevMode As Long, lpDevName As Long
    Dim bReturn As Integer
    Dim objPrinter As Printer, NewPrinterName As String

    ' Use PrintDialog to get the handle to a memory
    ' block with a DevMode and DevName structures

    PrintDlg.lStructSize = Len(PrintDlg)
    PrintDlg.hwndOwner = hWnds

    PrintDlg.flags = Flagss
    On Error Resume Next
    'Set the current orientation and duplex setting
    DevMode.dmDeviceName = Printer.DeviceName
    DevMode.dmSize = Len(DevMode)
    DevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX
    DevMode.dmPaperWidth = Printer.Width
    DevMode.dmOrientation = Printer.Orientation
    DevMode.dmPaperSize = Printer.PaperSize
    DevMode.dmDuplex = Printer.Duplex
    On Error GoTo 0

    'Allocate memory for the initialization hDevMode structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevMode))
    lpDevMode = GlobalLock(PrintDlg.hDevMode)
    If lpDevMode > 0 Then
        CopyMemory ByVal lpDevMode, DevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
    End If

    'Set the current driver, device, and port name strings
    With DevName
        .wDriverOffset = 8
        .wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
        .wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
        .wDefault = 0
    End With

    With Printer
        DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
    End With

    'Allocate memory for the initial hDevName structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
    lpDevName = GlobalLock(PrintDlg.hDevNames)
    If lpDevName > 0 Then
        CopyMemory ByVal lpDevName, DevName, Len(DevName)
        bReturn = GlobalUnlock(lpDevName)
    End If

    'Call the print dialog up and let the user make changes
    If PrintDialog(PrintDlg) <> 0 Then

        'First get the DevName structure.
        lpDevName = GlobalLock(PrintDlg.hDevNames)
        CopyMemory DevName, ByVal lpDevName, 45
        bReturn = GlobalUnlock(lpDevName)
        GlobalFree PrintDlg.hDevNames

        'Next get the DevMode structure and set the printer
        'properties appropriately
        lpDevMode = GlobalLock(PrintDlg.hDevMode)
        CopyMemory DevMode, ByVal lpDevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
        GlobalFree PrintDlg.hDevMode
        NewPrinterName = UCase$(Left(DevMode.dmDeviceName, InStr(DevMode.dmDeviceName, Chr$(0)) - 1))
        If Printer.DeviceName <> NewPrinterName Then
            For Each objPrinter In Printers
               If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                    Set Printer = objPrinter
                    'set printer toolbar name at this point
               End If
            Next
        End If

        On Error Resume Next
        'Set printer object properties according to selections made
        'by user
        Printer.Copies = DevMode.dmCopies
        Printer.Duplex = DevMode.dmDuplex
        Printer.Orientation = DevMode.dmOrientation
        Printer.PaperSize = DevMode.dmPaperSize
        Printer.PrintQuality = DevMode.dmPrintQuality
        Printer.ColorMode = DevMode.dmColor
        Printer.PaperBin = DevMode.dmDefaultSource
        On Error GoTo 0
    End If
End Sub



Public Function ShowPageSetupDlg() As Long
'返回－1　表示用户按了“取消”键
    Dim m_PSD As PAGESETUPDLG
    'Set the structure size
    m_PSD.lStructSize = Len(m_PSD)
    'Set the owner window
    m_PSD.hwndOwner = hWnds
    'Set the application instance
    m_PSD.hInstance = App.hInstance
    'no extra flags
    m_PSD.flags = Flagss

    'Show the pagesetup dialog
    If PAGESETUPDLG(m_PSD) Then
        ShowPageSetupDlg = 0
    Else
        ShowPageSetupDlg = -1
    End If
End Function



Public Sub ShowColor()
'打开COLOR　对话框 Colors 返回－1表示用户按了"取消"键
    Dim cc As CHOOSECOLOR
    Dim Custcolor(16) As Long
    Dim lReturn As Long

    'set the structure size
    cc.lStructSize = Len(cc)
    'Set the owner
    cc.hwndOwner = hWnds
    'set the application's instance
    cc.hInstance = App.hInstance
    'set the custom colors (converted to Unicode)
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    'no extra flags
    cc.flags = Flagss

    'Show the 'Select Color'-dialog
    If CHOOSECOLOR(cc) <> 0 Then
        
        Colors = cc.rgbResult
        CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
    Else
        Colors = -1
    End If




End Sub




Public Sub ShowOpen()
'FileNames 返回文件的全路径，如果返回：Canceled 即用户按了 取消 按钮!
    Dim ofn As OPENFILENAME
    Dim rtn As String
    Dim Str As String, i As Integer, S As String
    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = hWnds
    ofn.hInstance = App.hInstance
     
    ofn.lpstrFilter = Filters      ' "Txt" + Chr$(0) + "*.txt" + Chr(0) + "Bmp" + Chr(0) + "*.bmp" + Chr(0)
     
    ofn.lpstrFile = Space(254)
    ofn.nMaxFile = 255
    ofn.lpstrFileTitle = Space(254)
    ofn.nMaxFileTitle = 255
     
    ofn.lpstrInitialDir = InitDirs
    ofn.lpstrTitle = DialogTitles
    ofn.flags = Flagss
     
     
       rtn = GetOpenFileName(ofn)
     
    If rtn >= 1 Then
        FileNames = Left(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr(0)) - 1)
        Str = FileNames
        
        S = Str
        For i = 1 To Len(Str)
             If Right(S, 1) = "\" Then
               
                 FileTitles = Right(Str, i - 1) '返回文件名：FileTitle 属性
                 Exit For
             Else
                   S = Left(S, Len(S) - 1)
                    
             End If
        Next i
    Else
        FileNames = "Canceled"
    End If
     
End Sub

Public Sub ShowSave()

'FileNames 返回文件的全路径，如果返回：Canceled 即用户按了 取消 按钮!
    Dim ofn As OPENFILENAME
    Dim rtn As String
    Dim Str As String, i As Integer, S As String

    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = hWnds
    ofn.hInstance = App.hInstance
     
    ofn.lpstrFilter = Filters      ' "Txt" + Chr$(0) + "*.txt" + Chr(0) + "Bmp" + Chr(0) + "*.bmp" + Chr(0)
     
    ofn.lpstrFile = Space(254)
    ofn.nMaxFile = 255
    ofn.lpstrFileTitle = Space(254)
    ofn.nMaxFileTitle = 255
     
    ofn.lpstrInitialDir = InitDirs
    ofn.lpstrTitle = DialogTitles
    ofn.flags = Flagss
     
     
       rtn = GetSaveFileName(ofn)
     
    If rtn >= 1 Then
        
        FileNames = Left(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr(0)) - 1)
        
        Str = FileNames
        
        S = Str
        For i = 1 To Len(Str)
             If Right(S, 1) = "\" Then
               
                 FileTitles = Right(Str, i - 1) '返回文件名：FileTitle 属性
                 Exit For
             Else
                   S = Left(S, Len(S) - 1)
                    
             End If
        Next i
    Else
        FileNames = "Canceled"
    End If
     
        
End Sub


Private Function SwapeStr(ByVal Strs As String, A As String, B As String) As String
'为一个字串内的字符做调换工作
'Strs 要对调的字串
'A 要对调的字符（即在Strs字串的字符）
'B 它用来代替A的字符
             Dim i As Integer, S As String, Str As String, ST As String, P As Integer
             S = vbNullString
             Str = Strs
             ST = Strs
             For i = 1 To Len(Str)
                 If Mid(Str, i, 1) = A Then
                     
                    S = S & Left(ST, i - 1 - P) & B
                     
                    ST = Right(Str, Len(Str) - i)
                    P = i
                 End If
             Next i
             SwapeStr = S & ST & Chr(0)
End Function
Public Sub ShowFont()
'打开字体对话框
On Error Resume Next
Dim cf As CHOOSEFONT, lFont As LOGFONT, hMem As Long, pMem As Long, Fs 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 = 0 ' 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 = hWnds ' 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 = FontSizes * 10 ' 12 point font (in units of 1/10 point)
    cf.flags = Flagss
    cf.rgbColors = Colors
     
    cf.nFontType = REGULAR_FONTTYPE ' regular font type i.e. not bold or anything
    cf.nSizeMin = Mins ' minimum point size
    cf.nSizeMax = Maxs ' 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.
    retval = CHOOSEFONT(cf) ' open the dialog box
    If retval <> 0 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.
        FontNames = Left(lFont.lfFaceName, InStr(lFont.lfFaceName, vbNullChar) - 1)
        
        If lFont.lfItalic > 0 Then FontItalics = True Else FontItalics = False
        If lFont.lfUnderline > 0 Then FontUnderlines = True Else FontUnderlines = False
        If lFont.lfStrikeOut > 0 Then FontStrikethrus = True Else FontStrikethrus = False
        If lFont.lfWeight > 400 Then FontBolds = True Else FontBolds = False
        Colors = cf.rgbColors
    Else
          FontNames = "宋体"
    End If
            FontSizes = cf.iPointSize / 10
    ' 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 Sub

Property Get FontUnderline() As Boolean
'返回字体的下划线的　布尔顿　值
          FontUnderline = FontUnderlines
End Property

Property Get FontStrikethru() As Boolean
'返回字体的删除线的　布尔顿　值
             FontStrikethru = FontStrikethrus
End Property

Property Get FontSize() As Long
'返回字体大小号数
            FontSize = FontSizes
              
End Property


Property Get FontName() As String
'返回字体的名称
          FontName = FontNames
End Property

Property Get FontItalic() As Boolean
'返回字体的斜体　布尔顿　值
        
        FontItalic = FontItalics
End Property

Property Get FontBold() As Boolean
'返回字体的粗体　布尔顿　值
            FontBold = FontBolds
End Property

Property Get Min() As Long
'返回字体的最小号数
       Min = Mins

End Property

Property Let Min(sMin As Long)
'设置字体的最小号数
        Mins = sMin
End Property
Property Get Max() As Long
'返回字体的最大号数
        Max = Maxs
        
End Property
Property Let Max(sMax As Long)
'设置字体的最大号数
        Maxs = sMax
End Property

Property Get FileTitle() As String
'只读属性,返回文件名，没有路径
        
               FileTitle = FileTitles
End Property
Public Sub ShowOpenPreview()
'新型的打开列表对话框
Dim ofn As OPENFILENAME, Ret As Long, Str As String, i As Integer, S As String
    With ofn
        .lStructSize = Len(ofn)
        .hInstance = App.hInstance
        .hwndOwner = hWnds
        .lpstrTitle = DialogTitles
        .lpstrFilter = Filters
        .lpstrFile = String(255, 0)
        .nMaxFile = 255
        .flags = Flagss
    End With
    Ret = GetOpenFileNamePreview(ofn)
    If Ret <> 0 Then
        CloseHandle Ret
                  
        FileNames = Left(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr(0)) - 1)
        Str = FileNames
        
        S = Str
        For i = 1 To Len(Str)
             If Right(S, 1) = "\" Then
               
                 FileTitles = Right(Str, i - 1) '返回文件名：FileTitle 属性
                 Exit For
             Else
                   S = Left(S, Len(S) - 1)
                    
             End If
        Next i
    Else
        FileNames = "Canceled"
    End If


End Sub
Public Sub ShowSavePreview()
'新型的保存列表对话框
       Dim ofn As OPENFILENAME, Ret As Long, Str As String, i As Integer, S As String
    With ofn
        .lStructSize = Len(ofn)
        .hInstance = App.hInstance
        .hwndOwner = hWnds
        .lpstrTitle = DialogTitles
        .lpstrFilter = Filters
        .lpstrFile = String(255, 0)
        .nMaxFile = 255
        .flags = Flagss
    End With
    Ret = GetSaveFileNamePreview(ofn)
    If Ret <> 0 Then
        CloseHandle Ret
                  
        FileNames = Left(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr(0)) - 1)
        Str = FileNames
        
        S = Str
        For i = 1 To Len(Str)
             If Right(S, 1) = "\" Then
               
                 FileTitles = Right(Str, i - 1) '返回文件名：FileTitle 属性
                 Exit For
             Else
                   S = Left(S, Len(S) - 1)
                    
             End If
        Next i
    Else
        FileNames = "Canceled"
    End If
End Sub

Private Sub Class_Initialize()
'类模块的初始化
ReDim CustomColors(0 To 16 * 4 - 1) As Byte
    Dim i As Integer
    For i = LBound(CustomColors) To UBound(CustomColors)
        CustomColors(i) = 0
    Next i
     
End Sub