Anzeige
Archiv - Navigation
340to344
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
340to344
340to344
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Hyperlinks per VB zeilenweise erzeugen

Hyperlinks per VB zeilenweise erzeugen
21.11.2003 15:09:48
golem
Hi@all°
kann man alle Dateien eines Ordners als Hyperlinks zeilenweise erstellen?
z.B.:

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"D:\Gifs\castr22.jpg", TextToDisplay:= _
"D:\Gifs\castr22.jpg"

Einzeln geht das per MAcrorec(s.o). Was tun wenn der Ordner 100^100 Dateien enthält?

mfg
Golem

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Hyperlinks per VB zeilenweise erzeugen
21.11.2003 15:11:18
Michael Scheffler
Hi,

kombiniere den Dir-Befehl mit dem, was Du aufgezeichnet hast.

Gruß

Micha
AW: Hyperlinks per VB zeilenweise erzeugen
21.11.2003 15:20:16
andreas e
Hallo golem,
hier ein bsp. makro - Pfad anpassen !!!

Sub DateienAuflistenUndHyperlinken()
Dim i As Long
Dim Bereich As Range
Dim Zelle As Range
Const verz = "D:\ftpupload an 8834byp31168"
'ACHTUNG PFAD ANPASSEN !!!!
'oder über Inputbox kreieren lassen
ChDir verz
Range("A1").Select
With Application.FileSearch
.NewSearch
.LookIn = verz
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For i = 1 To .FoundFiles.Count
ActiveCell.Value = .FoundFiles(i)
ActiveCell.Offset(1, 0).Select
Next i
End With
Range("A1").Select
Set Bereich = ActiveCell.CurrentRegion
For Each Zelle In Bereich
Zelle.Hyperlinks.Add Zelle, Zelle.Value
Next Zelle
End Sub

Gruß
Andreas E

http://www.skripteundaufgaben.de
viele kostenlose Downloads und Links zu EXCEL und mehr
http://www.fachforen.de
eine Linksammlung zu diversen fachforen
Anzeige
Danke es klappt aber ...
21.11.2003 15:38:22
golem
..nur für XL Dateien:
FileType = msoFileTypeExcelWorkbooks
Geht das generell nur für Office Anwendungen/Dateien oder kann man es für beliebige DAteien verschiedener Formate erzeugen?

In der Exccel Hilfe war dafür keine Hilfe verfügbar(msoFileTypeExcelWorkbooks )
Wo finde ich eine Liste oder Inhaltsverzeichnis die einen/alle Dateitypen beinhaltet?

Danke für die bisherige Hilfe!
AW: Danke es klappt aber ...
21.11.2003 15:50:40
andreas e
hallo golem,
das weiss ich leider auch nicht,
aber ein makro von Bert Korn hilft dir da vielleicht weiter - das hyperlinken der gefundenen files dürfte ja nicht das problem sein:
'######################################################
'# #
'# Diese Makros stammen von Bert Körn #
'# E-Mail: bert@bert-koern.de #
'# Homepage: http://www.bert-koern.de #
'# #
'######################################################

' Muß erwähnt sein: Der API-Aufruf stammt nicht von mir.
' Die Quelle ist mir nicht mehr bekannt.

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

Sub Verzeichnisse_auflisten()
Dim Pfad1, Name1, Anzahl, X, X0, X1, X2, Verz, Anzverz, Größe
Dim TB1, TB2 As Worksheet
Dim msg As String
Set TB1 = ThisWorkbook.Worksheets(1)
Set TB2 = ThisWorkbook.Worksheets(2)
start = Now
TB1.[a:D] = ""
TB2.[a:D] = ""
'überflüssige Tabellenblätter löschen
If ThisWorkbook.Worksheets.Count > 2 Then
Application.DisplayAlerts = False
For X = 3 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(3).Delete
Next X
Application.DisplayAlerts = True
End If
' Pfad abfragen
msg = "Wählen Sie bitte einen Ordner aus:"
Pfad1 = getdirectory(msg)
If Pfad1 = "" Then Exit Sub
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
TB1.[a2] = Pfad1
Anzahl = 2
TB1.[a1] = "Pfad"
TB1.[b1] = "UnterVerz."
TB1.[c1] = "Anz. Dateien"
TB1.[d1] = "Datgröße in Verz."
X0 = 2
X1 = 2
Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row <> TB1.Cells(Rows.Count, 2).End(xlUp).Row
For X2 = X0 To X1
Pfad1 = TB1.Cells(X2, 1)  ' Pfad setzen.
If Right(Pfad1, 1) <> "\" Then Pfad1 = Pfad1 & "\"
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
Verz = 0
Do While Name1 <> "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 <> "." And Name1 <> ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein
' Verzeichnis ist.
If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then
Anzahl = Anzahl + 1
TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\"
Verz = Verz + 1
'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt.
End If
End If
Name1 = Dir ' Nächsten Eintrag abrufen.
Loop
TB1.Cells(X2, 2) = Verz
Next X2
X0 = X1 + 1
X1 = X2
Loop
'Dateien aus den Verzeichnissen auslesen
Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
ii = 0
For Verz = 2 To Anzverz
Anzahl = 0
Größe = 0
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(TB1.Cells(Verz, 1))
Set fc = f.Files
For Each f1 In fc
If i = 65536 Then
ii = ii + 1
ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ThisWorkbook.Worksheets(ii + 2).Name = "Dateien " & ii + 1
Set TB2 = ThisWorkbook.Worksheets(ii + 2)
i = 1
End If
i = i + 1
Anzahl = Anzahl + 1
TB2.Cells(i, 1) = f1.Name
TB2.Cells(i, 2) = f & "\" & f1.Name
'Hyperlink auf die Datei einfügen
TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _
f & "\" & f1.Name
TB2.Cells(i, 3) = FileLen(f1)
TB2.Cells(i, 4) = FileDateTime(f1)
Größe = Größe + FileLen(f1)
Next
TB1.Cells(Verz, 3) = Anzahl
TB1.Cells(Verz, 4) = Größe / 1024 / 1024
Next Verz
'MsgBox (ii * 65536) + i
ende = Now
MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _
"Anzahl der Dateien: " & (ii * 65536) + i & Chr(13) & _
Chr(13) & "Dauer: " & Format(ende - start, "nn:ss")
End Sub


' Muß erwähnt sein: Diese Funktion stammt nicht von mir.
' Die Quelle ist mir nicht mehr bekannt.


Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, X As Long, pos As Integer
'   Ausgangsordner = Desktop
bInfo.pidlRoot = 0&
'   Dialogtitel
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
'   Rückgabe des Unterverzeichnisses
bInfo.ulFlags = &H1
'   Dialog anzeigen
X = SHBrowseForFolder(bInfo)
'   Ergebnis gliedern
Path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function

Gruß
Andreas E

http://www.skripteundaufgaben.de
viele kostenlose Downloads und Links zu EXCEL und mehr
http://www.fachforen.de
eine Linksammlung zu diversen fachforen
Anzeige
Dir[(pathname[, attributes])]
21.11.2003 15:30:24
golem
Von was für einem Typ muß die Variable sein mit der alle Dateien durchlaufen werden ?
Object?
Für 100 Dateien:

Dim obj(100) As Variant, i%, j%
For j = 1 To 100
Cells(j, 1).Select
For i = 1 To 100
Selection.Hyperlinks(1).Address = "D:\Gifs\obj(i)"
Selection.Hyperlinks(1).TextToDisplay = "D:\Gifs\obj(i)"
Next
Next

Läuft nicht so ganz...

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige