Office: PDF-Dateien einlesen und Hyperlink erzeugen

kolacell · 18. August 2017

Moin,

kann mir jemand mit dem Beispielprojekt helfen?

https://wetransfer.com/downloads/431...0091509/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) · 19. August 2017

Moin,

Die blauen Code-Regel.

Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

amicro2000 · 20. August 2017

Hallo auch kola,

hier dein überarbeitete code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

fkw48 · 20. August 2017

http://www.vba-forum.de/Forum/View.a...nzeigen_lassen

kolacell · 20. August 2017

...ihr seid meine Helden!

Vielen Dank!!!

*grins

HS(V) · 20. August 2017

Versuche diesen Code statt ihrer.

Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: PDF-Dateien einlesen und Hyperlink erzeugen

PDF-Dateien einlesen und Hyperlink erzeugen

PDF-Dateien einlesen und Hyperlink erzeugen

PDF-Dateien einlesen und Hyperlink erzeugen

PDF-Dateien einlesen und Hyperlink erzeugen - Similar Threads - PDF Dateien einlesen

Datei als PDF speichern ohne festen Dateipfad

PDF-Dateinamen aus Zellen zusammensetzen

mehrere Hyperlink-Dateien in pdf drucken

PDF Datei in Zelle fixieren

Hintergrundbild: Keine Anzeige in pdf-Datei

Öffnen einer bestimmten Seite einer pdf-Datei

Kann Posteingang an meine Mails angehängte Office Dateien sowie Pdf und Fotos-Jpg nicht mehr öffnen