über VBA Dateien auf einen SSH Server Laden
12.09.2024 19:45:38
Stefan
Ich habe etwas gesucht aber nicht wirklich etwas passendes gefunden.
Folgende Ausgangssituation:
im Tabellen Blatt "BMB" in der Zeile M9 wird eine Kundennummer/ Maschinennummer eingegeben.
wenn diese im Tabellen Blatt "Kundenliste" existiert, werden Firma, Adresse,... automatisch im Tabellen Blatt "BMB" über Sverweis ausgefüllt.
es gibt ein Makro welches das Tabellen Blatt "BMB" als .pdf Lokal in einem Ordner speichert.
dafür gibt es verschiedene Voraussetzungen oder Angaben.
auch kann es dann als E-Mail versendet werden.
Ich habe aber auch einen SSH Server
mit diesem verbinde ich mich aktuell nur über das öffnen von WinSCP und Synchronisiere alles oder einzeln Manuell.
nun meine Frage:
Ist es möglich das ich mit VBA eine Verbindung zum Server herstelle und die gleichen Voraussetzungen Programmieren kann ( auch da soll der passende Ordner auf dem Server gesucht werden und das "BMB" mit der gleicher Beschriftung gespeichert werden sowie wenn der Ordner nicht existiert dann soll er wie Lokal ein "Leeres Archiv" kopieren und umbenennen)
eine Alternative wehre vielleicht auch wenn ein neues Makro erstellt wird welches sich dann mit dem Server verbindet und die Ordner Lokal von "C:\Users\info\Desktop\XY\Archiv\" und den Ordner auf dem Server /yx/b/5/f/xy.yx/httpd.www/xy/Archiv Synchronisiert
der derzeitige Code in VBA:
Sub Speicher_BMB_als_PDF_im_Archiv()
Dim suchKriterium As String
Dim ordnerPfad As String
Dim FSO As Object
Dim pdfPfad As String
Dim dateiname As String
Dim leerArchivPfad As String
Dim neuerOrdnerPfad As String
Dim wsKundenliste As Worksheet
Dim wsBMB As Worksheet
Dim wsABL As Worksheet
Dim gefunden As Boolean
Dim Zelle As Range
Dim outlookApp As Object
Dim outlookMail As Object
' Arbeitsblätter zuweisen
Set wsBMB = ThisWorkbook.Sheets("BMB")
Set wsKundenliste = ThisWorkbook.Sheets("Kundenliste")
Set wsABL = ThisWorkbook.Sheets("ABL")
' Suchkriterium aus Zelle M9 BMB
suchKriterium = wsBMB.Range("M9").Value
ordnerPfad = "C:\Users\info\Desktop\XY\Archiv\"
leerArchivPfad = "C:\Users\info\Desktop\XY\Leeres Archiv"
' Überprüfen, ob der Eintrag in der Kundenliste existiert
gefunden = False
For Each Zelle In wsKundenliste.Range("A:A")
If Zelle.Value = suchKriterium Then
gefunden = True
Exit For
End If
Next Zelle
If Not gefunden Then
' Meldung hinzufügen, bevor zu ABL gewechselt wird
MsgBox "Die Maschinennummer '" & suchKriterium & "' wurde nicht in der Kundenliste gefunden. Sie werden jetzt zu ABL weitergeleitet.", vbExclamation
' Wenn nicht gefunden, wechsle zu ABL und setze den Fokus auf D9
wsABL.Activate
wsABL.Range("D9").Select
Exit Sub
End If
' FileSystemObject erstellen
Set FSO = CreateObject("Scripting.FileSystemObject")
' Überprüfen, ob der Ordner existiert
If FSO.FolderExists(ordnerPfad & suchKriterium) Then
MsgBox "Die Maschinennummer '" & suchKriterium & "' wurde im Archiv gefunden!", vbInformation
Else
MsgBox "Die Maschinennummer '" & suchKriterium & "' wurde nicht im Archiv gefunden.", vbExclamation
' Ordner "Leeres Archiv" kopieren und umbenennen
If FSO.FolderExists(leerArchivPfad) Then
neuerOrdnerPfad = ordnerPfad & suchKriterium
FSO.CopyFolder leerArchivPfad, neuerOrdnerPfad
MsgBox "Der Ordner 'Leeres Archiv' wurde kopiert und umbenannt zu '" & suchKriterium & "'.", vbInformation
Else
MsgBox "Der Ordner 'Leeres Archiv' existiert nicht.", vbExclamation
End If
End If
' Dateinamen für die PDF erstellen
dateiname = Format(Date, "yyyy-mm-dd") & ". " & _
wsBMB.Range("M9").Value & ". " & _
"BMB. " & _
wsBMB.Range("B8").Value & " " & _
wsBMB.Range("D10").Value & ".pdf"
' PDF-Pfad festlegen
pdfPfad = ordnerPfad & suchKriterium & "\Montageberichte\" & dateiname
' Tabellenblatt BMB als PDF speichern
wsBMB.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPfad, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
MsgBox "Das BMB wurde erfolgreich als PDF zur Maschinennummer im Archiv gespeichert: " & pdfPfad, vbInformation
' E-Mail senden
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
' Bestätigungsdialog vor dem Senden der E-Mail
Dim sendBestätigung As VbMsgBoxResult
sendBestätigung = MsgBox("Eine E-Mail mit dem BMB-Protokoll an Thomas senden?", vbYesNo + vbQuestion, "E-Mail senden")
If sendBestätigung = vbYes Then
With outlookMail
.To = "XXX.XXX@gmx.de"
.Subject = "Gespeicherte BMB PDF"
.Body = "Hallo Muster," & vbCrLf & vbCrLf & _
"Anbei das Protokoll BMB mit der Maschinennummer '" & suchKriterium & "'." & vbCrLf & _
"Das BMB-Protokoll zur Maschinennummer ist im Anhang." & vbCrLf & vbCrLf & _
"Gruß," & vbCrLf & _
"Stefan"
.Attachments.Add pdfPfad
.Send
End With
MsgBox "Die E-Mail wurde gesendet.", vbInformation
Else
MsgBox "Die E-Mail wurde nicht gesendet.", vbInformation
End If
' Objekte freigeben
Set FSO = Nothing
Set outlookMail = Nothing
Set outlookApp = Nothing
' Frage, ob WinSCP geöffnet werden soll
Dim openWinSCP As VbMsgBoxResult
openWinSCP = MsgBox("Möchten Sie WinSCP öffnen?", vbYesNo + vbQuestion, "WinSCP öffnen")
If openWinSCP = vbYes Then
Shell "C:\Program Files (x86)\WinSCP\WinSCP.exe", vbNormalFocus
End If
Vielen Dank für Eure Hilfe
Gruß
Stefan
Anzeige