VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ComDlgNoOcx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'This is a simple Common Dialog class which will allow a user to
'invoke all Windows Common dialogs without using an OCX

'************************************************
'Functions:

'OpenDialog(WindowHandle, "Batch Files (*.bat)" & Chr(0) & "*.BAT" & Chr(0) & "Text Files (*.txt)" & Chr(0) & "*.TXT" & Chr(0) & "Reg Files (*.reg)" & Chr(0) & "*.REG" & Chr(0), 1, "Open")
'SaveDialog(WindowHandle, "Batch Files (*.bat)" & Chr(0) & "*.BAT" & Chr(0) & "Text Files (*.txt)" & Chr(0) & "*.TXT" & Chr(0), 1, "Save")
'SaveAsDialog(WindowHandle, "Batch Files (*.bat)" & Chr(0) & "*.BAT" & Chr(0) & "Text Files (*.txt)" & Chr(0) & "*.TXT" & Chr(0), 1, "SaveAs")
'PrintDialog(WindowHandle , 0)
'PrintSetupDialog(WindowHandle)
'FontsDialog(WindowHandle , "Arial", 36)
'ColorDialog(WindowHandle, 1, RGB(101, 128, 74))


'****************************************************
'Properties:

'intRed
'intGreen
'intBlue
'boolFontBold
'boolFontItalic
'boolFontUnderLine
'intFontSize
'strFontName
'strFontWeight
'*****************************************************


Option Explicit

'*************
'* Types     *
'*************

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 POINTAPI
        x As Long
        Y As Long
End Type

'LOGFONT constants
Private Const LF_FACESIZE = 31
Private Const LF_FULLFACESIZE = 63


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(LF_FACESIZE) As Byte 'this value should be 31 instead of 32 as an array of (32) actually contains 33 items in VBA
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


Private Type rect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
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 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 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

Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32

Private Type DEVNAMES
        wDriverOffset As Long
        wDeviceOffset As Long
        wOutputOffset As Long
        wDefault As Long
End Type

Private Type DEVMODE
        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 Long
        dmPelsWidth As Long
        dmPelsHeight As Long
        dmDisplayFlags As Long
        dmDisplayFrequency As Long
End Type


'OpenFileName constants
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules
Private Const OFN_EXPLORER = &H80000                         '  new look commdlg
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0

'ChooseFont error constants
Private Const CFERR_CHOOSEFONTCODES = &H2000
Private Const CFERR_NOFONTS = &H2001
Private Const CFERR_MAXLESSTHANMIN = &H2002

'Print dialog constants
Private Const PD_ALLPAGES = &H0
Private Const PD_SELECTION = &H1
Private Const PD_PAGENUMS = &H2
Private Const PD_NOSELECTION = &H4
Private Const PD_NOPAGENUMS = &H8
Private Const PD_COLLATE = &H10
Private Const PD_PRINTTOFILE = &H20
Private Const PD_PRINTSETUP = &H40
Private Const PD_NOWARNING = &H80
Private Const PD_RETURNDC = &H100
Private Const PD_RETURNIC = &H200
Private Const PD_RETURNDEFAULT = &H400
Private Const PD_SHOWHELP = &H800
Private Const PD_USEDEVMODECOPIES = &H40000
Private Const PD_USEDEVMODECOPIESANDCOLLATE = &H40000
Private Const PD_DISABLEPRINTTOFILE = &H80000
Private Const PD_HIDEPRINTTOFILE = &H100000
Private Const PD_NONETWORKBUTTON = &H200000

'ChooseFont constants
Private Const CF_SCREENFONTS = &H1
Private Const CF_PRINTERFONTS = &H2
Private Const CF_BOTH = CF_SCREENFONTS Or CF_PRINTERFONTS
Private Const CF_SHOWHELP = &H4&
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_USESTYLE = &H80&
Private Const CF_EFFECTS = &H100&
Private Const CF_APPLY = &H200&
Private Const CF_ANSIONLY = &H400&
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_WYSIWYG = &H8000 '  must also have CF_SCREENFONTS CF_PRINTERFONTS
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_TTONLY = &H40000
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_NOSIZESEL = &H200000
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOVERTFONTS = &H1000000


