AW: Hyperlink ueber makro
11.09.2003 09:59:49
geri
Hallo Darwin
ich habe es diese Woche so gelöst
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
'Application.ScreenUpdating = False
sPath = FunktionGetDirectory
'If FunktionGetDirectory = "" Then Exit Sub
Application.CutCopyMode = False 'Zwischenspeicher löschen
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
Application.ScreenUpdating = False
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("c8").Select
End Sub
Sub sort()
Dim letzteZeile As String
Range("c8").Select
Application.ScreenUpdating = False
If [C8].Value >= 1 Then 'wenn zellinhalt >
letzteZeile = Range("A2000").End(xlUp).Row ' Bereich für Hypererstellung
Range("A1:A" & letzteZeile).Select 'Abgrenzung benutzte Zellen
Selection.sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Selection.Columns.AutoFit
End If
Application.ScreenUpdating = True
Range("c8").Select
End Sub
Sub del_hyper()
Cells.Hyperlinks.Delete
End Sub
kopiere dies als test in ein Modul und starte habe es auf 2000 beschränkt evtl anpassen
gruss geri