Attribute VB_Name = "LibBuild_Module"
' Copyright (C) 2008-2010 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

' 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

Public VBInstance As VBIDE.VBE
'Private Declare Function WritePrivateProfileStringA Lib "kernel32" (ByVal AppName As String, ByVal KeyName As String, ByVal keydefault As String, ByVal FileName As String) As Long

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

Private CommonDLG_OpenPath_CurDir As Long
Public Declare Sub RtlMoveMemory Lib "kernel32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetClassNameA Lib "user32" (ByVal hWnd As Long, lpClassName As Any, ByVal nMaxCount As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SendMessageA Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function lstrcpynA Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As Long) As Long
Private Declare Function SHBrowseForFolderA Lib "shell32" (lpBI As BrowseInfo) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

Public ptrTemp As Long
Private Const ptrTempSize As Long = 32000 ' int (signed?), so crashes with some apis

'Public Sub AddToINI()
'  Call WritePrivateProfileStringA("Add-Ins32", "LibBuild.Connect", "0", "vbaddin.ini")
'  End Sub







Public Function LocalAllocFromString(ByVal xChar1 As String) As Long ', Optional ByVal FixedPos As Boolean = True) As Long
  Dim xLong1 As Long
  
  xChar1 = xChar1 & vbNullChar
  xLong1 = Len(xChar1)
  
  LocalAllocFromString = LocalAlloc(0&, xLong1)
  If Not LocalAllocFromString = 0& Then
    Call RtlMoveMemory(ByVal LocalAllocFromString, ByVal xChar1, xLong1)
    End If
  End Function

Public Function PeekS(ByVal ptrChar As Long, Optional ByVal MaxLength As Long = -1&) As String
  Dim xLong1 As Long
  
  If Not ptrChar = 0& Then
    If MaxLength = -1& Then MaxLength = &HFFFF&
    xLong1 = lstrlenA(ptrChar)
    If xLong1 > MaxLength Then xLong1 = MaxLength
    PeekS = String(xLong1 + 1&, vbNullChar)
    Call lstrcpynA(PeekS, ptrChar, xLong1 + 1&)
    PeekS = Left(PeekS, xLong1)
    End If
  End Function

Private Function CommonDLG_OpenPath_GetTreeView(hWnd) As Long
  Dim xChar1 As String
  
  xChar1 = String(16&, vbNullChar)
  CommonDLG_OpenPath_GetTreeView = GetWindow(hWnd, 5&)
  Do While (Not (CommonDLG_OpenPath_GetTreeView = 0&))
    If GetClassNameA(CommonDLG_OpenPath_GetTreeView, ByVal xChar1, 15&) = 13& Then
      If LCase(Left(xChar1, 13&)) = "systreeview32" Then
        Exit Do
        End If
      End If
    CommonDLG_OpenPath_GetTreeView = GetWindow(CommonDLG_OpenPath_GetTreeView, 2&)
    Loop
  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
  On Error Resume Next
  If hWnd = -2& Then
    CommonDLG_OpenPath_CallbackProc = lParam
    Else
    Select Case uMsg
      Case 1&
        uMsg = CommonDLG_OpenPath_GetTreeView(hWnd)
        If Not uMsg = 0& Then
          Call ShowWindow(uMsg, 0&)
          Call SetWindowLongA(uMsg, -16&, (GetWindowLongA(uMsg, -16&) And &HFFFFFBF7) Or &H1020&)
          Call ShowWindow(uMsg, 5&)
          End If
        If Not CommonDLG_OpenPath_CurDir = 0& Then
          Call SendMessageA(hWnd, &H466&, 1&, ByVal CommonDLG_OpenPath_CurDir)
          End If
      Case 2&
        If SHGetPathFromIDListA(lParam, ByVal ptrTemp) = 1& Then
          Call SendMessageA(hWnd, &H464&, 0&, ByVal ptrTemp)
          End If
        '#If (CommonDLG_FlagA And &H30&) = &H30& Then
        #If CommonDLG_OpenPath_CallbackHack Then
          CommonDLG_CallbackProc_Change hWnd, PeekS(ptrTemp)
          #End If
      End Select
    CommonDLG_OpenPath_CallbackProc = 0&
    End If
  End Function

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
    
  ptrTemp = LocalAlloc(0&, ptrTempSize)
  If Not ptrTemp = 0& Then
    If Len(InitDir) > 3& And Right(InitDir, 1&) = "\" Then InitDir = Left(InitDir, Len(InitDir) - 1&)
    xType1.hWndOwner = hWnd
    xType1.lpszTitle = LocalAllocFromString(Caption)
    xType1.ulFlags = &H1&    '&H3&
    If Not Len(InitDir) = 0& Then
      CommonDLG_OpenPath_CurDir = LocalAllocFromString(InitDir & vbNullChar)
      End If
    xType1.lpfnCallback = CommonDLG_OpenPath_CallbackProc(-2&, 0&, AddressOf CommonDLG_OpenPath_CallbackProc, 0&)
    xLong1 = SHBrowseForFolderA(xType1)
    If Not xLong1 = 0& Then
      hWnd = SHGetPathFromIDListA(xLong1, ptrTemp)
      If Not hWnd = 0& Then
        CommonDLG_OpenPath = PeekS(ptrTemp)
        End If
      Call CoTaskMemFree(xLong1)
      End If
    If Not CommonDLG_OpenPath_CurDir = 0& Then
      Call LocalFree(CommonDLG_OpenPath_CurDir)
      CommonDLG_OpenPath_CurDir = 0&
      End If
    If Not xType1.lpszTitle = 0& Then Call LocalFree(xType1.lpszTitle)
    Call LocalFree(ptrTemp)
    End If
  End Function