'Character set constants
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const OEM_CHARSET = 255

'ChooseColor constants
Private Const CC_RGBINIT = &H1
Private Const CC_FULLOPEN = &H2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_SHOWHELP = &H8
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_ANYCOLOR = &H100

'constants for API memory functions
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

'API declarations for Common Dialogs
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
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) 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


'API declarations to get the window handle
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'API memory function declarations
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy 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

'global declarations
Dim gstrFontName As String
Dim gstrFontWeight As String
Dim gintFontSize As Integer
Dim glngRGBValue As Long
Dim gblnFontItalic As Boolean, gblnFontUnderline As Boolean
Dim m_PrinterName As String
'---------------------------------------------
' Subroutine: GetWindowHandle
' Action: Retrieve a window handle
' Return: valid window handle on success, 0 on failure
' ------------------------------------------------------------------------------------------------------------
Public Function GetWindowHandle(strClassName As String, strWindowName As String) As Long
'as VBA does not support a Hwnd(window handle)property, we have to
'use this function to get the hwnd
'"ThunderDFrame" is the classname for VBA forms, but "ThunderFormDC"
'is the classname for VB forms. The windowname is always the form's
'caption property.
GetWindowHandle = FindWindow(strClassName, strWindowName)

End Function
'---------------------------------------------
' Function: SaveDialog
' Action: Invoke the Windows Common SaveAs Dialog
' Return: The complete path to the saved file on success, an
' empty string on failure
' ------------------------------------------------------------------------------------------------------------
Public Function SaveDialog(WindowHandle As Long, strFilter As String, intFilterIndex As Long, strTitle As String, Optional strInitDir As String, Optional strInitFile As String) As String
'filter should be in format below
'sFilter = "Batch Files (*.bat)" & Chr(0) & "*.BAT" & Chr(0) & "Text Files (*.txt)" & Chr(0) & "*.TXT" & Chr(0) & "Reg Files (*.reg)" & Chr(0) & "*.REG" & Chr(0)
Dim ofn As OpenFilename
Dim strFileNameBuffer As String
Dim lngApiReturn As Long

On Error GoTo ErrHandler

    If strInitFile <> "" Then

        Dim lngPadding As Long
        lngPadding = 257 - Len(strInitFile)
        strFileNameBuffer = strInitFile & String(lngPadding, 0)
    Else
        strFileNameBuffer = String(257, 0)
    End If
    
 
'initialize the ofn structure
ofn.lStructSize = Len(ofn)
ofn.flags = OFN_HIDEREADONLY
ofn.HwndOwner = WindowHandle
ofn.lpstrFilter = strFilter
ofn.nFilterIndex = intFilterIndex
ofn.lpstrFile = strFileNameBuffer
ofn.nMaxFile = Len(ofn.lpstrFile) - 1
ofn.lpstrFileTitle = ofn.lpstrFile
ofn.nMaxFileTitle = ofn.nMaxFile
ofn.lpstrTitle = strTitle

    If ValidateDir(strInitDir) = vbDirectory Then
        ofn.lpstrInitialDir = strInitDir
    Else
        ofn.lpstrInitialDir = curDir
    End If


'call the API function
lngApiReturn = GetSaveFileName(ofn)

    If lngApiReturn = 0 Then
        SaveDialog = ""
        Exit Function
    Else
       SaveDialog = ofn.lpstrFile
       Exit Function
    End If
    
ErrHandler:

SaveDialog = ""
    
