Attribute VB_Name = "mod_CommonDialogs"
' Copyright (C) 2003-2007 Jan Vorel
'
' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.

' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.

' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

' This is a shared modul, class modul, usercontrol or form. It is also
' published under the GNU General Public License.

' If you have any questions, suggestions or bug reports about this product,
' contact me: info@ctuser.net; Do not contact me about general B.A.S.I.C.
' language or A.P.I. issues

Option Explicit
Option Base 0

' When opening multiple files, the first file is the path for all other files
' To check whether multiple files are to open, you may try
' Dim FileNameString As String
' Dim FileBasePath As String
' If InStr(FileNameString, Chr(0)) = InStr(FileNameString, Chr(0) + Chr(0)) Then
'   'Only one file to open
'   Else
'   'They are multiple files: You may act this way:
'   FileBasePath = Left(FileNameString, InStr(FileNameString, Chr(0)) - 1)
'   FileNameString = Mid(FileNameString, InStr(FileNameString, Chr(0)) + 1)
'   End If

'#CommonDLG_FlagA
'  1 OpenFileDialog
' 10 OpenPathDialog

'Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

#If (CommonDLG_FlagA And 1) = 1 Then
  Private Type tOpenType
    lStructSize As Long
    HwndOwner As Long
    hInstance As Long
    lpstrFilter As Long 'String
    lpstrCustomFilter As Long 'String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As Long
    nMaxFile As Long
    lpstrFileTitle As Long ' String
    nMaxFileTitle As Long
    lpstrInitialDir As Long 'String
    lpstrTitle As Long 'String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As Long ' String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
    End Type
  Private Declare Function GetOpenFileNameA Lib "comdlg32.dll" (pOpenfilename As tOpenType) As Long
  Private Declare Function GetOpenFileNameW Lib "comdlg32.dll" (pOpenfilename As tOpenType) As Long
  Private Declare Function GetSaveFileNameA Lib "comdlg32.dll" (pOpenfilename As tOpenType) As Long
  Private Declare Function GetSaveFileNameW Lib "comdlg32.dll" (pOpenfilename As tOpenType) As Long
  Public Const LoadSingleFile As Long = &H81004
  Public Const LoadMultipleFiles As Long = &H81204
  Public Const SaveSingleFile As Long = &H80006
  #End If

#If (CommonDLG_FlagA And &H10&) = &H10& Then
  Private Declare Function SHBrowseForFolderA Lib "shell32" (lpBI As BrowseInfo) As Long
  Private Declare Function SHBrowseForFolderW Lib "shell32" (lpBI As BrowseInfo) As Long
  Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pidList As Long, lpBuffer As Any) As Long
  Private Declare Function SHGetPathFromIDListW Lib "shell32" (ByVal pidList As Long, lpBuffer As Any) As Long
  Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
  Private xCurDir As Long
  Private Type BrowseInfo
    HwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long ' String
    lpszTitle As Long 'String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
    End Type
  #End If





#If (CommonDLG_FlagA And 1) = 1 Then
  Public Function CommonDLG_OpenFiles(ByVal hwnd As Long, ByVal Filters As String, ByVal FileMode As Long, ByVal DlgCaption As String, Optional ByVal InitDir As String) As String
    Dim xLong1 As Long
    'Dim xLong2 As Long
    
    Dim xType1 As tOpenType
    Const DataSize As Long = 32760&
    'Const DataSizeX As Long = DataSize - 1&
    'Const DataSizeXW As Long = Fix(DataSize \ 2&) - 1&
    Const DataSizeW As Long = (DataSize + 2&) * 2&
    'Const DataSizeTitle As Long = 32767&
    'Const DataSizeTitleW As Long = DataSizeTitle * 2&
    
    xLong1 = (1& - CLng(IsUnicode)) * (DataSize + 2&)
    With xType1
      .lpstrFilter = LocalAllocFromString(Filters & vbNullChar)
      .lpstrTitle = LocalAllocFromString(DlgCaption)
      .nFilterIndex = 1
      .lpstrFile = LocalAlloc(0&, xLong1)
      Call PokeL(.lpstrFile, 0&)
      .nMaxFile = DataSize
      .lpstrFileTitle = LocalAlloc(0&, xLong1)
      .nMaxFileTitle = DataSize
      .lStructSize = 76&
      'Debug.Print "Diff:", Len(xType1), LenB(xType1)
      .HwndOwner = hwnd
      .hInstance = App.hInstance
      If Not Len(InitDir) = 0& Then
        .lpstrInitialDir = LocalAllocFromString(InitDir)
        End If
      
      
      
      hwnd = InStr(Filters, vbNullChar) + 1&
      xLong1 = InStr(hwnd, Filters & vbNullChar, vbNullChar)
      If Not hwnd = 1& Then
        Filters = Mid(Filters, hwnd, InStr(hwnd, Filters & vbNullChar, vbNullChar) - hwnd)
        If Not Filters = "" Then
          .lpstrDefExt = LocalAllocFromString(Filters)
          End If
        End If
      .Flags = FileMode
      
      
