Attribute VB_Name = "modDialog"
' -------------------------------------------------------------------------------
'
'   AVStoDVD - by MrC
'   File: modDialog.bas
'   Purpose: Common Dialog APIs
'
' -------------------------------------------------------------------------------


Option Explicit
Option Compare Binary
Option Base 0

' Constants for BrowseForFolder
Const MAX_PATH = 260
Const WM_USER = &H400
Const BFFM_INITIALIZED = 1
Const BFFM_SELCHANGED = 2
Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Const BFFM_SETSELECTION = (WM_USER + 102)

' Constants for SetFont
Const FW_NORMAL = 400
Const FW_BOLD = 700
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_TTONLY = &H40000
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const CF_NOSCRIPTSEL = &H800000
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32

' Constants for ShowColor
Const CC_FULLOPEN = &H2
Const CC_RGBINIT = &H1

' Constants for EnumFontFamProc
Const RASTER_FONTTYPE = &H1
Const DEVICE_FONTTYPE = &H2        'i.e. ADOBE OPENTYPE
Const TRUETYPE_FONTTYPE = &H4


' File Open/Save structure
Private Type cdlOpenFileName
    lStructSize As Long
    owner As Long
    hInstance As Long
    Filter As String
    CustomFilter As String
    MaxCustFilter As Long
    FilterIndex As Long
    File As String
    MaxFile As Long
    FileTitle As String
    MaxFileTitle As Long
    InitialDir As String
    Title As String
    Flags As Long
    FileOffset As Integer
    FileExtension As Integer
    DefExt As String
    CustData As Long
    Hook As Long
    TemplateName As String
End Type

' Folder structure
Private Type BrowseInfo
    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

' Constants
Public Enum cdlFileOpenConstants
    cdlOFNAllowMultiselect = 512
    cdlOFNCreatePrompt = 8192
    cdlOFNExplorer = 524288
    cdlOFNExtensionDifferent = 1024
    cdlOFNFileMustExist = 4096
    cdlOFNHelpButton = 16
    cdlOFNHideReadOnly = 4
    cdlOFNLongNames = 2097152
    cdlOFNNoChangeDir = 8
    cdlOFNNoDereferenceLinks = 1048576
    cdlOFNNoLongNames = 262144
    cdlOFNNoReadOnlyReturn = 32768
    cdlOFNNoValidate = 256
    cdlOFNOverwritePrompt = 2
    cdlOFNPathMustExist = 2048
    cdlOFNReadOnly = 1
    cdlOFNShareAware = 16384
End Enum

' Folder browsing constants
Public Enum BrowseFolderConstants
    BIF_RETURNONLYFSDIRS = &H1
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    BIF_EDITBOX = &H10
    BIF_VALIDATE = &H20
    BIF_NEWDIALOGSTYLE = &H40
    BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
    BIF_BROWSEINCLUDEURLS = &H80
    BIF_UAHINT = &H100
    BIF_NONEWFOLDERBUTTON = &H200
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_BROWSEINCLUDEFILES = &H4000
    BIF_SHAREABLE = &H8000&
End Enum

' User Font Structure
Public Type MyFont
    Name As String
    Height As Long
    Bold As Boolean
    Italic As Boolean
    Underline As Boolean
    Outline As Boolean
    Shadow As Boolean
    Color As Long
End Type

' ChooseFont Structure
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

' LogFont Structure
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

' NewTextMetric Structure
Type NewTextMetric
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
    ntmFlags As Long
    ntmSizeEM As Long
    ntmCellHeight As Long
    ntmAveWidth As Long
End Type

' ChooseColor Structure
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

' Folder browsing variables
Private m_CurrentDirectory As String

' API calls
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As cdlOpenFileName) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pSavefilename As cdlOpenFileName) As Long
Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As ChooseFont) As Long
Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
Declare Function SHBrowseForFolder Lib "Shell32.dll" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "Shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Declare Function GlobalLock Lib "KERNEL32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "KERNEL32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "KERNEL32" (ByVal hMem As Long) As Long
Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hdc As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, lParam As Any) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long


' Open (or select) a file
Public Function OpenFile(ByVal hwnd As Long, ByRef DialogTitle As String, ByRef Filter As String, ByRef InitDir As String, ByRef InitFilename As String, ByVal Flags As cdlFileOpenConstants) As String
     
    Dim FileStruct As cdlOpenFileName
    
    With FileStruct
    
        ' Set all dialog parameters
        .lStructSize = Len(FileStruct)
        .hInstance = App.hInstance
        .owner = hwnd
        .Title = DialogTitle
        .Filter = Replace(Filter, "|", vbNullChar)
        .Flags = Flags
        .File = String(4096, Chr(0)) & vbNullChar
        .MaxFile = Len(.File)
        .InitialDir = InitDir
        If InitFilename <> "" And Dir(InitFilename) <> "" Then
            .InitialDir = Left(InitFilename, Len(InitFilename) - Len(Dir(InitFilename)))
            .File = InitFilename
        End If
        
        ' Show the dialog and return the result
        If GetOpenFileName(FileStruct) Then
            OpenFile = modStr.StripNullEnd(.File)
        End If
    
    End With
     
End Function


' Save a file
Public Function SaveFile(ByVal hwnd As Long, ByRef DialogTitle As String, ByRef Filter As String, ByRef InitDir As String, ByRef InitFilename As String, ByVal Flags As cdlFileOpenConstants, Optional ByRef FilterIndex As Long) As String
     
    Dim FileStruct As cdlOpenFileName
    
    With FileStruct
    
        ' Set all dialog parameters
        .lStructSize = Len(FileStruct)
        .hInstance = App.hInstance
        .owner = hwnd
        .Title = DialogTitle
        .Filter = Replace(Filter, "|", vbNullChar)
        .Flags = Flags
        .File = InitFilename & String(4096 - Len(InitFilename), Chr(0)) & vbNullChar
        .MaxFile = Len(.File)
        .InitialDir = InitDir
        
        ' Show the dialog and return the result
        If GetSaveFileName(FileStruct) Then
            SaveFile = modStr.StripNullEnd(.File)
        End If
         
    End With
     
End Function


'Opens a Treeview control that displays the directories in a computer
Public Function BrowseForFolder(owner As Form, Title As String, Optional StartDir As String) As String

    Dim lpIDList As Long
    Dim szTitle As String
    Dim sBuffer As String
    Dim tBrowseInfo As BrowseInfo
    
    m_CurrentDirectory = StartDir & vbNullChar
    
    szTitle = Title
    With tBrowseInfo
        .hwndOwner = owner.hwnd
        .lpszTitle = lstrcat(szTitle, "")
        .ulFlags = BIF_USENEWUI Or BIF_RETURNONLYFSDIRS
        '.ulFlags = 0
        .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
    End With
    
    lpIDList = SHBrowseForFolder(tBrowseInfo)
    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        BrowseForFolder = sBuffer
    Else
        BrowseForFolder = ""
    End If

End Function


' This function allows you to assign a function pointer to a variable.
Private Function GetAddressofFunction(add As Long) As Long

    GetAddressofFunction = add

End Function


' BrowseForFolder callback procedure
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long

    Dim ret As Long
    Dim sBuffer As String
    
    On Error Resume Next  'Sugested by MS to prevent an error from propagating back into the calling process.
    
    Select Case uMsg
    Case BFFM_INITIALIZED
        Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
    Case BFFM_SELCHANGED
        sBuffer = Space(MAX_PATH)
        ret = SHGetPathFromIDList(lp, sBuffer)
        If ret = 1 Then
            Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
        End If
    End Select
    
    BrowseCallbackProc = 0

End Function


