PDA

Vollständige Version anzeigen : PDF-Dateien einlesen und Hyperlink erzeugen


kolacell
20.08.2017, 10:19
Moin,

kann mir jemand mit dem Beispielprojekt helfen?

https://wetransfer.com/downloads/431ff782169442a8b1fa8431c197707d20170820091509/6fb4fcd2fd1eb57107a6ec44d62ce45120170820091509/e1ac3b

Die PDF-Dateien einlesen funktioniert bereits...nur leider nicht als Hyperlink, damit man die Datei bequem aus Excel heraus öffnen kann.

WICHTIG: Die Dateistruktur muss so erhalten bleiben (die PDF-Dateien befinden sich immer in einem Unterordner namens "neue_pdfs")

LG kola

HS(V)
20.08.2017, 10:54
Moin,

Die blauen Code-Regel.

Sub Dateisuche(Laufwerk As String, Dateien As String)
Dim tmp As String, Wdhlg As String, DateiName As String
On Error Resume Next
If Right(Laufwerk, 1) <> "" Then Laufwerk = Laufwerk + ""
tmp = Dir(Laufwerk & Dateien)
Do While Len(tmp)
DateiName = Laufwerk & tmp
Application.StatusBar = DateiName
DoEvents
Cells(z, 1) = tmp 'nur Dateiname
ActiveSheet.Hyperlinks.Add Cells(z, 1), DateiName

amicro2000
20.08.2017, 11:01
Hallo auch kola,

hier dein überarbeitete code:

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
'#############################
Private z As Long
'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
x = SHBrowseForFolder(bInfo)
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

Sub Dateisuche(Laufwerk As String, Dateien As String)
Dim tmp As String, Wdhlg As String, DateiName As String
On Error Resume Next
If Right(Laufwerk, 1) <> "" Then Laufwerk = Laufwerk + ""
tmp = Dir(Laufwerk & Dateien)
Do While Len(tmp)
DateiName = Laufwerk & tmp
Application.StatusBar = DateiName
DoEvents
Cells(z, 1) = tmp 'nur Dateiname
With ThisWorkbook.Sheets("Tabelle1")
.Hyperlinks.Add Anchor:=.Cells(z, 1), Address:=Laufwerk & tmp, ScreenTip:=Laufwerk & tmp, TextToDisplay:=tmp
End With
z = z + 1
tmp = Dir()
Loop
tmp = Dir(Laufwerk, vbDirectory)
Do While Len(tmp)
If (tmp <> ".") And (tmp <> "..") Then
If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche Laufwerk & tmp, Dateien
z = z - 1
Wdhlg = Dir(Laufwerk, vbDirectory)
z = z + 1
Do While Wdhlg <> tmp
Wdhlg = Dir()
Loop
End If
End If
DoEvents
tmp = Dir()
Loop
With ThisWorkbook.Sheets("Tabelle1")
With .Range("A:A")
.Font.Name = "Arial"
.Font.Size = 12
.Columns.AutoFit
End With
End With
On Error GoTo 0
Application.StatusBar = False
End Sub
'Aufruf mit dem folgenden Makro
Sub Suchen()
Dim Laufwerk$, Dateien$
'Ersze Zeile, in der eine Eintragung erfolgt
z = 2
'Alte Eintragungen löschen
With ThisWorkbook.Sheets("Tabelle1")
.Range("A:A").Delete Shift:=xlToLeft
.Range("A1").EntireColumn.Insert
End With
'Den Variablen Laufwerk und Dateien kann
'auch ein direkter Wert zugewiesen werden.
'Ersatz: ... = "C:Eigene Dateien"
Laufwerk = ThisWorkbook.path & "neue_pdfs"
'Laufwerk = "E:Eigene DateienEigene Bilder"
If Laufwerk = "" Then Exit Sub
'Ersatz: Dateien = "*.*"
'Dateien = InputBox("Nach welchen Dateien soll in" & _
Chr(10) & " " & Laufwerk & Chr(10) & _
"gesucht werden (z. B. *.xls)?", _
"Dateityp", "*.pdf")
Dateien = "*.pdf"
If Dateien = "" Then Exit Sub
Dateisuche Laufwerk, Dateien
DoEvents
End Sub

fkw48
20.08.2017, 11:49
http://www.vba-forum.de/Forum/View.aspx?ziel=39049-Wie_mit_VBA_Hyperlinks_anzeigen_lassen

kolacell
20.08.2017, 12:21
...ihr seid meine Helden!

Vielen Dank!!!

:grins:

HS(V)
20.08.2017, 12:31
Versuche diesen Code statt ihrer.

Sub hsv()
Dim fName As String, x As Long
fName = Dir(ThisWorkbook.Path & "\neue_pdfs\" & "*.pdf", vbDirectory)
While fName <> ""
x = x + 1
Cells(x, 1).Hyperlinks.Add Cells(x, 1), ThisWorkbook.Path & "\neue_pdfs\" & fName, , , fName
fName = Dir()
Wend
End Sub