Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1080to1084
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

xls/pdf aus Intranet downloaden (mit Makro)

xls/pdf aus Intranet downloaden (mit Makro)
14.06.2009 14:50:14
Florian
Hallo Excel-Freunde!
Eine Frage, bei der Ihr mir evt. weiterhelfen könnt:
Täglich müssen bei uns verschiedene Dateien aus dem Intranet downgeloadet werden (xls und pdf). Könnte man das auch per Makro automatisieren? Es müsste dabei natürlich auch Username und Passwort eingegeben werden. Habt Ihr eine Ahnung ob das geht, wenn ja wie?
Danke Euch schon mal für die Hilfe!
Schöner Gruss Florian

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: xls/pdf aus Intranet downloaden (mit Makro)
14.06.2009 20:23:44
edie
Hallo Florian,
habe das Problem zum Beispiel per FTP so gelöst, Code aus dem Archiv, und etwas angepasst.
Option Explicit

Function FTP_Down()
Dim FTP As New clsFTP, asFiles() As String, vThisFile As Variant
Dim sDir As String
Dim Pfad As String
sDir = "/"
sDir = WorksheetFunction.Substitute(sDir, "\", "/")
FTP.LoginName = "Name"
FTP.Password = "Passwort"
FTP.ServerName = "100.168.1.2"
If FTP.Connect Then
FTP.CurDir = sDir
FTP.DownloadFile "Mappe.xls", _
ThisWorkbook.Path & "\" & _
"Mappe.xls"
FTP.Disconnect
MsgBox "Die Daten wurden vom Server geladen!", vbInformation, "Information"
Else
MsgBox "Es kann keine Server-Verbindung hergestellt werden - " & Chr(13) & _
"überprüfen Sie bitte, ob eine Internet-Verbindung besteht.", vbInformation, "Information"
End If
End Function


PS: Es gibt jede Mene Beispiele im Archiv.
Grüße

Anzeige
Nachtrag
14.06.2009 20:26:17
edie
Nachtrag,
den Nachfolgenden Code in ein Klassenmodul kopieren:
'FTP Class by Andrew Baker
Option Explicit
Private Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
'Default for FTP servers
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_SERVICE_FTP = 1
'Use FTP connections
Private Const INTERNET_FLAG_PASSIVE = &H8000000
'Use registry configuration
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
'Direct to net
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
'Via a named proxy
Private Const INTERNET_OPEN_TYPE_PROXY = 3
'Prevent using java/script/INS
Private Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As Long _
) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" _
Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUserName As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long _
) As Long
Private Declare Function InternetOpen Lib "wininet.dll" _
Alias "InternetOpenA" ( _
ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long _
) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszDirectory As String _
) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias _
"FtpGetCurrentDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszCurrentDirectory As String, _
lpdwCurrentDirectory As Long _
) As Long
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias _
"FtpCreateDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszDirectory As String _
) As Boolean
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias _
"FtpRemoveDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszDirectory As String _
) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias _
"FtpDeleteFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszFileName As String _
) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias _
"FtpRenameFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszExisting As String, _
ByVal lpszNew As String _
) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias _
"FtpGetFileA" ( _
ByVal hConnect As Long, _
ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, _
ByVal fFailIfExists As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, _
ByRef dwContext As Long _
) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias _
"FtpPutFileA" ( _
ByVal hConnect As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long _
) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias _
"InternetGetLastResponseInfoA" ( _
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long _
) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias _
"FtpFindFirstFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Long, _
ByVal dwContent As Long _
) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias _
"InternetFindNextFileA" ( _
ByVal hFind As Long, _
lpvFindData As WIN32_FIND_DATA _
) As Long
Private zsAgent As String, zsServerName As String, zsLoginName As String, zsPassword As String
Private zsCurDir As String, zbPassiveConnection As Boolean
Private zlhwndConnection As Long, zlhOpen As Long
'--------Agent
Property Get Agent() As String
Agent = zsAgent
End Property
Property Let Agent(Value As String)
zsAgent = Value
End Property
'--------Server Name
Property Get ServerName() As String
ServerName = zsServerName
End Property
Property Let ServerName(Value As String)
zsServerName = Value
End Property
'--------Login Name
Property Get LoginName() As String
LoginName = zsLoginName
End Property
Property Let LoginName(Value As String)
zsLoginName = Value
End Property
'--------Login Password
Property Get Password() As String
Password = zsPassword
End Property
Property Let Password(Value As String)
zsPassword = Value
End Property
Property Get CurDir() As String
Dim sCurPath As String * MAX_PATH, lRetVal As Long
'Get the current directory
On Error Resume Next
lRetVal = FtpGetCurrentDirectory(zlhwndConnection, sCurPath, MAX_PATH)
CurDir = Left$(sCurPath, InStr(1, sCurPath, vbNullChar) - 1)
If Right$(CurDir, 1) "/" Then
CurDir = CurDir & "/"
End If
End Property
Property Let CurDir(Value As String)
zsCurDir = Value
'Change the current directory
Call FtpSetCurrentDirectory(zlhwndConnection, Value)
End Property
Function DelDir(sDirectory As String) As Boolean
'Remove a directory in the current directory
DelDir = FtpRemoveDirectory(zlhwndConnection, sDirectory)
End Function


Function MakeDir(sPath As String) As Boolean
'Create a new directory in the current directory
MakeDir = FtpCreateDirectory(zlhwndConnection, sPath)
End Function


Function UploadFile(sSourceFile As String) As Boolean
'Upload a file to current directory
UploadFile = FtpPutFile( _
zlhwndConnection, _
sSourceFile, _
PathFileToFile(sSourceFile), _
FTP_TRANSFER_TYPE_UNKNOWN, _
0)
End Function


Function RenameFile(sSourceFile As String, sNewName As String) As Boolean
'Rename a file in current directory
RenameFile = FtpRenameFile(zlhwndConnection, sSourceFile, sNewName)
End Function


Function Connect() As Boolean
'Return a handle/Open an internet connection
zlhOpen = InternetOpen( _
zsAgent, _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, _
vbNullString, _
0)
'Connect to the FTP server
If zbPassiveConnection Then
zlhwndConnection = InternetConnect( _
zlhOpen, _
zsServerName, _
INTERNET_DEFAULT_FTP_PORT, _
zsLoginName, _
zsPassword, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, _
0)
Else
zlhwndConnection = InternetConnect( _
zlhOpen, zsServerName, _
INTERNET_DEFAULT_FTP_PORT, _
zsLoginName, _
zsPassword, _
INTERNET_SERVICE_FTP, _
0, _
0)
End If
If zlhwndConnection Then
Connect = True
Else
Connect = False
End If
End Function


Sub Disconnect()
'Close FTP connection
InternetCloseHandle zlhwndConnection
zlhwndConnection = 0
'Close Internet connection
InternetCloseHandle zlhOpen
zlhOpen = 0
End Sub


Property Get FTPHwnd() As Long
FTPHwnd = zlhwndConnection
End Property
Property Get InternetHwnd() As Long
InternetHwnd = zlhOpen
End Property
Sub GetMatchingFiles( _
ByRef asMatching() As String, _
Optional sFilter = "*.*", _
Optional bReturnDirectories As Boolean = False)
Dim pData As WIN32_FIND_DATA, lhwndFind As Long, lRet As Long, lMatching As Long
Dim sThisFile As String
Const FILE_ATTRIBUTE_READONLY = &H1, _
FILE_ATTRIBUTE_HIDDEN = &H2, _
FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_DIRECTORY = &H10, _
FILE_ATTRIBUTE_ARCHIVE = &H20, _
FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_TEMPORARY = &H100, _
FILE_ATTRIBUTE_COMPRESSED = &H800, _
FILE_ATTRIBUTE_OFFLINE = &H1000
'Create a buffer
pData.cFileName = String(MAX_PATH, 0)
lRet = 1
'Erase asMatching
'Find the first file
lhwndFind = FtpFindFirstFile(zlhwndConnection, sFilter, pData, 0, 0)
If lhwndFind Then
Do
If lRet > 0 And CBool(pData.dwFileAttributes And _
FILE_ATTRIBUTE_DIRECTORY) = bReturnDirectories Then
sThisFile = Left$(pData.cFileName, _
InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
'Store the the filename
lMatching = lMatching + 1
If lMatching = 1 Then
Erase asMatching
ReDim asMatching(1 To lMatching)
Else
ReDim Preserve asMatching(1 To lMatching)
End If
asMatching(lMatching) = Left$(pData.cFileName, _
InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
ElseIf lRet = 0 Then
'No more matching files
Exit Do
End If
'Find the next file
lRet = InternetFindNextFile(lhwndFind, pData)
Loop
End If
'Close the search
Call InternetCloseHandle(lhwndFind)
End Sub


Function DownloadFile(sGetFileName As String, sSaveToPath As String) As Boolean
'Retrieve the file
DownloadFile = FtpGetFile( _
zlhwndConnection, _
sGetFileName, _
sSaveToPath, False, _
0, _
FTP_TRANSFER_TYPE_UNKNOWN, _
0)
End Function


Function DeleteFile(sFileName As String) As Boolean
'Delete the file from server
DeleteFile = FtpDeleteFile(zlhwndConnection, sFileName)
End Function


Function GetLastError(Optional ByRef lErrNumber As Long) As String
Dim lErr As Long, sErr As String, lenBuf As Long
'Get the size of the required buffer
Call InternetGetLastResponseInfo(lErr, sErr, lenBuf)
'Create a buffer
sErr = String(lenBuf, 0)
Call InternetGetLastResponseInfo(lErr, sErr, lenBuf)
'Return the last response error
GetLastError = sErr
lErrNumber = lErr
End Function



Private Function PathFileToPath(sFilePathName As String) As String
Dim ThisChar As Long
PathFileToPath = sFilePathName 'Default return value
For ThisChar = 0 To Len(sFilePathName) - 1
If Mid$(sFilePathName, Len(sFilePathName) - ThisChar, 1) = "\" Then
PathFileToPath = Left$(sFilePathName, Len(sFilePathName) - ThisChar)
Exit For
End If
Next
End Function



Private Function PathFileToFile(sFilePathName As String) As String
Dim ThisChar As Long
PathFileToFile = sFilePathName 'Default return value
For ThisChar = 0 To Len(sFilePathName) - 1
If Mid$(sFilePathName, Len(sFilePathName) - ThisChar, 1) = "\" Then
PathFileToFile = Right$(sFilePathName, ThisChar)
Exit For
End If
Next
End Function



Private Sub Class_Initialize()
zsAgent = "FTP Client"
zbPassiveConnection = True
End Sub


Property Get PassiveConnection() As Boolean
PassiveConnection = zbPassiveConnection
End Property
Property Let PassiveConnection(Value As Boolean)
zbPassiveConnection = Value
End Property

Anzeige
AW: Nachtrag
14.06.2009 22:24:15
Florian
Hei Edie!
Viele Dank, ich werds morgen ausprobieren!
Gruß,
Florian

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige