AW: Prima! Danke für die Rückmeldung. owT
15.01.2018 13:32:17
Josi
Hallo Uwe,
wenn du sowieso gerade online bist:
Das mit dem einfügen der PDF hat ja super geklappt (habe davor noch den Ordner erstellt), im _
zweiten
Sub möchte ich gerne genau diese eigefügte Datei wieder Löschen, wie kann ich von dem einen _
Makro den Dateinamen (ZielDatei) in das Folgemakro übergeben?
Sub Blisterzeichnungeinfügen()
Dim TB, StartPfad As String, ZielPfad As String, Datei As String, ZielDatei As String
Dim Pfad2 As String, Ext As String, RNG As Range
Dim Dlg As FileDialog, Fso As Object
Dim Speicherordner As String
Speicherordner = "W:\Dokumente\Format\20_Störungen\40_Digitale Liste offener Punkte dLOP\ _
10_Blistermaschine\" & Range("D5").Value & "-" & Range("F18").Value
'Ordner erstellen
If Dir(Speicherordner, vbDirectory) = "" Then
MkDir (Speicherordner)
MsgBox "Ordner wurde angelegt!"
Else
MsgBox "Ordner ist vorhanden!"
End If
Set TB = ThisWorkbook.Sheets("SFB_BM")
StartPfad = "M:\Austauschverzeichnis\"
ZielPfad = "W:\Dokumente\Format\20_Störungen\40_Digitale Liste offener Punkte dLOP\ _
10_Blistermaschine\"
Pfad2 = TB.Range("D5").Value & "-" & TB.Range("F18") & "\"
Ext = "*.pdf"
Set RNG = TB.Range("B11") 'Zielzelle
Set Dlg = Application.FileDialog(msoFileDialogFilePicker) 'Datei wählen
With Dlg
.AllowMultiSelect = False
.InitialFileName = StartPfad & Ext
.InitialView = msoFileDialogViewDetails 'Anzeige des Dialogs - die Dateien als Detail
.Title = "Datei auswählen"
End With
If Dlg.Show = True Then
Datei = Dlg.SelectedItems(1)
ZielDatei = ZielPfad & Pfad2 & Dir(Datei)
'Kopieren
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.copyfile Datei, ZielDatei
' Hyperlink Makro
Range("B11").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
ZielDatei _
, TextToDisplay:="Blisterzeichnung"
End If
' BildEinfügenindirekteUrsacheausblenden BildändernIndirekteUrsacheeinblenden Makro
ActiveSheet.Shapes.Range(Array("Blisterzeichnung einfügen")).Visible = False
ActiveSheet.Shapes.Range(Array("Blisterzeichnung ändern")).Visible = True
End Sub
Sub Blisterzeichnungändern()
On Error Resume Next
Kill (ZielDatei)
Call Blisterzeichnungeinfügen
End Sub