End Function
'---------------------------------------------
' Function: OpenDialog
' Action: Invoke the Windows Common Open Dialog
' Return: The complete path to the opened file on success, an
' empty string on failure
' ------------------------------------------------------------------------------------------------------------
Public Function OpenDialog(WindowHandle As Long, strFilter As String, intFilterIndex As Integer, strTitle As String, Optional strInitialDir As String, Optional strInitialFile As String) As String
Dim ofn As OpenFilename
Dim strFileNameBuffer As String
Dim lngApiReturn As Long
  
On Error GoTo ErrHandler

    'if the initial file string has a value
    'calculate how much padding we need, so that the buffer
    'can hold a long filename on return
    If strInitialFile <> "" Then
        Dim lngPadding As Long
        lngPadding = 257 - Len(strInitialFile)
        strFileNameBuffer = strInitialFile & String(lngPadding, 0)
    Else
        strFileNameBuffer = String(257, 0)
    End If


'initialize the ofn structure
ofn.lStructSize = Len(ofn)
ofn.flags = OFN_HIDEREADONLY
ofn.HwndOwner = WindowHandle
ofn.lpstrFilter = strFilter
ofn.nFilterIndex = intFilterIndex
ofn.lpstrFile = strFileNameBuffer
ofn.nMaxFile = Len(ofn.lpstrFile) - 1
ofn.lpstrFileTitle = ofn.lpstrFile
ofn.nMaxFileTitle = ofn.nMaxFile
ofn.lpstrTitle = strTitle

    If ValidateDir(strInitialDir) = vbDirectory Then
        ofn.lpstrInitialDir = strInitialDir
    Else
        ofn.lpstrInitialDir = curDir
    End If
'call the API function
lngApiReturn = GetOpenFileName(ofn)

    If lngApiReturn = 0 Then
        OpenDialog = ""
        
    Else
        OpenDialog = ofn.lpstrFile
       
    End If
 Exit Function
 
ErrHandler:

OpenDialog = ""

End Function
'---------------------------------------------
' Function: SaveAsDialog
' Action: Invoke the Windows Common SaveAs Dialog
' Return: The complete path to the saved file on success, an
' empty string on failure
' ------------------------------------------------------------------------------------------------------------
Public Function SaveAsDialog(WindowHandle As Long, strFilter As String, intFilterIndex As Long, strTitle As String, Optional strInitDir As String, Optional strInitFile As String, Optional strDefaultExt As String) As String
'filter should be in format below
'strFilter = "Batch Files (*.bat)" & Chr(0) & "*.BAT" & Chr(0) & "Text Files (*.txt)" & Chr(0) & "*.TXT" & Chr(0) & "Reg Files (*.reg)" & Chr(0) & "*.REG" & Chr(0)
Dim ofn As OpenFilename
Dim strFileNameBuffer As String
Dim lngApiReturn As Long

On Error GoTo ErrHandler

    If strInitFile <> "" Then

        Dim lngPadding As Long
        lngPadding = 257 - Len(strInitFile)
        strFileNameBuffer = strInitFile & String(lngPadding, 0)
    Else
        strFileNameBuffer = String(257, 0)
    End If
    
'initialize the ofn structure
ofn.lStructSize = Len(ofn)
ofn.flags = OFN_HIDEREADONLY
ofn.HwndOwner = WindowHandle
ofn.lpstrFilter = strFilter
ofn.nFilterIndex = intFilterIndex
ofn.lpstrFile = strFileNameBuffer
ofn.nMaxFile = Len(ofn.lpstrFile) - 1
ofn.lpstrFileTitle = ofn.lpstrFile
ofn.nMaxFileTitle = ofn.nMaxFile
ofn.lpstrTitle = strTitle

    If ValidateDir(strInitDir) Then
        ofn.lpstrInitialDir = strInitDir
    Else
        ofn.lpstrInitialDir = curDir
    End If
    
    If strDefaultExt <> "" Then
        ofn.lpstrDefExt = strDefaultExt
    End If

'call the API function
lngApiReturn = GetSaveFileName(ofn)

    If lngApiReturn = 0 Then
        SaveAsDialog = ""
        Exit Function
    Else
       SaveAsDialog = ofn.lpstrFile
       Exit Function
    End If
    