'      CommonDLG_OpenFiles = ""
 '     Stop
      If FileMode = SaveSingleFile Then
        If IsUnicode Then
          xLong1 = GetSaveFileNameW(xType1)
          Else
          xLong1 = GetSaveFileNameA(xType1)
          End If
        ElseIf IsUnicode Then
        xLong1 = GetOpenFileNameW(xType1)
        Else
        xLong1 = GetOpenFileNameA(xType1)
        End If
'      Stop
      If Not xLong1 = 0& Then
        If FileMode = LoadMultipleFiles Then
          CommonDLG_OpenFiles = String(DataSize, vbNullChar)
          If IsUnicode Then
            Call RtlMoveMemory(ByVal StrPtr(CommonDLG_OpenFiles), xType1.lpstrFile, DataSizeW)
            Else
            Call RtlMoveMemory(ByVal CommonDLG_OpenFiles, xType1.lpstrFile, DataSize)
            End If
          xLong1 = InStr(CommonDLG_OpenFiles, vbNullChar & vbNullChar)
          If xLong1 = 0& Then
            CommonDLG_OpenFiles = ""
            Else
            CommonDLG_OpenFiles = Left(CommonDLG_OpenFiles, xLong1 + 1&)
            End If
          Else
          CommonDLG_OpenFiles = PeekS(xType1.lpstrFile)
          End If
        'Else
        'Debug.Print CommDlgExtendedError
        End If
      TryFree .lpstrFilter
      TryFree .lpstrTitle
      TryFree .lpstrFile
      TryFree .lpstrFileTitle
      TryFree .lpstrInitialDir
      TryFree .lpstrDefExt
      End With
    End Function
  
  Private Sub TryFree(ByVal ptrMem As Long)
    If Not ptrMem = 0& Then Call LocalFree(ptrMem)
    End Sub
  #End If












#If (CommonDLG_FlagA And &H10&) = &H10& Then
  Public Function CommonDLG_OpenPath(ByVal hwnd As Long, ByVal Caption As String, Optional ByVal InitDir As String) As String
    Dim xLong1 As Long
    Dim xType1 As BrowseInfo
    
    xType1.HwndOwner = hwnd
    xType1.lpszTitle = LocalAllocFromString(Caption) '0 '"Add directory"
    xType1.ulFlags = &H1&    '&H3&
    'InitDir = "c:\q0400b"
    If Not Len(InitDir) = 0& Then
      xCurDir = LocalAllocFromString(InitDir & vbNullChar)
      xType1.lpfnCallback = CommonDLG_OpenPath_CallbackProc(-2&, 0&, AddressOf CommonDLG_OpenPath_CallbackProc, 0&)
      End If
    If IsUnicode Then
      xLong1 = SHBrowseForFolderW(xType1)
      Else
      xLong1 = SHBrowseForFolderA(xType1)
      End If
    If Not xLong1 = 0& Then
      'CommonDLG_OpenPath = String(260&, vbNullChar) 'Space(260&)
      If IsUnicode Then
        hwnd = SHGetPathFromIDListW(xLong1, ByVal ptrTemp)
        Else
        hwnd = SHGetPathFromIDListA(xLong1, ByVal ptrTemp)
        End If
      If Not hwnd = 0& Then
        hwnd = LocalLock(ptrTemp)
        If Not hwnd = 0& Then
          CommonDLG_OpenPath = PeekS(hwnd)
          Call LocalUnlock(ptrTemp)
          End If
        End If
      Call CoTaskMemFree(xLong1)
      End If
    If Not xCurDir = 0& Then
      Call LocalFree(xCurDir)
      xCurDir = 0&
      End If
    If Not xType1.lpszTitle = 0& Then Call LocalFree(xType1.lpszTitle)
    End Function

  Private Function CommonDLG_OpenPath_CallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lData As Long) As Long
    'Dim sbuffer As String
    'Dim Ret As Long
    
    On Error Resume Next
    If hwnd = -2& Then
      CommonDLG_OpenPath_CallbackProc = lParam
      Else
      Select Case uMsg
        Case 1&
'
'          Debug.Print xCurDir, PeekS(xCurDir)
          Call SendMessage(hwnd, &H466&, 1&, xCurDir)
        Case 2&
          'wParam = LocalLock(ptrTemp)
          'If Not wParam = 0& Then
            If IsUnicode Then
              If SHGetPathFromIDListW(lParam, ByVal ptrTemp) = 1& Then
                Call SendMessage(hwnd, &H464&, 0&, ByVal ptrTemp)
                End If
              ElseIf SHGetPathFromIDListA(lParam, ByVal ptrTemp) = 1& Then
              Call SendMessage(hwnd, &H464&, 0&, ByVal ptrTemp)
              End If
          '  Call LocalUnlock(ptrTemp)
          '  End If
        End Select
      CommonDLG_OpenPath_CallbackProc = 0&
      End If
    End Function
  #End If