' Show Font Dialog and Set Font
Public Function SetFont(ByVal hwnd As Long, CurrentFont As MyFont, Optional DisplayEffects As Boolean = True, Optional DisplayScript As Boolean = True) As MyFont

    Dim cf As ChooseFont
    Dim lfont As LogFont
    Dim hMem As Long
    Dim pMem As Long
    Dim retval As Long

    On Error Resume Next
    
    With lfont
        .lfFaceName = CurrentFont.Name & vbNullChar   ' string must be Null - terminated
        .lfHeight = CLng(1.333 * CurrentFont.Height) ' determine default height
        If CurrentFont.Bold = True Then
            .lfWeight = FW_BOLD
        Else
            .lfWeight = FW_NORMAL
        End If
        .lfItalic = CByte(CurrentFont.Italic)
        .lfUnderline = CByte(CurrentFont.Underline)
        .lfStrikeOut = 0
        .lfWidth = 0  ' determine default width
        .lfEscapement = 0  ' angle between baseline and escapement vector
        .lfOrientation = 0  ' angle between baseline and orientation vector
        .lfCharSet = DEFAULT_CHARSET  ' use default character set
        .lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
        .lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
        .lfQuality = DEFAULT_QUALITY  ' default quality setting
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
    End With
    
    ' 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 = hwnd  ' form with hwnd 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 = CurrentFont.Height * 10
    cf.Flags = CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE Or CF_BOTH Or CF_TTONLY
    If DisplayEffects = True Then cf.Flags = cf.Flags Or CF_EFFECTS
    If DisplayScript = False Then cf.Flags = cf.Flags Or CF_NOSCRIPTSEL
    cf.RGBColors = CurrentFont.Color
    cf.nFontType = REGULAR_FONTTYPE  ' regular font type i.e. not bold or anything
    cf.nSizeMin = 0  ' 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.
    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.
        With lfont
            SetFont.Name = Left(.lfFaceName, InStr(.lfFaceName, vbNullChar) - 1)
            SetFont.Height = CLng(cf.iPointSize / 10)
            If .lfWeight = FW_BOLD Then
                SetFont.Bold = True
            End If
            SetFont.Italic = CBool(.lfItalic)
            SetFont.Underline = CBool(.lfUnderline)
            SetFont.Color = cf.RGBColors
        End With
    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


' EnumFontFamProc, called by EnumFontfamilies with AddressOf
Function EnumFontFamProc(lpNLF As LogFont, lpNTM As NewTextMetric, ByVal FontType As Long, lParam As ListBox) As Long

    Dim FaceName As String
    
    FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
    If FontType = TRUETYPE_FONTTYPE Or FontType = DEVICE_FONTTYPE Then
        lParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
    End If
    EnumFontFamProc = 1

End Function


' MakeFontsList creates list of fonts in a ComboBox
'  Remember to set ComboBox <sort> property to <true>
Public Sub MakeFontsList(cb As ComboBox)

    Dim hdc As Long 'Device context of ComboBox

    cb.Clear
    hdc = GetDC(cb.hwnd)   'Obtains Device Context
    EnumFontFamilies hdc, vbNullString, AddressOf EnumFontFamProc, cb
    ReleaseDC cb.hwnd, hdc 'Finished with the Device Context

End Sub


'Show the 'Select Color'-dialog
Public Function ShowColor(InputColor As Long, OwnerForm As Form) As Long
    
    Dim cc As ChooseColor
    'Dim Custcolor(16) As Long
    'Dim lReturn As Long
    Dim CustomColors(0 To 16 * 4 - 1) As Byte
    
    'set the structure size
    cc.lStructSize = Len(cc)
    'Set the owner
    cc.hwndOwner = OwnerForm.hwnd
    'set the application's instance
    cc.hInstance = App.hInstance
    'set the custom colors (converted to Unicode)
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    'Extra flags
    cc.Flags = CC_FULLOPEN Or CC_RGBINIT
    'Set start color
    cc.rgbResult = InputColor
    
    If ChooseColor(cc) <> 0 Then
        ShowColor = cc.rgbResult
    Else
        ShowColor = -1
    End If
    
End Function


