AW: Fehlerteufel - erledigt Danke ganzer Code
13.06.2008 13:21:47
Lutz
Hallo,
vielen Dank. Anbei mal der ganze Code:
Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal lpWindowName As String) As Long
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_RETURNONLYFSDIRSCREATENEW As Long = &H40
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Function GetAOrdner() As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlMain", vbNullString)
.Title = lstrcat("Bitte wählen Sie ein Verzeichnis", "")
.Flags = BIF_BROWSEINCLUDEFILES
End With
IDList = SHBrowseForFolder(xl)
If IDList 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim$(FolderName)
FolderName = Left$(FolderName, Len(FolderName) - 1)
End If
GetAOrdner = FolderName
End Function
Public Sub Dateiliste_Hyperlinks_2()
Dim lngCount As Long
Dim lngZahl As Long
Dim lngZahl1 As Long
Dim strPfad As String
Dim blnMsg As Boolean
Dim strErweiterung As String
On Error GoTo Dateiliste_Hyperlinks_Error
lngZahl1 = 2
strPfad = GetAOrdner
If strPfad = "" Then Exit Sub
Select Case MsgBox("Sollen auch die Unterverzeichnisse des ausgewaehletn Ordners mit _
ausgegeben werden?", _
vbYesNo Or vbQuestion Or vbDefaultButton1, "Unterverzeichnisse - Ja / Nein")
Case vbYes
blnMsg = True
Case vbNo
blnMsg = False
End Select
strErweiterung = InputBox("Bitte in der Art *.Erweiterung angeben", "Extension", "*.xls")
If strErweiterung = "" Then Exit Sub
Worksheets(1).Columns(2).Clear
With Application.FileSearch
.NewSearch
.LookIn = strPfad
.Filename = strErweiterung
.SearchSubFolders = blnMsg
.Execute
lngCount = .FoundFiles.Count
For lngZahl = 1 To lngCount
Worksheets(1).Hyperlinks.Add anchor:=Worksheets(1).Cells(lngZahl1, 2), Address:=. _
FoundFiles(lngZahl)
lngZahl1 = lngZahl1 + 1
Next lngZahl
End With
Columns.AutoFit
On Error GoTo 0
Exit Sub
Dateiliste_Hyperlinks_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Sub
Public Sub Dateiliste_ohneHyperlinks_2()
Dim lngCount As Long
Dim lngZahl As Long
Dim lngZahl1 As Long
Dim strPfad As String
Dim blnMsg As Boolean
Dim strErweiterung As String
On Error GoTo Dateiliste_Hyperlinks_Error
lngZahl1 = 2
strPfad = GetAOrdner
If strPfad = "" Then Exit Sub
Select Case MsgBox("Sollen auch die Unterverzeichnisse des ausgewaehletn Ordners mit _
ausgegeben werden?", _
vbYesNo Or vbQuestion Or vbDefaultButton1, "Unterverzeichnisse - Ja / Nein")
Case vbYes
blnMsg = True
Case vbNo
blnMsg = False
End Select
strErweiterung = InputBox("Bitte in der Art *.Erweiterung angeben", "Extension", "*.xls")
If strErweiterung = "" Then Exit Sub
Worksheets(1).Columns(2).Clear
With Application.FileSearch
.NewSearch
.LookIn = strPfad
.Filename = strErweiterung
.SearchSubFolders = blnMsg
.Execute
lngCount = .FoundFiles.Count
For lngZahl = 1 To lngCount
Worksheets(1).Cells(lngZahl1, 2).Value = .FoundFiles(lngZahl)
lngZahl1 = lngZahl1 + 1
Next lngZahl
End With
Columns.AutoFit
On Error GoTo 0
Exit Sub
Dateiliste_Hyperlinks_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Sub
Sub HyperlinksRaus()
Selection.Hyperlinks.Delete
End Sub
Sub DeleteHyperLinks()
Range("A:Z").Hyperlinks.Delete
End Sub
Die letzten beiden entfernen die Hyperlinks - so hatte ich mir schnell geholfen.
Vielen Dank an Euch beide und ein schönes Wochenende.
Gruß Lutz