Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
440to444
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
440to444
440to444
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

MsgBox beim auswählen einen Ordner

MsgBox beim auswählen einen Ordner
16.06.2004 13:58:36
Rosenwasser
Hallo allen,
Ich arbeite mit der Funktion BrowseDirectory um Dateien aus zu lesen.
Gerne wollte ich einen MsgBox sehen wenn keinen z.B. ".gbm" Dateien anwesend sein in den ausgewählte Ordner. Text: "Keine .gbm Dateien in diese Ordner, bitte wahlen sie einen anderen Ordner aus mit .gbm files"
Beim OK drucken diese MsgBox soll dass auswählen einen Ordner wieder möglich sein.
mfg
Benny
Option Explicit
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.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 Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" _
(ByVal szPath As String) As Long
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
Private Const BFFM_INITIALIZED As Long = 1
Private Const MAX_PATH As Long = 260
Private Const WM_USER As Long = &H400
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
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 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
' Callback für die Browse-Directory-Methode - "pidList"-Methode
' zur Verwendung in der BrowseDirectory()-Funktion

Private Function BrowseCallBackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Voreinstellung des Verzeichnisses im Verzeichnis-
'Dialog unter Verwendung des Parameters "pidList"
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData)
Case Else
End Select
End Function

' Dummy-Methode, um den Inhalt des AddressOf-Operators zu erhalten und
' zur Verwendung in der BrowseDirectory()-Funktion zurückzugeben

Private Function FARPROC(pfn As Long) As Long
'Einstellen und Erhalten der Adresse für ein Callback. Das ist notwendig,
'weil man "AddressOf" nicht direkt einem benutzerdefinierten Typ zuweisen
'kann. Man kann es aber einer anderen Variablen vom Typ "Long" zuweisen,
'der - wie hier auch von der Function zurückgegeben - weiter verwendet
'werden kann.
FARPROC = pfn
End Function

' "pidList"-Parameter für den vorgegebenen Pfad wird durch den Aufruf
' der undokumenteierten API-Funktion #162 zurückgegeben.

Private Function GetPIDLFromPath(ByVal sPath As String) As Long
'If IsWinNT Then
GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode))
'Else
'    GetPIDLFromPath = SHSimpleIDListFromPath(sPath)
'End If
End Function

Public Function BrowseDirectory(Optional ByVal strInitialDir As String, Optional ByVal _
hWnd As Long) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "Please select a directory"
With tBrowseInfo
.hwndOwner = hWnd
.pIDLRoot = 0
.lpszTitle = szTitle
' .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
.lpfnCallback = FARPROC(AddressOf BrowseCallBackProc)
.lParam = GetPIDLFromPath(strInitialDir)
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseDirectory = sBuffer
' Ressourcen freigeben
CoTaskMemFree lpIDList
Else
BrowseDirectory = strInitialDir
End If
' Ressourcen freigeben
CoTaskMemFree tBrowseInfo.lParam
End Function
Sub OrdnerAuswahl()
Dim strInitialDir As String, strPath As String
Dim sFile As String, sPattern As String, sPath As String
Dim iRow As Integer
Columns(1).ClearContents ' Kolom A leegmaken
strPath = BrowseDirectory()

Range("B1") = strPath

If strPath = "" Then Exit Sub
'einlesen
If Right(sPath, 1) "\" Then strPath = strPath & "\"
sPattern = "*.gbm"
sFile = Dir(strPath & sPattern)
Do Until sFile = ""
iRow = iRow + 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(iRow, 1), _
Address:=strPath & sFile, TextToDisplay:=sFile
sFile = Dir()
Loop

End Sub

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: MsgBox beim auswählen einen Ordner
16.06.2004 14:15:37
kdosi
Hallo Benny, ich habe gerade etwas sehr ehnliches gemacht (Du bist schon der dritte, dem ich es jetzt schicke, das nenne ich Code Re-Use :-)))
https://www.herber.de/bbs/user/7449.xls
Schau es Dir mal an, es reagiert auf doouble click. Am Anfang muss man die Referentz auf Microsof Scripting Runtime setzen. Falls Du damit Probleme haben solltest, dann schreib mir bitte. Gruss kdosi, CZ [DDMAIL@seznam.cz]
AW: MsgBox beim auswählen einen Ordner
16.06.2004 15:08:08
Rosenwasser
Super! DANKE, genau was ich suche.
Habe doch zwei beikommende fragen.
1)Kann ich einen bestimmte Ordner Auswahl, wo man anfangt zu suchen? Z.B."C:\GBM\Dateien"
2)Wie kann ich erreichen dass nur die *.gbm Dateien sehen lasst in den untersten Bereich?
Mit dank im voraus
Benny?
Anzeige
AW: MsgBox beim auswählen einen Ordner
kdosi
Hallo, es ist moeglich :-), hier der code, der User Form ist der gleiche. Der Folder, wo man anfangt zu suchen ist im code in der Konstante STARTING_FOLDER festgelegt, also man sollte ihn dort aendern ... Jetzt ist es "C:\Temp". Gruss kdosi
Option Explicit
Private fso As FileSystemObject
Private fld_current_path As String
Private Const FILTER As String = "gbm"
Private Const STARTING_FOLDER As String = "C:\Temp"

Private Sub cboLaufwerke_Change()
On Error GoTo Err_In_cboLaufwerke_Change
If (Me.cboLaufwerke.ListIndex = -1) Then Exit Sub
fld_current_path = Me.cboLaufwerke.Value & ":\"
Call lstFolders_Fill
Call lstDateien_Fill
Exit Sub
Err_In_cboLaufwerke_Change:
MsgBox Err.Description, vbCritical, "Error [cboLaufwerke_Change]"
End Sub


Private Sub cmdCancel_Click()
VBA.Unload Me
End Sub


Private Sub lstDateien_Fill()
On Error GoTo Err_In_lstDateien_Fill
If (Me.lstFolders.ListCount = 0) Then Exit Sub
Dim fld_current As Folder
Dim fe As File
Dim hat_filter_datei As Boolean
hat_filter_datei = False
Set fld_current = fso.GetFolder(fld_current_path)
Me.lstDateien.Clear
For Each fe In fld_current.Files
If (VBA.Right(fe.Name, 3) = FILTER) Then
hat_filter_datei = True
Me.lstDateien.AddItem fe.Name & "    (" & fe.Type & ")"
End If
Next fe
If (hat_filter_datei = False) Then
If (MsgBox("Keine ." & FILTER & " Dateien in diese Ordner, bitte wahlen sie einen anderen Ordner aus mit ." & _
FILTER & " files", vbExclamation + vbOKCancel) = vbCancel) Then
End
End If
End If
Exit Sub
Err_In_lstDateien_Fill:
MsgBox Err.Description, vbCritical, "Error [lstDateien_Fill]"
End Sub


Private Sub lstFolders_Fill()
On Error GoTo Err_In_lstFoldersInhalt_Fill
Dim fld_current As Folder
Dim fld As Folder
Set fld_current = fso.GetFolder(fld_current_path)
With Me.lstFolders
.Clear
.AddItem "..", 0
End With
For Each fld In fld_current.SubFolders
Me.lstFolders.AddItem fld.Name
Next fld
Me.lblPfad.Caption = fld_current_path
Exit Sub
Err_In_lstFoldersInhalt_Fill:
If (Err.Number = 76) Then
MsgBox Err.Description & vbCrLf & "Laufwerk ist leer oder ausser Betrieb.", vbExclamation, "Error"
Else
MsgBox Err.Description, vbCritical, "Error [lstFolders_Fill]"
End If
Call Controls_Reset
End Sub


Private Sub cmdOK_Click()
' code hier ...
' z.B.:
MsgBox "Pfad ist : " & fld_current_path
End Sub


Private Sub lstFolders_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If (Me.lstFolders.ListIndex = -1) Then Exit Sub
Dim fld_name As String
fld_name = Me.lstFolders.Value
' zurueck bewegen
If (fld_name = "..") Then
Dim backslash_pos
backslash_pos = VBA.InStrRev(fld_current_path, "\")
' sind wir am root?
If (VBA.Len(fld_current_path) > 3) Then
fld_current_path = VBA.Left(fld_current_path, backslash_pos - 1)
If (VBA.Len(fld_current_path) = 2 And VBA.Right(fld_current_path, 1) <> "\") Then
fld_current_path = fld_current_path & "\"
End If
Else
Exit Sub
End If
' vorwaerts bewegen
Else
If (VBA.Right(fld_current_path, 1) = "\") Then
fld_current_path = fld_current_path & fld_name
Else
fld_current_path = fld_current_path & "\" & fld_name
End If
End If
Call lstFolders_Fill
Call lstDateien_Fill
End Sub


Private Sub Controls_Reset()
With Me
.cboLaufwerke.ListIndex = -1
.lstDateien.Clear
.lstFolders.Clear
.lblPfad.Caption = ""
End With
End Sub


Private Sub UserForm_Initialize()
On Error GoTo Err_UserForm_Initialize
Dim drv As Drive
Set fso = New FileSystemObject
For Each drv In fso.Drives
Me.cboLaufwerke.AddItem drv.DriveLetter '  & " [" & drv.DriveType & "]"
Next drv
fld_current_path = STARTING_FOLDER
Call lstFolders_Fill
Call lstDateien_Fill
Exit Sub
Err_UserForm_Initialize:
MsgBox Err.Description, vbCritical, "Error [UserForm_Initialize]"
End Sub

Anzeige
AW: MsgBox beim auswählen einen Ordner
16.06.2004 16:23:50
Rosenwasser
Danke,
Funktioniert in einen stand allone Datei.
Habe alles eingefügt in meinen Programm, und hier will es nicht funktionieren!
Gibt Fehlermeldung bei -> Private fso As FileSystemObject Was kann die Fehler sein?
Benny
AW: MsgBox beim auswählen einen Ordner
Rosenwasser
OK, gefunden,
Ich war vergessen den Verweis MS Scripting Runtime ein zu schalten!
Benny
AW: MsgBox beim auswählen einen Ordner
Rosenwasser
WOW, was is jetzt passiert?
Ich habe den Code in meines Programm eingefügt, und funktioniert auch.
Aber was ich jetzt gesehen habe ist, dass in dass unterliegendes UserForm alle Zeilen in die ListBoxen nochmal automatisch dazu geschrieben wurde.
Was kann hier der Fehler sein?
Danke, Benny
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige