Hallo Rainer,
ich hoffe, du hast noch etwas Geduld mit mir.
geht im Modul nicht, das hat Dir VB ja gesagt. Statt Me. mußt
Du den Namen der Form schreiben.
Ich habe keine Form erstellt, mein kompletter Code befindet sich in einem Modul. Mein VB-Projekt sieht folgendermaßen aus:
Modul1, Sheet1, ThisWorkbook. Folgenden Code habe ich ins das Modul1 kopiert. Muss ich damit es läuft noch eine Form erstellen? Wenn ja, welchen Teil vom Code muss dort schreiben?
Ich danke dir vielmals für deine Mühe.
Viele Grüße,
Michael
Option Explicit
' == Dialog-Einstellungen ================================
' String, der vor dem aktuell ausgewählen Verzeichnis angezeigt wird,
' falls der ShowCurrentPath-Paramter True ist.
Private Const DIALOG\_CURRENT\_SELECTION\_TEXT As String = "Auswahl: "
' == API-Deklarationen ===================================
Private Type BROWSEINFO
hOwner 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
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32.dll" \_
Alias "SHBrowseForFolderA" ( \_
lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" \_
Alias "SHGetPathFromIDListA" ( \_
ByVal lPIDL As Long, \_
ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( \_
ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" \_
Alias "SendMessageA" ( \_
ByVal hwnd As Long, \_
ByVal wMsg As Long, \_
ByVal wParam As Long, \_
lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" \_
Alias "RtlMoveMemory" ( \_
pDest As Any, \_
pSource As Any, \_
ByVal dwLength As Long)
Private Declare Function ILCreateFromPath Lib "shell32" \_
Alias "#157" ( \_
ByVal sPath As String) As Long
Private Declare Function LocalAlloc Lib "kernel32" ( \_
ByVal uFlags As Long, \_
ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" ( \_
ByVal hmem As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32" ( \_
lpString1 As Any, \_
lpString2 As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" ( \_
lpString As Any) As Long
Private Declare Function FindWindowEx Lib "user32.dll" \_
Alias "FindWindowExA" ( \_
ByVal hWnd1 As Long, \_
ByVal hWnd2 As Long, \_
ByVal lpsz1 As String, \_
ByVal lpsz2 As String) As Long
Private Declare Function GetWindowDC Lib "user32.dll" ( \_
ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( \_
ByVal hwnd As Long, \_
ByRef lpRect As RECT) As Long
Private Declare Function GetTextExtentPoint Lib "gdi32.dll" \_
Alias "GetTextExtentPointA" ( \_
ByVal hDC As Long, \_
ByVal lpszString As String, \_
ByVal cbString As Long, \_
ByRef lpSize As Size) As Long
Private Declare Function PathCompactPath Lib "shlwapi.dll" \_
Alias "PathCompactPathA" ( \_
ByVal hDC As Long, \_
ByVal pszPath As String, \_
ByVal dx As Long) As Long
Private Const MAX\_PATH = 260
Private Const WM\_USER = &H400
Private Const BFFM\_INITIALIZED = 1
Private Const BFFM\_SELCHANGED As Long = 2
Private Const BFFM\_SETSTATUSTEXTA As Long = (WM\_USER + 100)
Private Const BFFM\_SETSTATUSTEXTW As Long = (WM\_USER + 104)
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 BIF\_NEWDIALOGSTYLE As Long = &H40
Private Const BIF\_RETURNONLYFSDIRS As Long = &H1
Private Const BIF\_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF\_STATUSTEXT As Long = &H4
Private Const LMEM\_FIXED = &H0
Private Const LMEM\_ZEROINIT = &H40
Private Const LPTR = (LMEM\_FIXED Or LMEM\_ZEROINIT)
' Zeigt den BrowseForFolder-Dialog an.
Public Function BrowseForFolder(DialogText As String, \_
DefaultPath As String, \_
OwnerhWnd As Long, \_
Optional ShowCurrentPath As Boolean = True, \_
Optional RootPath As Variant, \_
Optional NewDialogStyle As Boolean = False, \_
Optional IncludeFiles As Boolean = False) As String
' Parameter:
' o DialogText Dialogtext, der oben im Dialog angezeigt wird.
' o DefaultPath Standardmäßig ausgewähltes Verzeichnis.
' o OwnerhWnd hWnd des übergeordneten Fensters (in den meisten
' Fällen Me.hWnd).
' o ShowCurrentPath Legt fest, ob die aktuelle Verzeichnisauswahl
' angezeigt werden soll. Verfügbar ab
' Internet Explorer 4.0 (-\> PathCompactPath).
' o RootPath Root-Verzeichnis. Wird es angegeben, werden nur die
' Ordner unterhalb dieses Verzeichnisses angezeigt.
' o NewDialogStyle Legt fest, ob der Dialog in der neuen Darstellung
' angezeigt werden soll (Dialog kann vergrößert/
' verkleinert werden, es ist eine Schaltfläche zum
' Anlegen eines neuen Ordners vorhanden, es können
' Dateioperationen wie löschen etc. ausgeführt
' werden, ...). Ist dieser Parameter True, hat der
' Parameter ShowCurrentPath keine Wirkung. Verfügbar
' unter WinME und Betriebsystemen ab Win2000.
' o IncludeFiles Legt fest, ob auch Dateien im Dialog angezeigt und
' ausgewählt werden können.
' Verfügbar ab Win98 und Internet Explorer 4.0 (bei
' frühreren Windowsversionen muss IE4 inkl. der
' Integrated Shell installiert sein).
Dim biBrowseInfo As BROWSEINFO
Dim lPIDL As Long
Dim sBuffer As String
Dim lBufferPointer As Long
With biBrowseInfo
' Handle des übergeordneten Fensters
.hOwner = OwnerhWnd
' PIDL des Rootordners zuweisen
If Not IsMissing(RootPath) Then .pidlRoot = PathToPIDL(RootPath)
' Dialogtext zuweisen
If ShowCurrentPath And DialogText = "$" Then DialogText = "" ' Wird intern nicht zugelassen
.lpszTitle = DialogText
' Stringbuffer für aktuell selektierten Pfad zuweisen
If ShowCurrentPath Then .pszDisplayName = sBuffer
' Dialogeinstellungen zuweisen
.ulFlags = BIF\_RETURNONLYFSDIRS + \_
IIf(ShowCurrentPath, BIF\_STATUSTEXT, 0) + \_
IIf(NewDialogStyle, BIF\_NEWDIALOGSTYLE, 0) + \_
IIf(IncludeFiles, BIF\_BROWSEINCLUDEFILES, 0)
' Callbackfunktion-Adresse zuweisen
.lpfnCallback = FARPROC(AddressOf CallbackString)
' PIDL des vorselektierten Ordnerpfades zuweisen (wird im
' lpData-Parameter an die Callback-Funktion weitergeleitet)
.lParam = PathToPIDL(DefaultPath)
End With
' BrowseForFolder-Dialog anzeigen
lPIDL = SHBrowseForFolder(biBrowseInfo)
If lPIDL Then
' Stringspeicher reservieren
sBuffer = Space$(MAX\_PATH)
' Selektierten Pfad aus der zurückgegebenen PIDL ermitteln
SHGetPathFromIDList lPIDL, sBuffer
' Nullterminierungszeichen des Strings entfernen
sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
' Selektierten Pfad zurückgeben
BrowseForFolder = sBuffer
' Reservierten Task-Speicher wieder freigeben
Call CoTaskMemFree(lPIDL)
End If
' Stringspeicher wieder freigeben
If ShowCurrentPath Then Call LocalFree(lBufferPointer)
End Function
Private Function CallbackString(ByVal hwnd As Long, ByVal uMsg As Long, \_
ByVal lParam As Long, ByVal lpData As Long) As Long
' Callback-Funktion des BrowseForFolder-Dialogs. Wird bei
' eintretenden Ereignissen des Dialogs aufgerufen.
Dim sBuffer As String
Dim lStaticWnd As Long
Dim lStaticDC As Long
Dim sPath As String
Dim rctStatic As RECT
Dim szTextSize As Size
' Meldungen herausfiltern
Select Case uMsg
Case BFFM\_INITIALIZED
' Dialog wurde initialisiert
' Standardmäßig markierten Pfad (dessen PIDL wurde in lpData
' übergeben) im Dialog selektieren
Call SendMessage(hwnd, BFFM\_SETSELECTIONA, False, ByVal lpData)
Case BFFM\_SELCHANGED
' Selektion hat sich geändert
' Stringspeicher reservieren
sBuffer = Space$(MAX\_PATH)
' Aktuell selektierten Pfad ermitteln und anzeigen, wenn möglich
If SHGetPathFromIDList(lParam, sBuffer) Then
' Temporäre Zeichenfolge an das Anzeigelabel senden, um
' dessen Handle anhand dieser Zeichenfolge ermitteln zu können
SendMessage hwnd, BFFM\_SETSTATUSTEXTA, 0&, ByVal "$"
' Handle und DeviceContext des Anzeigelabels ermitteln
lStaticWnd = FindWindowEx(hwnd, ByVal 0&, ByVal "Static", ByVal "$")
lStaticDC = GetWindowDC(lStaticWnd)
' Abmessungen des Anzeigelabels ermitteln
GetWindowRect lStaticWnd, rctStatic
' Textabmessungen der Zeichenfolge "Auswahl: " im Anzeigelabel
' ermitteln
GetTextExtentPoint lStaticDC, ByVal DIALOG\_CURRENT\_SELECTION\_TEXT, \_
ByVal Len(DIALOG\_CURRENT\_SELECTION\_TEXT), szTextSize
' Anzuzeigenden Pfad auf die Abmessungen des Anzeigelabels
' kürzen; falls dies nicht möglich ist, gesamten Pfad anzeigen
sPath = sBuffer
If PathCompactPath(ByVal lStaticDC, sPath, ByVal (rctStatic.Right - \_
rctStatic.Left - szTextSize.cx + 80)) = 0 Then sPath = sBuffer
' Nullterminierung entfernen
sPath = Left$(sPath, InStr(1, sPath, vbNullChar) - 1)
' Pfad im Dialog anzeigen
Call SendMessage(hwnd, BFFM\_SETSTATUSTEXTA, 0&, \_
ByVal DIALOG\_CURRENT\_SELECTION\_TEXT & sPath)
Else
' Pfadanzeige leeren
SendMessage hwnd, BFFM\_SETSTATUSTEXTA, 0&, ByVal ""
End If
End Select
End Function
Private Function FARPROC(FunctionPointer As Long) As Long
' Funktion wird benötigt, um Funktions-Adresse ermitteln
' zu können, dessen Adresse mit AddressOf übergeben und
' anschließend wieder zurückgegeben wird.
FARPROC = FunctionPointer
End Function
' Gibt die lPIDL zum übergebenen Pfad zurück.
Private Function PathToPIDL(ByVal sPath As String) As Long
Dim lRet As Long
lRet = ILCreateFromPath(sPath)
If lRet = 0 Then
sPath = StrConv(sPath, VbStrConv.vbUnicode)
lRet = ILCreateFromPath(sPath)
End If
PathToPIDL = lRet
End Function
Sub GetDirectory()
Dim directory As String
directory = BrowseForFolder("Select a directory", "C:\", Me.hwnd, True, , True, False)
MsgBox "directory"
End Sub
Ich hoffe nur, daß ich auch wirklich helfen kann, ich verstehe Deinen Code nämlich nicht vollständig. Beim ersten lesen, überfliegen ist mir nur bei der Durchsicht der Deklarationen aufgefallen, daß Du mit Subclassing in den Nachrichtenstrom eingreifen willst und Manipulationen des Arbeitsspeichers vor hast. Die Stelle, wo das passiert habe ich dann aber nicht gefunden …