VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CommonDialogs"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Const MAX_PATH = 260

Private Declare Function GetActiveWindow Lib "user32" () As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
 (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd _
 As Long, lpRect As RECT) As Long
 
Private Declare Function GetClassName Lib "user32" Alias _
 "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, _
 ByVal nMaxCount As Long) As Long
 
Private Const CC_RGBINIT = &H1
Private Const CC_FULLOPEN = &H2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_SHOWHELP = &H8
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_ANYCOLOR = &H100

Private Type CHOOSECOLORTYPE
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        rgbResult As Long
        lpCustColors As Long
        flags As Long
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias _
 "ChooseColorA" (pChoosecolor As CHOOSECOLORTYPE) As Long

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_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
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_EXPLORER = &H80000

Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0

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
        lpstrDirectory 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 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 GetFileTitle Lib "comdlg32.dll" Alias _
 "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle _
 As String, ByVal cbBuf As Integer) As Integer
 
' Logical Font
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName(1 To LF_FACESIZE) As Byte
End Type

Private Type CHOOSEFONTTYPE
        lStructSize As Long
        hwndOwner As Long          '  caller's window handle
        hdc As Long                '  printer DC/IC or NULL
        lpLogFont As LOGFONT          '  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 Declare Function ChooseFont Lib "comdlg32.dll" Alias _
 "ChooseFontA" (pChoosefont As CHOOSEFONTTYPE) As Long

Private Type SHFILEINFO
        hIcon As Long                      '  out: icon
        iIcon As Long          '  out: icon index
        dwAttributes As Long               '  out: SFGAO_ flags
        szDisplayName As String * MAX_PATH '  out: display name (or path)
        szTypeName As String * 80         '  out: type name
End Type

Const SHGFI_ICON = &H100                         '  get icon
Const SHGFI_DISPLAYNAME = &H200                  '  get display name
Const SHGFI_TYPENAME = &H400                     '  get type name
Const SHGFI_ATTRIBUTES = &H800                   '  get attributes
Const SHGFI_ICONLOCATION = &H1000                '  get icon location
Const SHGFI_EXETYPE = &H2000                     '  return exe type
Const SHGFI_SYSICONINDEX = &H4000                '  get system icon index
Const SHGFI_LINKOVERLAY = &H8000                 '  put a link overlay on icon
Const SHGFI_SELECTED = &H10000                   '  show icon in selected state
Const SHGFI_LARGEICON = &H0                      '  get large icon
Const SHGFI_SMALLICON = &H1                      '  get small icon
Const SHGFI_OPENICON = &H2                       '  get open icon
Const SHGFI_SHELLICONSIZE = &H4                  '  get shell size icon
Const SHGFI_PIDL = &H8                           '  pszPath is a pidl
Const SHGFI_USEFILEATTRIBUTES = &H10             '  use passed dwFileAttribute

Private Declare Function SHGetFileInfo Lib "shell32.dll" _
 Alias " SHGetFileInfoA" (ByVal pszPath As String, _
 ByVal dwFileAttributes As Long, psfi As SHFILEINFO, _
 ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long

'Shadow variables
Private strWindowTitle As String
Private strFilterTitle() As String
Private strWildcardRack() As String
Private lOpenFlags As Long
Private strDirectory As String
Private strActiveFile As String
Private iChosenFileCount As Integer
Private strChosenFiles() As String

Private bytCustomColors() As Byte
Private lChosenColor As Long

Private strThisModule As String
Private iniStandard As New INIControl

Public Property Get WindowTitle() As String
    WindowTitle = strWindowTitle
End Property

Public Property Let WindowTitle(strSetting As String)
    strWindowTitle = strSetting
End Property

Public Property Get ActiveFile() As String
    ActiveFile = strActiveFile
End Property

Public Property Let ActiveFile(strSetting As String)
    'not important that this file exists
    strActiveFile = strSetting
End Property

Public Property Get FilterTitle(iWhichOne As Integer) As String
    If UBound(strFilterTitle) = 0 Or iWhichOne <= _
     UBound(strFilterTitle) Then
        FilterTitle = strFilterTitle(iWhichOne)
    End If
End Property

Public Property Let FilterTitle(iWhichOne As Integer, strEntry As String)
    Dim iOverMax As Integer, iCtr As Integer
    
    iOverMax = UBound(strFilterTitle) + 1
    Select Case True
        Case iWhichOne > iOverMax
            iWhichOne = iOverMax
        Case iWhichOne = iOverMax
            ReDim Preserve strFilterTitle(iOverMax)
        Case iWhichOne < iOverMax
            ReDim Preserve strFilterTitle(iOverMax)
            For iCtr = iOverMax To iWhichOne + 1 Step -1
                strFilterTitle(iCtr) = strFilterTitle(iCtr - 1)
            Next iCtr
    End Select
    
    strFilterTitle(iWhichOne) = strEntry
End Property

Public Property Get FilterExtenders(iWhichOne As Integer) As String
    If UBound(strWildcardRack) = 0 Or iWhichOne <= _
     UBound(strWildcardRack) Then
        FilterExtenders = strWildcardRack(iWhichOne)
    End If
End Property

Public Property Let FilterExtenders(iWhichOne As Integer, strEntry As String)
    Dim iOverMax As Integer, iCtr As Integer
    
    iOverMax = UBound(strWildcardRack) + 1
    Select Case True
        Case iWhichOne > iOverMax
            iWhichOne = iOverMax
        Case iWhichOne = iOverMax
            ReDim Preserve strWildcardRack(iOverMax)
        Case iWhichOne < iOverMax
            ReDim Preserve strWildcardRack(iOverMax)
            For iCtr = iOverMax To iWhichOne + 1 Step -1
                strWildcardRack(iCtr) = strWildcardRack(iCtr - 1)
            Next iCtr
    End Select
    
    strWildcardRack(iWhichOne) = strEntry
End Property

Public Property Get OpenMultipleChoice() As Boolean
    OpenMultipleChoice = CBool(lOpenFlags And OFN_ALLOWMULTISELECT)
End Property

Public Property Let OpenMultipleChoice(bSet As Boolean)
    If bSet Then
        lOpenFlags = lOpenFlags Or OFN_ALLOWMULTISELECT
    Else
        lOpenFlags = lOpenFlags And Not OFN_ALLOWMULTISELECT
    End If
End Property

Public Property Get ReadOnly() As Boolean
    ReadOnly = CBool(lOpenFlags And OFN_READONLY)
End Property

Public Property Let ReadOnly(bSet As Boolean)
    If bSet Then
        lOpenFlags = lOpenFlags Or OFN_READONLY
    Else
        lOpenFlags = lOpenFlags And Not OFN_READONLY
    End If
End Property

Public Property Get ReadOnlyBox() As Boolean
    'This property works in reverse
    ReadOnlyBox = CBool(Not (lOpenFlags And OFN_HIDEREADONLY))
End Property

Public Property Let ReadOnlyBox(bSet As Boolean)
    If bSet Then
        lOpenFlags = lOpenFlags And Not OFN_HIDEREADONLY
    Else
        lOpenFlags = lOpenFlags Or OFN_HIDEREADONLY
    End If
End Property

Public Property Get ShowHelpButton() As Boolean
    ShowHelpButton = CBool(lOpenFlags And OFN_SHOWHELP)
End Property

Public Property Let ShowHelpButton(bSet As Boolean)
    If bSet Then
        lOpenFlags = lOpenFlags Or OFN_SHOWHELP
    Else
        lOpenFlags = lOpenFlags And Not OFN_SHOWHELP
    End If
End Property

Public Property Get ExplorerStyle() As Boolean
    ExplorerStyle = CBool(lOpenFlags And OFN_EXPLORER)
End Property

Public Property Let ExplorerStyle(bSet As Boolean)
    If bSet Then
        lOpenFlags = lOpenFlags Or OFN_EXPLORER
    Else
        lOpenFlags = lOpenFlags And Not OFN_EXPLORER
    End If
End Property

Public Property Get FileMustExist() As Boolean
    FileMustExist = CBool(lOpenFlags And OFN_FILEMUSTEXIST)
End Property

Public Property Let FileMustExist(bSet As Boolean)
    If bSet Then
        lOpenFlags = lOpenFlags Or OFN_FILEMUSTEXIST
    Else
        lOpenFlags = lOpenFlags And Not OFN_FILEMUSTEXIST
    End If
End Property

Public Property Get ActiveDirectory() As String
    ActiveDirectory = strDirectory
End Property

Public Property Let ActiveDirectory(strSetting As String)
    If FileSystem.Dir(strSetting) <> "" Then
        strDirectory = strSetting
    End If
End Property

Public Property Get ChosenFileCount() As Integer
    ChosenFileCount = iChosenFileCount
End Property

Public Property Get ChosenFile(Optional iWhichOne As Integer) As String
    iWhichOne = Abs(iWhichOne)
    If iWhichOne = 0 Then
        iWhichOne = 1
    ElseIf iWhichOne > iChosenFileCount Then
        iWhichOne = iChosenFileCount
    End If
    
    ChosenFile = strChosenFiles(iWhichOne)
End Property

Public Property Get CustomColor(iWhichOne As Integer) As Long
    iWhichOne = Abs(iWhichOne)
    If iWhichOne < 0 Then
        iWhichOne = 0
    ElseIf iWhichOne > 15 Then
        iWhichOne = 15
    End If

    CustomColor = bytCustomColors(iWhichOne * 4) * &H1000000 _
                 + bytCustomColors(iWhichOne * 4 + 1) * &H10000 _
                 + bytCustomColors(iWhichOne * 4 + 2) * &H100 _
                 + bytCustomColors(iWhichOne * 4 + 3)
End Property

Public Property Let CustomColor(iWhichOne As Integer, lValue As Long)
    iWhichOne = Abs(iWhichOne)
    If iWhichOne < 0 Then
        iWhichOne = 0
    ElseIf iWhichOne > 15 Then
        iWhichOne = 15
    End If

    bytCustomColors(iWhichOne * 4) = (lValue And &HFF000000) \ &H1000000
    bytCustomColors(iWhichOne * 4 + 1) = (lValue And &HFF0000) \ &H10000
    bytCustomColors(iWhichOne * 4 + 2) = (lValue And &HFF00) \ &H100
    bytCustomColors(iWhichOne * 4 + 3) = (lValue And &HFF)
End Property

Public Property Get ChosenColor() As Long
    ChosenColor = lChosenColor
End Property

Public Property Get ChosenFileTitle(Optional iWhichOne As Integer) As String
    Dim strTitleBuffer As String * 256
    Dim iSuccess As Integer

    iWhichOne = Abs(iWhichOne)
    If iWhichOne = 0 Then
        iWhichOne = 1
    End If
    If iWhichOne > iChosenFileCount Then
        iWhichOne = iChosenFileCount
    End If
    If strChosenFiles(iWhichOne) = "" Then
        ChosenFileTitle = ""
        Exit Property
    End If
    
    strTitleBuffer = String$(256, 0)
    iSuccess = GetFileTitle(strChosenFiles(iWhichOne), strTitleBuffer, 256)
    If iSuccess = 0 Then
        ChosenFileTitle = strTitleBuffer
    End If

End Property

Public Function OpenDialog() As String
    On Error Resume Next

    Dim openParams As OPENFILENAME
    Dim lReturn As Long
    Dim iMaxTypes As Integer, iCtr As Integer
    Dim iPtrLeft As Integer, iPtrRight As Integer
    Dim strFilter As String, strExtractor As String
           
    If UBound(strWildcardRack) <> UBound(strFilterTitle) Then
        Err.Raise vbObjectError + 514, strThisModule, "Filter property arrays are uneven."
        Exit Function
    End If
    
    With openParams
'        .hwndOwner = GetActiveWindow
        .lStructSize = Len(openParams)
        iMaxTypes = UBound(strWildcardRack)
        For iCtr = 1 To iMaxTypes
            strFilter = strFilter & strFilterTitle(iCtr) & Chr$(0) & _
            strWildcardRack(iCtr) & Chr$(0)
        Next iCtr
        strFilter = strFilter & "All Files" & Chr(0) & "*.*" & Chr(0)
     
        .lpstrFilter = strFilter
        .nFilterIndex = iMaxTypes
        .lpstrFile = strActiveFile & String(257 - _
          Len(strActiveFile), 0)
        .nMaxFile = Len(.lpstrFile) - 1
        .lpstrFileTitle = .lpstrFile
        .nMaxFileTitle = .nMaxFile
        .lpstrDirectory = strDirectory
        .lpstrTitle = strWindowTitle
        .flags = lOpenFlags
      
        lReturn = GetOpenFileName(openParams)
        lOpenFlags = .flags
        OpenDialog = Left$(.lpstrFile, InStrRev(.lpstrFile, _
         Chr$(0)) - 1)
        If lOpenFlags And OFN_ALLOWMULTISELECT Then
            iPtrLeft = InStr(.lpstrFile, " ")
            strDirectory = Left$(.lpstrFile, iPtrLeft - 1) & "\"
            ReDim strChosenFiles(0)
            iCtr = 0
            Do
                iPtrRight = InStr(iPtrLeft + 1, .lpstrFile, " ")
                If iPtrRight = 0 Then Exit Do
                iCtr = iCtr + 1
                strExtractor = Mid$(.lpstrFile, iPtrLeft + 1, iPtrRight - iPtrLeft - 1)
                ReDim Preserve strChosenFiles(iCtr)
                strChosenFiles(iCtr) = strExtractor
                iPtrLeft = iPtrRight
            Loop
            iChosenFileCount = iCtr
        Else
            ReDim strChosenFiles(1)
            strExtractor = Left$(.lpstrFile, InStr(.lpstrFile, Chr$(0)) - 1)
            strDirectory = Left$(strExtractor, InStrRev(strExtractor, "\"))
            strChosenFiles(1) = Right$(strExtractor, Len(strExtractor) - InStrRev(strExtractor, "\"))
            iChosenFileCount = 1
        End If
        strActiveFile = strChosenFiles(1)
    End With
End Function

Public Function ChooseAColor() As Long
    Dim colorParams As CHOOSECOLORTYPE
    Dim lChoice As Long
    
    With colorParams
        .lStructSize = Len(CHOOSECOLORTYPE)
        .lpCustColors = StrConv(bytCustomColors, vbUnicode)
        .flags = 0
        lChoice = ChooseColor(colorParams)
        If lChoice <> 0 Then
            lChosenColor = .rgbResult
            bytCustomColors = StrConv(.lpCustColors, vbFromUnicode)
        End If
    End With
    
    ChooseAColor = lChosenColor
End Function

Private Sub Class_Initialize()
    ReDim strFilterTitle(1)
    ReDim strWildcardRack(1)
    ReDim bytCustomColors(63)
    Dim i As Integer

    For i = 0 To 63 Step 4
        bytCustomColors(i) = 255 - (i * 4)
        bytCustomColors(i + 1) = 255 - (i * 4)
        bytCustomColors(i + 2) = 255 - (i * 4)
        bytCustomColors(i + 3) = 0
    Next i
    strThisModule = VBE.ActiveVBProject.Name & ".CommonDialogs"
    strWindowTitle = "Open file..."
    strDirectory = "C:\"
    lOpenFlags = 0& Or OFN_SHOWHELP Or OFN_EXPLORER
End Sub

Public Function GetFileIcon(strThisFile As String) As String
    Dim shData As SHFILEINFO
    Dim strBuffer As String
    
    If strThisFile <> "" Then
        If FileSystem.Dir(strThisFile) <> "" Then
            strBuffer = String$(MAX_PATH, 0)
            shData.szDisplayName = strThisFile
            SHGetFileInfo strBuffer, 0&, shData, MAX_PATH, SHGFI_LARGEICON
            GetFileIcon = Left$(strBuffer, InStr(strBuffer, Chr$(0)) - 1)
        End If
    End If
End Function