Mit einem Makro als html Seite hochladen | Herbers Excel-Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo zusammen,
so vllt(ungetestet):

Code:
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub PutFTPFile()
Dim strReturn As String
Dim strUploadFile, strSheetName As String
Dim strRange As String, strTitle As String

'------------- Einstellungen START -----------------------
Const cstrFTPServer = "ftpsite.com" 'ftp-Server
Const cstrUser = "myUserName" 'Benutzername
Const cstrPassword = "myPassword" 'Passwort
Const cstrPath = "subfolder" 'ftp-Zielverzeichnis
'------------- Einstellungen ENDE -----------------------

strSheetName = "Tabelle1"

strRange = ThisWorkbook.Sheets(strSheetName).UsedRange.Address

strTitle = "" 'ThisWorkbook.Sheets(strSheetName).Range("A1").Text

strUploadFile = Environ("USERPROFILE") & "\tmp.html"

With ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strUploadFile, _
Sheet:=strSheetName, _
Source:=strRange, _
HtmlType:=xlHtmlStatic, _
Title:=strTitle)
.Publish (True)
End With

strReturn = FTPUpload(cstrFTPServer, cstrUser, cstrPassword, strUploadFile, cstrPath)

MsgBox strReturn

Kill Replace(strUploadFile, Chr(34), "")
End Sub
Private Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath) As String
Dim oFTPScriptFSO As Object, oFTPScriptShell As Object
Dim sFTPScript As String, sFTPTemp As String, sFTPTempFile As String
Dim sFTPResults As String, sResults As String
Dim fFTPScript As Variant, fFTPResults As Variant

'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com

Const OpenAsDefault = -2
Const FailIfNotExist = 0
Const ForReading = 1
Const ForWriting = 2

Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
Set oFTPScriptShell = CreateObject("WScript.Shell")

sRemotePath = Trim(sRemotePath)
sLocalFile = Trim(sLocalFile)

'----------Path Checks---------
'Here we willcheck the path, if it contains
'spaces then we need to add quotes to ensure
'it parses correctly.
If InStr(sRemotePath, " ") > 0 Then
If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
sRemotePath = """" & sRemotePath & """"
End If
End If

'Check the local path and file to ensure
'that either the a file that exists was
'passed or a wildcard was passed.
If InStr(sLocalFile, "*") Then
If InStr(sLocalFile, " ") Then
FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _
"space." & vbCrLf
FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client."
Exit Function
End If
ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
'nothing to upload
FTPUpload = "Error: File Not Found."
Exit Function
End If

If InStr(sLocalFile, " ") > 0 Then
If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
sLocalFile = """" & sLocalFile & """"
End If
End If

'Check to ensure that a remote path was
'passed. If it's blank then pass a "\"
If Len(sRemotePath) = 0 Then
'Please note that no premptive checking of the
'remote path is done. If it does not exist for some
'reason. Unexpected results may occur.
sRemotePath = "\"
End If

'--------END Path Checks---------

'build input file for ftp command
sFTPScript = sFTPScript & "USER " & sUsername & vbCrLf
sFTPScript = sFTPScript & sPassword & vbCrLf
sFTPScript = sFTPScript & "cd " & sRemotePath & vbCrLf
sFTPScript = sFTPScript & "binary" & vbCrLf
sFTPScript = sFTPScript & "prompt n" & vbCrLf
sFTPScript = sFTPScript & "put " & sLocalFile & vbCrLf
sFTPScript = sFTPScript & "quit" & vbCrLf & "quit" & vbCrLf & "quit" & vbCrLf

sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName

'Write the input file for the ftp command
'to a temporary file.
Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
fFTPScript.WriteLine (sFTPScript)
fFTPScript.Close
Set fFTPScript = Nothing

oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
" > " & sFTPResults, 0, True

Sleep 1000

'Check results of transfer.
Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
FailIfNotExist, OpenAsDefault)
sResults = fFTPResults.ReadAll
fFTPResults.Close

oFTPScriptFSO.DeleteFile (sFTPTempFile)
oFTPScriptFSO.DeleteFile (sFTPResults)

If InStr(sResults, "226 Transfer complete.") > 0 Then
FTPUpload = "Done"
ElseIf InStr(sResults, "File not found") > 0 Then
FTPUpload = "Error: File Not Found"
ElseIf InStr(sResults, "cannot log in.") > 0 Then
FTPUpload = "Error: Login Failed."
Else
FTPUpload = "Error: Unknown."
End If

Set oFTPScriptFSO = Nothing
Set oFTPScriptShell = Nothing
End Function

mfg Anton

Beliebteste Forumthreads (12 Monate)

Mit einem Makro als html Seite hochladen | Herbers Excel-Forum

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread