'***************************************************************************************
'*                     Написано: 01.08.2003 (Team HomeWork)                            *
'*                           e-mail: sne_pro@mail.ru                                   *
'***************************************************************************************

Option Explicit
Private Declare Function GetOpenFileNameA Lib "comdlg32" (FileName As FileName) As Long
Private Declare Function GetSaveFileNameA Lib "comdlg32" (FileName As FileName) As Long
Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type FileName
    lngStructSize     As Long
    lngHandle         As Long
    lngInstance       As Long
    strFilter         As String
    strCustomFilter   As String
    lngMaxCustFilter  As Long
    lngFilterIndex    As Long
    strFile           As String
    lngMaxFile        As Long
    strFileTitle      As String
    lngMaxFileTitle   As Long
    strInitialDir     As String
    strTitle          As String
    lngFlags          As Long
    intFileOffset     As Integer
    intFileExtension  As Integer
    strDefExt         As String
    lngCustData       As Long
    lngHook           As Long
    strTemplateName   As String
End Type
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage 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

Public Enum CdlgExt_Flags
    OFN_CREATEPROMPT = &H2000
    OFN_ENABLESIZING = &H800000
    OFN_EXPLORER = &H80000
    OFN_FILEMUSTEXIST = &H1000
    OFN_HIDEREADONLY = &H4
    OFN_OVERWRITEPROMPT = &H2
    OFN_PATHMUSTEXIST = &H800
End Enum
Public Enum WhatBrowse
    BIF_RETURNONLYFSDIRS = &H1
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    BIF_EDITBOX = &H10
    BIF_NEWDIALOGSTYLE = &H40
    BIF_BROWSEINCLUDEFILES = &H1 Or &H4000
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
End Enum
Private Const MAX_PATH  As Long = 260

Private Inst            As Long, _
        sArray()        As String, _
        sBuffer         As String

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  GetOpenFileName
' Описание   :  Отурытие файла
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  lngHandle   - Хэндл родителя
'               lDlgStyle   - Стиль окна открытия
'               strFilter   - Фильтр
'               FltrIndex   - Номер используемого фильтра
'               sInitPath   - Начальный путь
'               sInitFile   - Начальное имя файла
'               sDlgTitle   - Заголовок окошка
'--------------------------------------------------------------------------------
Public Function GetOpenFileName(Optional ByVal lngHandle As Long = &H0, _
                                Optional ByVal lDlgStyle As CdlgExt_Flags = OFN_HIDEREADONLY, _
                                Optional ByVal strFilter As String = vbNullString, _
                                Optional ByVal FltrIndex As Long = &H1, _
                                Optional ByVal sInitPath As String = vbNullString, _
                                Optional ByVal sInitFile As String = vbNullString, _
                                Optional ByVal sDlgTitle As String = vbNullString) As String
    Dim FN As FileName
    Call InitialisateOFN(FN, lngHandle, lDlgStyle, strFilter, FltrIndex, sInitPath, sInitFile, sDlgTitle)
    
    Call GetOpenFileNameA(FN)
    Inst = InStr(1&, FN.strFile, vbNullChar) - &H1
    If Inst Then GetOpenFileName = Left$(FN.strFile, Inst)
End Function

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  GetSaveFileName
' Описание   :  Сохранение файла
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  lngHandle   - Хэндл родителя
'               lDlgStyle   - Стиль окна открытия
'               strFilter   - Фильтр
'               FltrIndex   - Номер используемого фильтра
'               sInitPath   - Начальный путь
'               sInitFile   - Начальное имя файла
'               sDlgTitle   - Заголовок окошка
'--------------------------------------------------------------------------------
Public Function GetSaveFileName(Optional ByVal lngHandle As Long = &H0, _
                                Optional ByVal lDlgStyle As CdlgExt_Flags = OFN_HIDEREADONLY, _
                                Optional ByVal strFilter As String = vbNullString, _
                                Optional ByVal FltrIndex As Long = &H1, _
                                Optional ByVal sInitPath As String = vbNullString, _
                                Optional ByVal sInitFile As String = vbNullString, _
                                Optional ByVal sDlgTitle As String = vbNullString) As String
    Dim FN As FileName
    Call InitialisateOFN(FN, lngHandle, lDlgStyle, strFilter, FltrIndex, sInitPath, sInitFile, sDlgTitle)
    
    Call GetSaveFileNameA(FN)
    Inst = InStr(1&, FN.strFile, vbNullChar) - &H1
    If Inst Then GetSaveFileName = Left$(FN.strFile, Inst)
End Function

Private Sub InitialisateOFN(ByRef FN As FileName, _
                            ByVal lngHandle As Long, _
                            ByVal lDlgStyle As CdlgExt_Flags, _
                            ByVal strFilter As String, _
                            ByVal FltrIndex As Long, _
                            ByVal sInitPath As String, _
                            ByVal sInitFile As String, _
                            ByVal sDlgTitle As String)
    For Inst = 1 To Len(strFilter)
        If Mid$(strFilter, Inst, 1& = "|" Then Mid$(strFilter, Inst, 1& = vbNullChar
    Next
    strFilter = strFilter & vbNullChar & vbNullChar

    With FN
        .lngStructSize = Len(FN)
        .lngHandle = lngHandle
        .lngFlags = lDlgStyle Or OFN_EXPLORER
        .lngInstance = App.hInstance
        
        .lngMaxFile = MAX_PATH
        .lngMaxFileTitle = MAX_PATH
        
        .strFile = sInitFile & String$(MAX_PATH - Len(sInitFile), &H0)
        .strFileTitle = String$(MAX_PATH, &H0)
        
        .strFilter = strFilter
        .lngFilterIndex = FltrIndex
        .strInitialDir = sInitPath
        .strTitle = sDlgTitle
    End With
End Sub

' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  ShowColor
' Описание   :  Выбор цвета
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  hOwner      - Хэндл родителя
'               InOutColor  - Цвет
'--------------------------------------------------------------------------------
Public Function ShowColor(hOwner As Long, InOutColor As Long) As Long
    Dim shi As Integer
    Dim CC As CHOOSECOLOR
    Dim CustomColors(&H0 To &H10 * &H4 - &H1) As Byte

    For shi = 0 To UBound(CustomColors)
        CustomColors(shi) = &HFF
    Next

    With CC
        .lStructSize = Len(CC)
        .hwndOwner = hOwner
        .hInstance = App.hInstance
        .lpCustColors = StrConv(CustomColors, vbUnicode)
        .flags = &H1 Or &H2 Or &H4 Or &H8
        .RGBResult = InOutColor
        If ChooseColorAPI(CC) Then
            InOutColor = .RGBResult: ShowColor = .RGBResult
        Else
            ShowColor = InOutColor
        End If
    End With
End Function

' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  fBrowseForFolder
' Описание   :  Обзор каталогов
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  hOwner      - Хэндл родителя
'               sPrompt     - Надпись сверху
'               WhatBr      - Что будем смотреть
'               InitDir     - Начальный каталог
'               fileMasks   - Маска файлов
'--------------------------------------------------------------------------------
Public Function fBrowseForFolder(ByVal hOwner As Long, _
                        Optional ByVal sPrompt As String, _
                        Optional ByVal WhatBr As WhatBrowse, _
                        Optional ByVal InitDir As String = vbNullString, _
                        Optional ByVal fileMasks As String = vbNullString) As String
    Dim udtBI As BROWSEINFO
    With udtBI
        .hOwner = hOwner
        .lpszTitle = Trim$(sPrompt)
        .ulFlags = WhatBr
        Call CopyMemory(.lpfn, AddressOf BrowseCallbackProc, &H4)
    End With
    
    sBuffer = InitDir
    If Len(fileMasks) Then sArray = Split(fileMasks, "|" Else ReDim sArray(0)
    
    Inst = SHBrowseForFolder(udtBI)
    fBrowseForFolder = String$(&H200, &H0)
    If Inst And SHGetPathFromIDList(Inst, fBrowseForFolder) = vbNull Then
        fBrowseForFolder = Left$(fBrowseForFolder, InStr(&H1, fBrowseForFolder, vbNullChar) - &H1)
        Call AddSlash(fBrowseForFolder)
    Else
        fBrowseForFolder = vbNullString
    End If
End Function

Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    Dim ci As Long, sPath As String
    
    Select Case uMsg
        Case Is = &H1           'BFFM_INITIALIZED
            If Len(sBuffer) Then Call SendMessage(hWnd, &H466, &H1, ByVal sBuffer & vbNullChar)

        Case Is = &H2           'BFFM_SELCHANGED
            sPath = String$(&H200, &H0)
            If Not SHGetPathFromIDList(lParam, sPath) = vbNull Then Exit Function
            
            sPath = Left$(sPath, InStr(1, sPath, vbNullChar) - 1)
            Call AddSlash(sPath)
            Call SendMessage(hWnd, &H464, &H0, ByVal sPath)
            
            If Len(sArray(0)) = &H0 Then Exit Function
            Call SendMessage(hWnd, &H465, &H0, ByVal False)
            For ci = 0 To UBound(sArray)
                If Len(Dir$(sPath & sArray(ci))) Then
                    Call SendMessage(hWnd, &H465, &H0, ByVal True)
                    Exit For
                End If
            Next
    End Select
End Function

Private Function AddSlash(ByRef inPath As String) As String
    On Error GoTo er
    Dim nf As Integer: nf = FreeFile

    AddSlash = inPath
    Open inPath For Input As nf
    Close nf

    Exit Function
er: AddSlash = IIf(Right$(inPath, &H1) = "\", inPath, inPath & "\": inPath = AddSlash
End Function