ErrHandler:

SaveAsDialog = ""
    
End Function
'---------------------------------------------
' Function: PrintSetupDialog
' Action: Invoke the Windows Common Print Setup Dialog
' Return:1 on success, 0 on cancel
' ------------------------------------------------------------------------------------------------------------
Public Function PrintSetupDialog(WindowHandle As Long, Optional PSFlags As Long) As Long
Dim Pdlg As PrintDlg

PSFlags = PSFlags + PD_PRINTSETUP
'Initialize the PrintDlg structure
Pdlg.flags = PSFlags
Pdlg.HwndOwner = WindowHandle
Pdlg.lStructSize = Len(Pdlg)

'call the API function
PrintSetupDialog = PrintDlg(Pdlg)

End Function
'---------------------------------------------
' Function: ColorDialog
' Action: Invoke the Windows Common Color Dialog
' Return: A color as a long on success,0 on cancel, -1 on failure
' ------------------------------------------------------------------------------------------------------------
Public Function ColorDialog(WindowHandle As Long, Optional CDFlags As Long, Optional InitialColor As Long) As Long
Dim CC As ChooseColor
Dim lngColDlgResult As Long
'array to hold custom colors
Dim bytCustomColorsArray(0 To 16 * 4 - 1) As Byte

Dim intCounter As Integer

For intCounter = LBound(bytCustomColorsArray) To UBound(bytCustomColorsArray)

    bytCustomColorsArray(intCounter) = 0
    
Next intCounter


On Error GoTo ErrHandler
CC.flags = CDFlags
CC.HwndOwner = WindowHandle
CC.lStructSize = Len(CC)
CC.hInstance = 0
CC.lpCustColors = StrConv(bytCustomColorsArray, vbUnicode) 'if you do not fill in this value,ChooseColor will IPF or do nothing
    
    If InitialColor Then
        'you must also set the CC_RGBINIT flag if you intend to
        'set the initial color
        CC.rgbResult = InitialColor
        
    End If

lngColDlgResult = ChooseColorAPI(CC)

    If lngColDlgResult Then
        ColorDialog = CC.rgbResult
        glngRGBValue = CC.rgbResult
    Else
        ColorDialog = lngColDlgResult
    End If
Exit Function

ErrHandler:

ColorDialog = -1

End Function
'---------------------------------------------
' Function: FontsDialog
' Action: Invoke the Windows Common Fonts Dialog
' Return: 1 on success,0 on cancel, -1 on failure
' ------------------------------------------------------------------------------------------------------------
Public Function FontsDialog(WindowHandle As Long, Optional strInitFontName As String, Optional intInitFontSize As Integer) As Long
Dim CF As CHOOSEFONT
Dim LF As LOGFONT
Dim lngFntDlgResult As Long
Dim lngLogFontSize As Long
Dim lngLogFontAddress As Long
Dim lngMemHandle As Long
Dim TempArray() As Byte
Dim strFont As String
Dim intPointSize As Integer, intFontHeight As Integer

On Error GoTo ErrHandler
    
    'check to see if user has chosen to initialize the
    'fontname in the dialog
    If strInitFontName = "" Then
        strFont = "MS Sans Serif"
    Else
        strFont = strInitFontName
    End If
        
    'check to see if user has chosen to initialize
    'the font size in the dialog
    If intInitFontSize Then
        intPointSize = intInitFontSize
    Else
        intPointSize = 12
    End If
        
    
ReDim TempArray(Len(strFont)) As Byte

'initalize the dialog
CF.flags = CF_BOTH + CF_INITTOLOGFONTSTRUCT
CF.HwndOwner = WindowHandle
CF.lStructSize = Len(CF)
intFontHeight = -(96 * intPointSize / 72)

LF.lfWeight = 400 'Normal/Regular
LF.lfHeight = intFontHeight

Dim cab As Long        ' Copy to existing array, padding or truncating if necessary
Dim intArrayCounter As Integer
cab = UBound(TempArray) - LBound(TempArray) + 1
    If Len(strFont) < cab Then
   
        strFont = strFont & String$(cab - Len(strFont), 0)
   
    End If

TempArray() = StrToBytesV(strFont)

'Note: all of the overhead associated with initializing lf.lfFacename to a specific
'font, affects performance. Leave this blank if this causes concern.

    For intArrayCounter = LBound(TempArray) To UBound(TempArray)

        LF.lfFaceName(intArrayCounter) = TempArray(intArrayCounter)
    
    Next intArrayCounter

lngLogFontSize = Len(LF)

lngMemHandle = GlobalAlloc(GHND, lngLogFontSize)

    If lngMemHandle = 0 Then
        Exit Function
    End If
        
        
lngLogFontAddress = GlobalLock(lngMemHandle)
    
    If lngLogFontAddress = 0 Then
        Exit Function
    End If



CopyMemory ByVal lngLogFontAddress, LF, lngLogFontSize

CF.lpLogFont = lngLogFontAddress
'CF.flags = CF_BOTH + CF_INITTOLOGFONTSTRUCT


lngFntDlgResult = CHOOSEFONT(CF)

Select Case lngFntDlgResult

   Case 0 'user canceled
        FontsDialog = 0
       Exit Function
       
   Case 1 'font selected
   
        CopyMemory LF, ByVal lngLogFontAddress, lngLogFontSize
        
        gstrFontName = StrConv(LF.lfFaceName, vbUnicode)
        gblnFontItalic = CBool(LF.lfItalic)
        gblnFontUnderline = CBool(LF.lfUnderline)
        
        'determine the font weight
        Select Case LF.lfWeight
        
        Case 0
            gstrFontWeight = "DontCare"
        
        Case 100
            gstrFontWeight = "Thin"
        
        Case 200
            gstrFontWeight = "ExtraLight"
            
        Case 300
            gstrFontWeight = "Light"
            
        Case 400
            gstrFontWeight = "Normal"
        
        Case 500
            gstrFontWeight = "Medium"
        
        Case 600
            gstrFontWeight = "DemiBold"
        
        Case 700
            gstrFontWeight = "Bold"
        
        Case 800
            gstrFontWeight = "ExtraBold"
        
        Case 900
            gstrFontWeight = "Black"
        
        Case Else
            gstrFontWeight = ""
            
        End Select
        
        
   
        
        gintFontSize = CLng(CF.iPointSize / 10)
        FontsDialog = 1 'success
        Exit Function
   Case Else
        'error
        FontsDialog = -1
       Exit Function

    End Select
Exit Function
ErrHandler:
FontsDialog = -1
End Function
'---------------------------------------------
' Property: ValidateDir
' Action: This function determines whether a directory is valid or not
' ------------------------------------------------------------------------------------------------------------
Private Function ValidateDir(Directory As String) As Boolean
'without this, we would crash if the GetAttr fails(if the
'user selected an invalid directory)
On Error Resume Next

    'make sure the user h-as selected a valid directory
    If GetAttr(Directory) <> vbDirectory Then
    
        ValidateDir = False
                
    Else
        
        ValidateDir = True
        
    End If

End Function

'---------------------------------------------
' Property: strFontName
' Action: This is a read-only property which returns the
' name of the font that was chosen in the Fonts dialog
' ------------------------------------------------------------------------------------------------------------
Public Property Get strFontName() As String
Dim strTemp, strFont As String
Dim lngCount As Long

For lngCount = 1 To Len(gstrFontName)
    
    strTemp = Mid(gstrFontName, lngCount, 1)
                
        If Asc(strTemp) = 0 Then
        
          
                
                strFont = Mid(gstrFontName, 1, lngCount - 1)
                
                lngCount = Len(gstrFontName) + 1
           
            
        End If
        
