CADsite

  • za 23 03 2019, 00:28:10
  • Welkom, gast
Log in of registreer jezelf.

Login met gebruikersnaam, wachtwoord en sessielengte
Geavanceerd zoeken  

Nieuws:

Poll

Ik heb een folderbrowse in mijn vba programma zitten wat nu niet meer werkt. Wie kan mij helpen aan een folderbrowse voor een 64 bit pc

Help mij
- 0 (0%)
Suggesties
- 1 (100%)

Totaal aantal stemmen: 1


Pagina's: [1]   Omlaag

Auteur Topic: Folderbrowse 64 bit computer  (gelezen 2256 keer)

thoma061

  • forum starter
  • *
  • Offline Offline
  • Berichten: 1
    • Bekijk profiel
Folderbrowse 64 bit computer
« Gepost op: do 02 06 2016, 14:04:38 »

Ik heb een folderbrowse in mijn vba programma zitten wat nu niet meer werkt. Wie kan mij helpen aan een folderbrowse voor een 64 bit pc
Gelogd

EddyBeerke

  • forumverslaafde
  • ******
  • Offline Offline
  • Berichten: 2334
  • 1d CADSITE.be niet bezoeken = 1 dag niet geleefd!
    • Bekijk profiel
    • Mijn site
Re: Folderbrowse 64 bit computer
« Reactie #1 Gepost op: do 02 06 2016, 14:14:37 »

Ik heb gestemd...
Beter niet een poll starten is mijn suggestie.
Gelogd

EddyBeerke

  • forumverslaafde
  • ******
  • Offline Offline
  • Berichten: 2334
  • 1d CADSITE.be niet bezoeken = 1 dag niet geleefd!
    • Bekijk profiel
    • Mijn site
Re: Folderbrowse 64 bit computer
« Reactie #2 Gepost op: do 02 06 2016, 14:17:52 »

Misschien heb je hier iets aan?
Kwam ik een keer tegen op het www.
Option Explicit
'----------------------------------------------------------------------
' 64 bit VBA 7 version of File and Folder Browswers
' FileBrowseOpen()
' FileBrowseSave()
' FolderBrowse()
' Much of the original 32 bit module was donated by the good people of XtremeVbTalk.com
' I massaged it to be 64 bit with VBA 7 code lifted from numerous sites on the web
'----------------------------------------------------------------------

Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
(ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long


Public Declare PtrSafe Function SendMessageA Lib "user32" _
(ByVal Hwnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)

Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const CSIDL_DRIVES As Long = &H11
Private Const WM_USER As Long = &H400
Private Const MAX_PATH As Long = 260
'// message from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN As Long = 5 '// provides IUnknown to client. lParam: IUnknown*
'// messages to browser
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only


Private Type OPENFILENAME
lStructSize As Long
hWndOwner As LongPtr
hInstance As LongPtr
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 LongPtr
lpTemplateName As String
End Type
Public Type BrowseInfo
hWndOwner As LongPtr
pIDLRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As LongPtr
lParam As LongPtr
iImage As Long
End Type
 
Sub OpenFile_test()
Dim F
F = FileBrowseOpen("d:", "Open File", "*.dwg", 1)
Debug.Print F
End Sub
 
Sub FolderBrowse_test()
Dim F
F = FolderBrowse("Open Folder", "1")
Debug.Print F
End Sub
 
'====== File Browsers for 64 bit VBA 7 ========
Public Function FileBrowseOpen(ByVal sInitFolder As String, _
ByVal sTitle As String, _
ByVal sFilter As String, _
ByVal nFilterIndex As Integer) As String


Dim OpenFile As OPENFILENAME
Dim lReturn As Long

sInitFolder = CorrectPath(sInitFolder)


OpenFile.lpstrInitialDir = sInitFolder

' Swap filter separator for api separator
sFilter = Replace(sFilter, "|", Chr(0))



OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = nFilterIndex
OpenFile.lpstrTitle = sTitle


OpenFile.hWndOwner = 0
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = LenB(OpenFile)

OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile

OpenFile.flags = 0

lReturn = GetOpenFileName(OpenFile)

If lReturn = 0 Then
FileBrowseOpen = ""
Else
FileBrowseOpen = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function
Public Function FileBrowseSave(ByVal sDefaultFilename As String, _
ByVal sInitFolder As String, _
ByVal sTitle As String, _
ByVal sFilter As String, _
ByVal nFilterIndex As Integer) As String
Dim PadCount As Integer
Dim OpenFile As OPENFILENAME
Dim lReturn As Long

sInitFolder = CorrectPath(sInitFolder)

' Swap filter separator for api separator
sFilter = Replace(sFilter, "|", Chr(0))

OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.hWndOwner = 0

PadCount = 260 - Len(sDefaultFilename)
OpenFile.lpstrFile = sDefaultFilename & String(PadCount, Chr(0))
'OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = LenB(OpenFile)

OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = sInitFolder
OpenFile.lpstrTitle = sTitle
OpenFile.flags = 0
lReturn = GetSaveFileName(OpenFile)

If lReturn = 0 Then
FileBrowseSave = ""
Else
FileBrowseSave = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function
 

'====== Folder Browser for 64 bit VBA 7 ========
Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String
Dim ReturnPath As String

Dim b(MAX_PATH) As Byte
Dim pItem As Long
Dim sFullPath As String
Dim bi As BrowseInfo
Dim ppidl As Long

sInitFolder = CorrectPath(sInitFolder)

' Note VBA windows and dialogs do not have an hWnd property.
bi.hWndOwner = 0 'Windows Main Screen handle.

' SHGetSpecialFolderLocation bi.hWndOwner, CSIDL_DRIVES, ppidl

bi.pIDLRoot = 0 'ppidl


bi.pszDisplayName = VarPtr(b(0))
bi.lpszTitle = sDialogTitle
bi.ulFlags = BIF_RETURNONLYFSDIRS
If FolderExists(sInitFolder) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
bi.lParam = StrPtr(sInitFolder)
pItem = SHBrowseForFolder(bi)

If pItem Then ' Succeeded
sFullPath = Space$(MAX_PATH)
If SHGetPathFromIDList(pItem, sFullPath) Then
ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
CoTaskMemFree pItem
End If
End If

If ReturnPath <> "" Then
If Right$(ReturnPath, 1) <> "\" Then
ReturnPath = ReturnPath & "\"
End If
End If

FolderBrowse = ReturnPath

End Function
' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData);
Private Function BFFCallback(ByVal Hwnd As LongPtr, ByVal uMsg As LongPtr, ByVal lParam As LongPtr, ByVal sData As String) As LongPtr
If uMsg = BFFM_INITIALIZED Then
SendMessageA Hwnd, BFFM_SETSELECTIONA, True, ByVal sData
End If
End Function
Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
PtrToFunction = lFcnPtr
End Function
Private Function CorrectPath(ByVal sPath As String) As String
If Right$(sPath, 1) = "\" Then
If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
Else
If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
End If
CorrectPath = sPath
End Function

Public Function FolderExists(ByVal sFolderName As String) As Boolean
Dim att As Long
On Error Resume Next
att = GetAttr(sFolderName)
If Err.Number = 0 Then
FolderExists = True
Else
Err.Clear
FolderExists = False
End If
On Error GoTo 0
End Function


Gelogd
Pagina's: [1]   Omhoog