Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Tworzenie pdf-a i wysyłaka na serwer ftp

partner2001 · Exceloholic Wersja: Win Office 365 Posty: 248

Witam.
Mam procedurę która tworzy plik pdf-a z dwóch arkuszy excela i nastepnie powinna go wysłać na serwer ftp. Coś pochrzaniłem i plik się tworzy ale nie wysyła się na serwer ftp.
Co zrobiłem nie tak?

Kod:

Sub Publikuj_do_PDF()
Dim shActv As Object
Dim strFName As String
Dim strFullPath As String
'zapamiętaj aktywny arkusz
Set shActv = ActiveSheet

'pobierz nazwę pliku
'dalej założono, że nazwa nie zawiera niedozwolonych znaków
strFName = Sheets("info").Range("A1").Value

If Len(Trim(strFName)) = 0 Then
MsgBox "Brak nazwy pliku.", vbExclamation, " Publikuj PDF"
Exit Sub
End If

'jl. brak rozszerzenia w nazwie, to go dodaj
If LCase(Right(strFName, 4)) <> ".pdf" Then
strFName = strFName & ".pdf"
End If

'ścieżka do folderu w którym znajduje się skoroszyt
' strFullPath = ThisWorkbook.Path & "\" & strFName
strFullPath = ThisWorkbook.Path & "\Wydruki"
If Dir(strFullPath, vbDirectory) = "" Then MkDir strFullPath
strFullPath = strFullPath & "\" & strFName

Application.ScreenUpdating = False

'jl. skoroszyt zawiera więcej arkuszy niż wymienione poniżej
'a zależy nam na publikacji tylko wymienionych
Sheets(Array("lista_TG", "TG8")).Select
Sheets("TG8").Activate

'jl. chcemy opublikować cały skoroszyt
'wtenczas dwie poprzednie linie są zbędne,
'a w poniższej należy zamienić ActiveSheet na ActiveWorkbook (lub ThisWorkbook)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'lub True,
'gdy chcesz pokazywać po publikacji

' Wysyłka pliku na serwer ftp
PublishFile strFullPath

End If

'zaznaczenie arkusza, który był aktywny przed uruchomieniem makra
shActv.Select

End Sub

Sub PublishFile(fileToSend As String)

Dim sServer As String, sLogin As String, sPassword As String, sPath As String
Dim strDirectoryList As String
Dim lStr_Dir As String
Dim lInt_FreeFile01 As Integer
Dim lInt_FreeFile02 As Integer
Dim strFName As String

' On Error GoTo Err_Handler

'************** Ustawienia **********
sServer = "94.152.11.148" 'adres serwera
sLogin = "danezpzts" 'login
sPassword = "mojehasło" 'hasło
sPath = "public_html/danezpzts.pl/" 'katalog na serwerze - jeżeli nie główny
'********** Koniec ustawień *********

'jako miejsce tworzenia plików roboczych ustawiamy katalog systemowy Temp
lStr_Dir = Environ("Temp")

lInt_FreeFile01 = FreeFile
lInt_FreeFile02 = FreeFile

strDirectoryList = lStr_Dir & "\Plik_Temp"

'' Usunięcie pliku z zakończeniem transakcji - w zasadzie nie powinno go być
If Dir(strDirectoryList & ".out") <> "" Then Kill (strDirectoryList & ".out")

'' Utworzenie pliku txt z komendami FTP
Open strDirectoryList & ".txt" For Output As #lInt_FreeFile01
Print #lInt_FreeFile01, "open " & sServer
Print #lInt_FreeFile01, sLogin
Print #lInt_FreeFile01, sPassword
Print #lInt_FreeFile01, "cd /" & sPath
Print #lInt_FreeFile01, "binary"
Print #lInt_FreeFile01, "send """ & fileToSend & """"
Print #lInt_FreeFile01, "bye"
Close #lInt_FreeFile01

'' Utworzenie pliku bat
Open strDirectoryList & ".bat" For Output As #lInt_FreeFile02
Print #lInt_FreeFile02, "ftp -s:""" & strDirectoryList & ".txt"""

Print #lInt_FreeFile02, "Echo ""Complete"" > """ & strDirectoryList & ".out"""
Close #lInt_FreeFile02

'' uruchomienie pliku bat
Shell """" & strDirectoryList & ".bat""", vbHide
'Czekamy na ukończenie przesyłu
Do While Dir(strDirectoryList & ".out") = ""
DoEvents
Loop

Application.Wait (Now + TimeValue("0:00:03"))

' Czyszczenie plików tymczasowych
If Dir(strDirectoryList & ".bat") <> "" Then Kill (strDirectoryList & ".bat")
If Dir(strDirectoryList & ".out") <> "" Then Kill (strDirectoryList & ".out")
If Dir(strDirectoryList & ".txt") <> "" Then Kill (strDirectoryList & ".txt")
' If Dir(lStr_Dir & "\" & sNazwaStrony) <> "" Then Kill (lStr_Dir & "\" & sNazwaStrony)

MsgBox "Jeśli masz połączenie z internetem i nie ma awarii na serwerze ZPZTS – diagram został wysłany na serwer ZPZTS"
bye:

Exit Sub