Option Explicit
'****************************************************************************
' 機能名 : modFtp.bas
' 機能説明 : FTP(File Transfer Protocol)送受信
' 備考 :
' 著作権 : Copyright(C) 2008 のん All rights reserved
' ---------------------------------------------------------------------------
' 使用条件 : このサイトの内容を使用(流用/改変/転載/等全て)した成果物を不特定
' : 多数に公開/配布する場合は、このサイトを参考にした旨を記述してく
' : ださい。(例)WEBページやReadMeにリンクを貼ってください
' ---------------------------------------------------------------------------
'****************************************************************************
' API用のConst定義
Private Const ERROR_NO_MORE_FILES = 18
Private Const ERROR_INTERNET_EXTENDED_ERROR = 12003
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const FILE_ATTRIBUTE_OFFLINE = &H1000
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_MULTIPART = &H200000
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_SERVICE_GOPHER = 2
Private Const INTERNET_SERVICE_HTTP = 3
Private Const LOAD_IGNORE_CODE_AUTHZ_LEVEL = &H10
Private Const LOAD_LIBRARY_AS_DATAFILE = &H2
Private Const LOAD_LIBRARY_AS_DATAFILE_EXCLUSIVE = &H40
Private Const LOAD_LIBRARY_AS_IMAGE_RESOURCE = &H20
Private Const LOAD_WITH_ALTERED_SEARCH_PATH = &H8
' API用のType定義
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 Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
' API定義
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 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 InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias _
"FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, _
ByRef lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias _
"FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias _
"FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
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 Declare Function FtpGetFile Lib "wininet.dll" Alias _
"FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, _
ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpPutFile Lib "wininet.dll" Alias _
"FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias _
"FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, _
ByVal lpszNew As String) As Long
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias _
"FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Long
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias _
"InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" _
(lpFiletime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function LoadLibraryEx Lib "kernel32.dll" Alias _
"LoadLibraryExA" (ByVal lpFileName As String, ByVal hFile As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hModule As Long) As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias _
"FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _
Arguments As Any) As Long
' その他定義
Private Const SourceFile = "modFtp" ' ソース名
Private lngInternetOpen As Long ' オープンハンドル
Private lngInternetConnect As Long ' コネクトハンドル
Private ErrNumber As Long ' エラー番号
Private ErrSource As String ' エラーソース
Private ErrDescription As String ' エラー説明
Private ErrHelpFile As String ' エラーヘルプファイル
Private ErrHelpContext As Long ' エラーヘルプコンテキスト
' 関数名 : FtpConnectServer
' 返り値 : 無し
' 引き数 : strServer : サーバ名またはIPアドレス
' : strUser : ユーザ名
' : strPswd : パスワード
' : strProxy : プロキシ名またはIPアドレス
' : blnPassive : パッシブFTP
' 機能説明 : FTPサーバ接続
' 備考 :
Public Sub FtpConnectServer(ByVal strServer As String, _
ByVal strUser As String, _
ByVal strPswd As String, _
Optional ByVal strProxy As String = "", _
Optional ByVal blnPassive As Boolean = False)
On Error GoTo ErrHandler
' インターネットオープン(FTPサーバ接続準備)
If strProxy <> "" Then
lngInternetOpen = InternetOpen("WININET", _
INTERNET_OPEN_TYPE_PROXY, strProxy, vbNullString, 0)
Else
lngInternetOpen = InternetOpen("WININET", _
INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
End If
If lngInternetOpen = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
' FTPサーバ接続
Dim lngPassive As Long: lngPassive = 0
If blnPassive Then lngPassive = INTERNET_FLAG_PASSIVE
lngInternetConnect = InternetConnect( _
lngInternetOpen, strServer, INTERNET_INVALID_PORT_NUMBER, _
strUser, strPswd, INTERNET_SERVICE_FTP, lngPassive, 0)
If lngInternetConnect = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
FtpDisconnectServer
ErrorRaise
End Sub
' 関数名 : FtpDisconnectServer
' 返り値 : 無し
' 引き数 : 無し
' 機能説明 : FTPサーバ切断
' 備考 :
Public Sub FtpDisconnectServer()
On Error Resume Next
' FTPサーバ切断
If lngInternetConnect <> 0 Then InternetCloseHandle (lngInternetConnect)
' インターネットクローズ
If lngInternetOpen <> 0 Then InternetCloseHandle (lngInternetOpen)
lngInternetConnect = 0
lngInternetOpen = 0
End Sub
' 関数名 : FtpCd
' 返り値 : 無し
' 引き数 : strDir : サーバのディレクトリPATH
' 機能説明 : FTPサーバのディレクトリ変更
' 備考 :
Public Sub FtpCd(ByVal strDir As String)
On Error GoTo ErrHandler
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Sub
End If
' CD要求送信
Dim lngRtn As Long
lngRtn = FtpSetCurrentDirectory(lngInternetConnect, strDir)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
ErrorRaise
End Sub
' 関数名 : FtpPwd
' 返り値 : カレントディレクトリ
' 引き数 : 無し
' 機能説明 : FTPサーバのカレントディレクトリ取得
' 備考 :
Public Function FtpPwd() As String
On Error GoTo ErrHandler
FtpPwd = ""
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Function
End If
' PWD要求送信
Dim lngRtn As Long
Dim strDir As String
Dim lngDir As Long
lngDir = MAX_PATH
strDir = String(MAX_PATH, 0)
lngRtn = FtpGetCurrentDirectory(lngInternetConnect, strDir, lngDir)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Function
End If
' カレントディレクトリ取得
FtpPwd = Left$(strDir, _
InStr(1, strDir, String(1, 0), vbBinaryCompare) - 1)
Exit Function
ErrHandler:
ErrorSave
ErrorRaise
End Function
' 関数名 : FtpMkdir
' 返り値 : 無し
' 引き数 : strDir : サーバのディレクトリPATH
' 機能説明 : FTPサーバのディレクトリ作成
' 備考 :
Public Sub FtpMkdir(ByVal strDir As String)
On Error GoTo ErrHandler
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Sub
End If
' MKDIR要求送信
Dim lngRtn As Long
lngRtn = FtpCreateDirectory(lngInternetConnect, strDir)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
ErrorRaise
End Sub
' 関数名 : FtpRmdir
' 返り値 : 無し
' 引き数 : strDir : サーバのディレクトリPATH
' 機能説明 : FTPサーバのディレクトリ削除
' 備考 :
Public Sub FtpRmdir(ByVal strDir As String)
On Error GoTo ErrHandler
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Sub
End If
' RMDIR要求送信
Dim lngRtn As Long
lngRtn = FtpRemoveDirectory(lngInternetConnect, strDir)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
ErrorRaise
End Sub
' 関数名 : FtpLs
' 返り値 : 無し
' 引き数 : 無し
' 機能説明 : FTPサーバのディレクトリリスト取得
' 備考 : ファイル名またはディレクト名
Public Function FtpLs() As String()
On Error GoTo ErrHandler
Dim strRtnVal() As String: ReDim strRtnVal(-1 To -1)
FtpLs = strRtnVal
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Function
End If
' 必要なローカル変数定義
Dim lngFirst As Long: lngFirst = 0
Dim typData As WIN32_FIND_DATA
Dim lngRtn As Long
' 最初のファイル名取得要求送信
typData.cFileName = String(MAX_PATH, 0)
lngFirst = FtpFindFirstFile(lngInternetConnect, "*.*", typData, _
INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD, 0)
If lngFirst = 0 Then
If Err.LastDllError <> ERROR_NO_MORE_FILES Then
SetErrAndRaise Err.LastDllError
End If
Exit Function
End If
' 最初のファイル名取得
ReDim strRtnVal(0)
strRtnVal(UBound(strRtnVal)) = Left$(typData.cFileName, _
InStr(1, typData.cFileName, String(1, 0), vbBinaryCompare) - 1)
If (typData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = _
FILE_ATTRIBUTE_DIRECTORY Then
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "/"
End If
FtpLs = strRtnVal
' ２個目以降のファイル名取得要求送信
Do
typData.cFileName = String(MAX_PATH, 0)
lngRtn = InternetFindNextFile(lngFirst, typData)
If lngRtn = 0 Then
If Err.LastDllError <> ERROR_NO_MORE_FILES Then
SetErrAndRaise Err.LastDllError
End If
Exit Do
End If
' ２個目以降のファイル名取得
ReDim Preserve strRtnVal(UBound(strRtnVal) + 1)
strRtnVal(UBound(strRtnVal)) = Left(typData.cFileName, _
InStr(1, typData.cFileName, String(1, 0), vbBinaryCompare) - 1)
If typData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "/"
End If
FtpLs = strRtnVal
Loop
' 最初のファイル名のハンドルクローズ
InternetCloseHandle lngFirst
Exit Function
ErrHandler:
ErrorSave
If lngFirst <> 0 Then InternetCloseHandle lngFirst
ErrorRaise
End Function
' 関数名 : FtpDir
' 返り値 : 無し
' 引き数 : 無し
' 機能説明 : FTPサーバのディレクトリリスト取得
' 備考 : ファイル名またはディレクト名、更新日時、サイズ
' : (注)ファイルサイズは2G以下しかサポートしていません
Public Function FtpDir() As String()
On Error GoTo ErrHandler
Dim strRtnVal() As String: ReDim strRtnVal(-1 To -1)
FtpDir = strRtnVal
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Function
End If
' 必要なローカル変数定義
Dim lngFirst As Long: lngFirst = 0
Dim typData As WIN32_FIND_DATA
Dim lngRtn As Long
' 最初のファイル名取得要求送信
typData.cFileName = String(MAX_PATH, 0)
lngFirst = FtpFindFirstFile(lngInternetConnect, "*.*", typData, _
INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD, 0)
If lngFirst = 0 Then
If Err.LastDllError <> ERROR_NO_MORE_FILES Then
SetErrAndRaise Err.LastDllError
End If
Exit Function
End If
' 最初のファイル名取得
ReDim strRtnVal(0)
strRtnVal(UBound(strRtnVal)) = Left$(typData.cFileName, _
InStr(1, typData.cFileName, String(1, 0), vbBinaryCompare) - 1)
If (typData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = _
FILE_ATTRIBUTE_DIRECTORY Then
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "/"
End If
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "," & _
GetStrDTime(typData.ftLastWriteTime) ' ファイルの更新日時
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "," & _
typData.nFileSizeLow ' ファイルのサイズ(2G以下)
FtpDir = strRtnVal
' ２個目以降のファイル名取得要求送信
Do
typData.cFileName = String(MAX_PATH, 0)
lngRtn = InternetFindNextFile(lngFirst, typData)
If lngRtn = 0 Then
If Err.LastDllError <> ERROR_NO_MORE_FILES Then
SetErrAndRaise Err.LastDllError
End If
Exit Do
End If
' ２個目以降のファイル名取得
ReDim Preserve strRtnVal(UBound(strRtnVal) + 1)
strRtnVal(UBound(strRtnVal)) = Left(typData.cFileName, _
InStr(1, typData.cFileName, String(1, 0), vbBinaryCompare) - 1)
If typData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "/"
End If
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "," & _
GetStrDTime(typData.ftLastWriteTime) ' ファイルの更新日時
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "," & _
typData.nFileSizeLow ' ファイルのサイズ(2G以下)
FtpDir = strRtnVal
Loop
' 最初のファイル名のハンドルクローズ
InternetCloseHandle lngFirst
Exit Function
ErrHandler:
ErrorSave
If lngFirst <> 0 Then InternetCloseHandle lngFirst
ErrorRaise
End Function
' 関数名 : FtpGet
' 返り値 : 無し
' 引き数 : strLocalPath : ローカルファイルのPATH
' : strRemotePath : リモートファイルのPATH
' : blnBinari : バイナリ(True)またはアスキー(False)
' 機能説明 : ファイルをFTPサーバから受信(ダウンロード)
' 備考 :
Public Sub FtpGet(ByVal strLocalPath As String, _
ByVal strRemotePath As String, _
Optional ByVal blnBinari As Boolean = True)
On Error GoTo ErrHandler
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Sub
End If
' バイナリまたはアスキーモードの設定
Dim lngtype As Long
lngtype = FTP_TRANSFER_TYPE_BINARY Or INTERNET_FLAG_RELOAD
If blnBinari = False Then
lngtype = FTP_TRANSFER_TYPE_ASCII Or INTERNET_FLAG_RELOAD
End If
' ファイルをFTPサーバから受信
Dim lngRtn As Long
lngRtn = FtpGetFile(lngInternetConnect, _
strRemotePath, strLocalPath, _
False, FILE_ATTRIBUTE_NORMAL, lngtype, 0)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
ErrorRaise
End Sub
' 関数名 : FtpPut
' 返り値 : 無し
' 引き数 : strLocalPath : ローカルファイルのPATH
' : strRemotePath : リモートファイルのPATH
' : blnBinari : バイナリ(True)またはアスキー(False)
' 機能説明 : ファイルをFTPサーバへ送信(アップロード)
' 備考 :
Public Sub FtpPut(ByVal strLocalPath As String, _
ByVal strRemotePath As String, _
Optional ByVal blnBinari As Boolean = True)
On Error GoTo ErrHandler
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Sub
End If
' バイナリまたはアスキーモードの設定
Dim lngtype As Long
lngtype = FTP_TRANSFER_TYPE_BINARY
If blnBinari = False Then
lngtype = FTP_TRANSFER_TYPE_ASCII
End If
' ファイルをFTPサーバへ送信
Dim lngRtn As Long
lngRtn = FtpPutFile(lngInternetConnect, _
strLocalPath, strRemotePath, lngtype, 0)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
ErrorRaise
End Sub
' 関数名 : FtpRename
' 返り値 : 無し
' 引き数 : strOld : サーバのファイルやディレクトリPATH(既存)
' : strNew : サーバのファイルやディレクトリPATH(新)
' 機能説明 : FTPサーバのファイルやディレクトリの名前変更
' 備考 :
Public Sub FtpRename(ByVal strOld As String, ByVal strNew As String)
On Error GoTo ErrHandler
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Sub
End If
' RENAME要求送信
Dim lngRtn As Long
lngRtn = FtpRenameFile(lngInternetConnect, strOld, strNew)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
ErrorRaise
End Sub
' 関数名 : FtpDelete
' 返り値 : 無し
' 引き数 : strOld : サーバのファイルPATH
' 機能説明 : FTPサーバのファイル削除
' 備考 :
Public Sub FtpDelete(ByVal strFile As String)
On Error GoTo ErrHandler
' FTPサーバ未接続の時はエラー
If lngInternetOpen = 0 Then
Err.Raise 9999, SourceFile, "It is not connected to the ftp server"
Exit Sub
End If
' DELETE要求送信
Dim lngRtn As Long
lngRtn = FtpDeleteFile(lngInternetConnect, strFile)
If lngRtn = 0 Then
SetErrAndRaise Err.LastDllError
Exit Sub
End If
Exit Sub
ErrHandler:
ErrorSave
ErrorRaise
End Sub
' 関数名 : GetStrDTime
' 返り値 : 無し
' 引き数 : ft : ファイルタイム
' 機能説明 : ファイルタイムをシステムタイム文字列変換
' 備考 :
Private Function GetStrDTime(typFileTime As FILETIME) As String
On Error Resume Next
Dim typSystemTime As SYSTEMTIME
Call FileTimeToSystemTime(typFileTime, typSystemTime)
GetStrDTime = Format(typSystemTime.wYear, "0000") & "/" & _
Format(typSystemTime.wMonth, "00") & "/" & _
Format(typSystemTime.wDay, "00") & " " & _
Format(typSystemTime.wHour, "00") & ":" & _
Format(typSystemTime.wMinute, "00") & ":" & _
Format(typSystemTime.wSecond, "00")
End Function
' 関数名 : SetErrAndRaise
' 返り値 : 無し
' 引き数 : lngDllError : Err.LastDllError
' 機能説明 : DLLエラーメッセージ取得＆エラー送信
' 備考 :
Private Sub SetErrAndRaise(lngDllError As Long)
On Error Resume Next
ErrNumber = lngDllError
ErrSource = SourceFile
ErrDescription = GetMessageFromDll(lngDllError, "WININET.DLL")
If lngDllError = ERROR_INTERNET_EXTENDED_ERROR Then
Dim lngError As Long
Dim lngLength As Long
Dim strMessage As String
InternetGetLastResponseInfo lngError, vbNullString, lngLength
strMessage = String(lngLength + 1, 0)
InternetGetLastResponseInfo lngError, strMessage, lngLength
ErrDescription = ErrDescription & vbCrLf & strMessage
ElseIf lngDllError = ERROR_NO_MORE_FILES Then
ErrDescription = ErrDescription & vbCrLf & "ERROR_NO_MORE_FILES"
End If
If ErrNumber = 0 Then ErrNumber = 9999
On Error GoTo 0
ErrorRaise
End Sub
' 関数名 : GetMessageFromDll
' 返り値 : DLLエラーメッセージ
' 引き数 : lngDllError : Err.LastDllError
' 機能説明 : DLLエラーメッセージ取得
' 備考 :
Private Function GetMessageFromDll(ByVal lngDllError As Long, _
ByVal strDllName As String) As String
On Error Resume Next
GetMessageFromDll = ""
Dim lngFlags As Long
Dim lngDll As Long
Dim lngRtn As Long
Dim strBuffer As String: strBuffer = String(1024, vbNullChar)
lngFlags = FORMAT_MESSAGE_IGNORE_INSERTS Or _
FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_MAX_WIDTH_MASK
lngDll = LoadLibraryEx(strDllName, 0&, LOAD_LIBRARY_AS_DATAFILE)
If (lngDll <> 0) Then _
lngFlags = lngFlags Or FORMAT_MESSAGE_FROM_HMODULE
lngRtn = FormatMessage( _
lngFlags, ByVal lngDll, lngDllError, 0&, strBuffer, Len(strBuffer), 0&)
If (lngDll <> 0) Then FreeLibrary lngDll
If (lngRtn > 0) Then
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Else
strBuffer = ""
End If
GetMessageFromDll = strBuffer
End Function
' 関数名 : ErrorSave
' 返り値 : 無し
' 引き数 : 無し
' 機能説明 : エラー保存
' 備考 :
Private Sub ErrorSave()
ErrNumber = Err.Number
ErrSource = Err.Source
ErrDescription = Err.Description
ErrHelpFile = Err.HelpFile
ErrHelpContext = Err.HelpContext
End Sub
' 関数名 : ErrorRaise
' 返り値 : 無し
' 引き数 : 無し
' 機能説明 : エラー送信
' 備考 :
Private Sub ErrorRaise()
Err.Raise ErrNumber, ErrSource, ErrDescription, ErrHelpFile, ErrHelpContext
End Sub
★テスト用フォームモジュール(Form1.frm)
Option Explicit
Private Sub Command1_Click()
On Error GoTo ErrHandler
' FTPサーバ接続
FtpConnectServer "localhost", "anonymous", ""
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command2_Click()
On Error GoTo ErrHandler
' FTPサーバ切断
FtpDisconnectServer
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command3_Click()
On Error GoTo ErrHandler
' FTPサーバのディレクトリ変更
FtpCd "/ftp"
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command4_Click()
On Error GoTo ErrHandler
' FTPサーバのカレントディレクトリ取得
Dim strPwd As String
strPwd = FtpPwd()
' デバッグ表示
Debug.Print strPwd
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command5_Click()
On Error GoTo ErrHandler
' FTPサーバのディレクトリリスト取得
Dim strLs() As String
strLs = FtpLs()
' デバッグ表示
Dim i As Long
For i = 0 To UBound(strLs)
Debug.Print strLs(i)
Next i
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command6_Click()
On Error GoTo ErrHandler
' FTPサーバのディレクトリリスト取得
Dim strDir() As String
strDir = FtpDir()
' デバッグ表示
Dim i As Long
For i = 0 To UBound(strDir)
Debug.Print strDir(i)
Next i
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command7_Click()
On Error GoTo ErrHandler
' FTPサーバのディレクトリ作成
FtpMkdir "test"
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command8_Click()
On Error GoTo ErrHandler
' FTPサーバのディレクトリ削除
FtpRmdir "test"
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command9_Click()
On Error GoTo ErrHandler
' ファイルをFTPサーバから受信(ダウンロード)
FtpGet "c:\temp\a.txt", "a.txt"
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command10_Click()
On Error GoTo ErrHandler
' ファイルをFTPサーバへ送信(アップロード)
FtpPut "c:\temp\b.txt", "b.txt"
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command11_Click()
On Error GoTo ErrHandler
' FTPサーバのファイルやディレクトリの名前変更
'FtpRename "test", "test2"
'FtpRename "test2", "test"
FtpRename "b.txt", "z.txt"
FtpRename "z.txt", "b.txt"
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Private Sub Command12_Click()
On Error GoTo ErrHandler
' FTPサーバのファイル削除
FtpDelete "b.txt"
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
★このサンプルのFTP送受信コマンド(パケット)の流れ
(送)：クライアントからFTPサーバへの送信パケット(電文)
(受)：FTPサーバからクライアントへの受信パケット(電文)
01.FtpConnectServerの送受信パケット
(送)TCP/IP接続(SERVER PORT=21へ)
(受)220 XXXXXXX Microsoft FTP Service (Version 5.0).
(送)USER anonymous
(受)331 Anonymous access allowed, send identity (e-mail name) as password.
(送)PASS
(受)230 Anonymous user logged in.
02.FtpDisconnectServerの送受信パケット
(送)TCP/IP切断(SERVER PORT=21へ)
03.FtpCdの送受信パケット
(送)CWD /ftp
(受)250 CWD command successful.
04.FtpPwdの送受信パケット
(送)PWD
(受)257 "/ftp" is current directory.
05.FtpLsの送受信パケット
06.FtpDirの送受信パケット
(送)TYPE A
(受)200 Typeset to A.
(送)PORT XXX,XXX,XX,X,6,18
(受)200 PORT command successful.
(送)LIST
(受)150 Opening ASCII mode data connection fr /bin/ls.
(受)TCP/IP接続(SERVER PORT=20から)
(受)09-08-08 01:12PM 48 a.txt
(受)TCP/IP切断(SERVER PORT=20から)
(受)226 Transfer complete.
07.FtpMkdirの送受信パケット
(送)MKD test
(受)257 "test" directory created.
08.FtpRmdirの送受信パケット
(送)RMD test
(受)250 RMD command successful.
09.FtpGetの送受信パケット
(送)TYPE I
(受)200 Type set to I.
(送)PORT XXX,XXX,XX,X,6,19
(受)200 PORT command successful.
(送)SIZE a.txt
(受)213 48
(送)RETR a.txt
(受)150 Opening BINARY mode data connection for a.txt(48 bytes).
(受)TCP/IP接続(SERVER PORT=20から)
(受)ああああああああああああああああああああああああ
(受)TCP/IP切断(SERVER PORT=20から)
(受)226 Transfer complete.
10.FtpPutの送受信パケット
(送)TYPE I
(受)200 Type set to I.
(送)PORT XXX,XXX,XX,X,6,21
(受)200 PORT command successful.
(送)STOR b.txt
(受)150 Opening BINARY mode data connection for b.txt.
(受)TCP/IP接続(SERVER PORT=20から)
(送)ＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢＢ
(受)TCP/IP切断(SERVER PORT=20から)
(受)226 Transfer complete.
11.FtpRenameの送受信パケット
(送)RNFR b.txt
(受)350 File exists, ready for destination name
(送)RNTO z.txt
(受)250 RNTO command successful.
12.FtpDeleteの送受信パケット
(送)DELE b.txt
(受)250 DELE command successful.