Next

strFontName = strFont

End Property
'---------------------------------------------
' Property: strFontWeight
' Action: This is a read-only property which returns the
' weight of the font that was chosen in the Fonts dialog
' ------------------------------------------------------------------------------------------------------------
Public Property Get strFontWeight() As String
Dim strTemp, strFontName As String
Dim lngCount As Long

For lngCount = 1 To Len(gstrFontName)
    
    strTemp = Mid(gstrFontName, lngCount, 1)
                
        If Asc(strTemp) = 0 Then
        
          
                
                strFontName = Mid(gstrFontName, 1, lngCount - 1)
                
                lngCount = Len(gstrFontName) + 1
           
            
        End If
        
Next

strFontWeight = gstrFontWeight

End Property
'---------------------------------------------
' Property: boolFontItalic
' Action: This is a read-only property which returns
' whether the weight of the font that was chosen in the Fonts
' dialog is Italic or not.
' ------------------------------------------------------------------------------------------------------------
Public Property Get boolFontItalic() As Boolean

    If gblnFontItalic = True Then
    
        boolFontItalic = True
        
    Else
    
        boolFontItalic = False
        
    End If

End Property
'---------------------------------------------
' Property: boolFontUnderline
' Action: This is a read-only property which returns
' whether the weight of the font that was chosen in the Fonts
' dialog is Underlined or not.
' ------------------------------------------------------------------------------------------------------------
Public Property Get boolFontUnderline() As Boolean

    If gblnFontUnderline = True Then
    
        boolFontUnderline = True
        
    Else
    
        boolFontUnderline = False
        
    End If

End Property
'---------------------------------------------
' Property: boolFontBold
' Action: This is a read-only property which returns
' whether the weight of the font that was chosen in the Fonts
' dialog is Bold or not.
' ------------------------------------------------------------------------------------------------------------
Public Property Get boolFontBold() As Boolean

    If gstrFontWeight = "Bold" Then
    
        boolFontBold = True
        
    Else
    
        boolFontBold = False
        
    End If

End Property
'---------------------------------------------
' Property: intFontSize
' Action: This is a read-only property which returns
' the point size of the font that was chosen in the Fonts
' dialog.
' ------------------------------------------------------------------------------------------------------------
Public Property Get intFontSize() As Integer

intFontSize = gintFontSize

End Property
'---------------------------------------------
' Property: intRed
' Action: This is a read-only property which returns
' the Red component of the color that was chosen in the Color
' dialog.
' ------------------------------------------------------------------------------------------------------------
Public Property Get intRed() As Integer

    intRed = glngRGBValue \ 256 ^ 0 And 255
    
End Property
'---------------------------------------------
' Property: intGreen
' Action: This is a read-only property which returns
' the Green component of the color that was chosen in the Color
' dialog.
' ------------------------------------------------------------------------------------------------------------
Public Property Get intGreen() As Integer

    intGreen = glngRGBValue \ 256 ^ 1 And 255
    
End Property
'---------------------------------------------
' Property: intBlue
' Action: This is a read-only property which returns
' the Blue component of the color that was chosen in the Color
' dialog.
' ------------------------------------------------------------------------------------------------------------
Public Property Get intBlue() As Integer

   intBlue = glngRGBValue \ 256 ^ 2 And 255
   
End Property
'---------------------------------------------
' Function: StrToBytesV
' Action: Convert a string to a byte array
' Return: a byte array as a variant
' ------------------------------------------------------------------------------------------------------------
Private Function StrToBytesV(str As String) As Variant

    StrToBytesV = StrConv(str, vbFromUnicode)

End Function
'---------------------------------------------
' Property: PrinterName
' Action: This is a read-only property which returns
' the the name of the printer that was chosen in the Print
' dialog.
' ------------------------------------------------------------------------------------------------------------
Public Property Get PrinterName() As String
PrinterName = m_PrinterName
End Property