AW: Dateiname auslesen - Hyperlinks zuweisen
geri
Hallo Dieter
hier ein Beispiel
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function FunktionGetDirectory(Optional strAufforderung) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(strAufforderung) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = strAufforderung
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
FunktionGetDirectory = Left(Path, pos - 1)
Else
FunktionGetDirectory = ""
End If
End Function
'G.Gall 3.09.03
Sub Dateien_Search_Listing()
Dim fsObjekt As Object, index As Integer
Dim C As Range
Dim datErweiterung As String
Dim Meldung As String
Dim letzteZeile As String
Dim DataOption1 As String
Dim intPos As Integer
Dim strLink As String
Dim sPath As Variant
Dim Merker As String
Dim Pruef As Integer
Range("b5").Select
Selection.Interior.ColorIndex = 3
Application.ScreenUpdating = False
sPath = FunktionGetDirectory
'If FunktionGetDirectory = "" Then Exit Sub
Range("B11").Value = sPath
Set fsObjekt = Application.FileSearch
With fsObjekt
ChDir sPath
.NewSearch
.LookIn = sPath ' "C:\Daten\" 'anpassen Suchort
.SearchSubFolders = True
Range("A1:A2000").ClearContents
Meldung = "Bitte Dateiendung festlegen. Erlaubte *SUFFIX*." & vbCrLf & vbCrLf & vbTab & _
"*.xls ---> Excel-Daten" & vbCrLf & vbTab & _
"*.doc ---> Word-Daten" & vbCrLf & vbTab & _
"*.pdf;mp3;txt ---> ANDERE "
Do
datErweiterung = Application.InputBox(Meldung, "mögliche DATEIENDUNGEN", "*.")
If datErweiterung = "" Or datErweiterung = "*." Then Exit Sub
Loop Until (datErweiterung = "*.xls" Or datErweiterung = "*.doc" Or datErweiterung = "*.pdf" Or datErweiterung = "*.mp3" Or datErweiterung = "*.txt")
.Filename = datErweiterung
If .Execute() > 0 Then
For index = 1 To .FoundFiles.Count
Merker = 0
For Pruef = 1 To index
If Cells(Pruef, 1) = .FoundFiles(index) Then
Merker = 1
Exit For
End If
Next
If Merker = 0 Then Cells(index, 1) = .FoundFiles(index)
Next index
End If
End With
letzteZeile = Range("A2000").End(xlUp).Row ' Bereich für Hypererstellung
Range("A1:A" & letzteZeile).Select 'Abgrenzung benutzte Zellen
For Each C In Selection
intPos = InStrRev(C.Value, "\")
strLink = Right(C.Value, Len(C) - intPos)
C.Hyperlinks.Add C, C.Value, TextToDisplay:=strLink
Next C
'Call sort
Application.ScreenUpdating = True
If Range("C8").Value <= 0 Then
MsgBox "NO FILES im Ordner"
End If
'ActiveWorkbook.Save
Range("b5").Select
Selection.Interior.ColorIndex = 4
Range("c8").Select
End Sub
alles in ein Modul, ich zähle auch noch Anzahl Datein im Original
gruss geri