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

#If (CommonDLG_FlagA And 1) = 1 Then
  Private Type tOpenType
    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 Declare Function GetOpenFileNameA Lib "comdlg32.dll" (pOpenfilename As tOpenType) As Long
  Private Declare Function GetSaveFileNameA 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 SHBrowseForFolder Lib "shell32" (lpBI As BrowseInfo) As Long
  Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
  Private xCurDir As String
  Private Type BrowseInfo
    HwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As String
    lpszTitle As 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 xType1 As tOpenType
    
    With xType1
      .lpstrFilter = Filters
      .lpstrTitle = DlgCaption
      .nFilterIndex = 1
      .lpstrFile = String(32767&, vbNullChar)
      .nMaxFile = 32766&
      .lpstrFileTitle = .lpstrFile
      .nMaxFileTitle = .nMaxFile
      .lStructSize = Len(xType1)
      .HwndOwner = hwnd
      .hInstance = App.hInstance
      .lpstrInitialDir = InitDir
      hwnd = InStr(Filters, vbNullChar) + 1&
      xLong1 = InStr(hwnd, Filters & vbNullChar, vbNullChar)
      If Not hwnd = 1& Then
        CommonDLG_OpenFiles = Mid(Filters, hwnd, InStr(hwnd, Filters & vbNullChar, vbNullChar) - hwnd)
        If Not CommonDLG_OpenFiles = "" Then
          .lpstrDefExt = CommonDLG_OpenFiles
          End If
        End If
      .Flags = FileMode
      End With
    CommonDLG_OpenFiles = ""
    If FileMode = &H81004 Or FileMode = &H81204 Then
      If GetOpenFileNameA(xType1) Then CommonDLG_OpenFiles = xType1.lpstrFile
      Else
      If GetSaveFileNameA(xType1) Then CommonDLG_OpenFiles = xType1.lpstrFile
      End If
    If Not FileMode = &H81204 Then
      hwnd = InStr(CommonDLG_OpenFiles, vbNullChar)
      If hwnd = 0& Then
        CommonDLG_OpenFiles = ""
        Else
        CommonDLG_OpenFiles = Left(CommonDLG_OpenFiles, hwnd - 1&)
        End If
      End If
    End Function
  #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 = Caption '0 '"Add directory"
    xType1.ulFlags = &H1&    '&H3&
    'InitDir = "c:\q0400b"
    If Not InitDir = "" Then
      xCurDir = InitDir & vbNullChar
      xType1.lpfnCallback = CommonDLG_OpenPath_CallbackProc(-2&, 0&, AddressOf CommonDLG_OpenPath_CallbackProc, 0&)
      End If
    xLong1 = SHBrowseForFolder(xType1)
    If Not xLong1 = 0& Then
      CommonDLG_OpenPath = String(260&, vbNullChar) 'Space(260&)
      SHGetPathFromIDList xLong1, CommonDLG_OpenPath
      CommonDLG_OpenPath = Left(CommonDLG_OpenPath, InStr(CommonDLG_OpenPath, vbNullChar) - 1)
      Call CoTaskMemFree(xLong1)
      End If
    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&
          Call SendMessagestring(hwnd, &H466&, 1&, xCurDir)
        Case 2&
          sbuffer = Space(260&)
          If SHGetPathFromIDList(lParam, sbuffer) = 1& Then Call SendMessagestring(hwnd, &H464&, 0&, sbuffer)
        End Select
      CommonDLG_OpenPath_CallbackProc = 0&
      End If
    End Function
  #End If
