'****************************************************************************
' 機能名 : Module1.vb
' 機能説明 : FTP(File Transfer Protocol)送受信
' 備考 :
' 著作権 : Copyright(C) 2008 のん All rights reserved
' ---------------------------------------------------------------------------
' 使用条件 : このサイトの内容を使用(流用/改変/転載/等全て)した成果物を不特定
' : 多数に公開/配布する場合は、このサイトを参考にした旨を記述してく
' : ださい。(例)WEBページやReadMeにリンクを貼ってください
' ---------------------------------------------------------------------------
'****************************************************************************
Imports System.Runtime.InteropServices
Module Module1
' 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 Structure FILETIME
Public dwLowDateTime As Integer
Public dwHighDateTime As Integer
End Structure
Private Structure WIN32_FIND_DATA
Public dwFileAttributes As Integer
Public ftCreationTime As FILETIME
Public ftLastAccessTime As FILETIME
Public ftLastWriteTime As FILETIME
Public nFileSizeHigh As Integer
Public nFileSizeLow As Integer
Public dwReserved0 As Integer
Public dwReserved1 As Integer
'Public cFileName As String * MAX_PATH
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=MAX_PATH)> _
Public cFileName As String
'Public cAlternate As String * 14
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=14)> _
Public cAlternate As String
End Structure
Private Structure SYSTEMTIME
Public wYear As Short
Public wMonth As Short
Public wDayOfWeek As Short
Public wDay As Short
Public wHour As Short
Public wMinute As Short
Public wSecond As Short
Public wMilliseconds As Short
End Structure
' API定義
Private Declare Function InternetOpen Lib "wininet.dll" Alias _
"InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Integer, _
ByVal sProxyName As String, ByVal sProxyBypass As String, _
ByVal lFlags As Integer) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias _
"InternetConnectA" (ByVal hInternetSession As Integer, _
ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUsername As String, ByVal sPassword As String, _
ByVal lService As Integer, ByVal lFlags As Integer, _
ByVal lContext As Integer) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Integer) As Integer
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Integer, _
ByVal lpszDirectory As String) As Integer
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias _
"FtpGetCurrentDirectoryA" (ByVal hFtpSession As Integer, _
ByVal lpszCurrentDirectory As String, _
ByRef lpdwCurrentDirectory As Integer) As Integer
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias _
"FtpCreateDirectoryA" (ByVal hFtpSession As Integer, _
ByVal lpszDirectory As String) As Integer
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias _
"FtpRemoveDirectoryA" (ByVal hFtpSession As Integer, _
ByVal lpszDirectory As String) As Integer
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias _
"FtpFindFirstFileA" (ByVal hFtpSession As Integer, _
ByVal lpszSearchFile As String, ByRef lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Integer, ByVal dwContent As Integer) As Integer
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias _
"InternetFindNextFileA" (ByVal hFind As Integer, _
ByRef lpvFindData As WIN32_FIND_DATA) As Integer
Private Declare Function FtpGetFile Lib "wininet.dll" Alias _
"FtpGetFileA" (ByVal hFtpSession As Integer, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, _
ByVal dwFlagsAndAttributes As Integer, ByVal dwFlags As Integer, _
ByVal dwContext As Integer) As Integer
Private Declare Function FtpPutFile Lib "wininet.dll" Alias _
"FtpPutFileA" (ByVal hFtpSession As Integer, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, ByVal dwFlags As Integer, _
ByVal dwContext As Integer) As Integer
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias _
"FtpRenameFileA" (ByVal hFtpSession As Integer, ByVal lpszExisting As String, _
ByVal lpszNew As String) As Integer
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias _
"FtpDeleteFileA" (ByVal hFtpSession As Integer, _
ByVal lpszFileName As String) As Integer
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias _
"InternetGetLastResponseInfoA" (ByRef lpdwError As Integer, _
ByVal lpszBuffer As String, ByRef lpdwBufferLength As Integer) As Integer
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" _
(ByRef lpFiletime As FILETIME, ByRef lpSystemTime As SYSTEMTIME) As Integer
Private Declare Function LoadLibraryEx Lib "kernel32.dll" Alias _
"LoadLibraryExA" (ByVal lpFileName As String, ByVal hFile As Integer, _
ByVal dwFlags As Integer) As Integer
Private Declare Function FreeLibrary Lib "kernel32.dll" _
(ByVal hModule As Integer) As Integer
Private Declare Function FormatMessage Lib "kernel32.dll" Alias _
"FormatMessageA" (ByVal dwFlags As Integer, ByVal lpSource As Integer, _
ByVal dwMessageId As Integer, ByVal dwLanguageId As Integer, _
ByVal lpBuffer As String, ByVal nSize As Integer, _
ByVal Arguments As Integer) As Integer
' その他定義
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 = New String(Chr(0), MAX_PATH)
lngRtn = FtpGetCurrentDirectory(lngInternetConnect, strDir, lngDir)
If lngRtn = 0 Then
SetErrAndRaise(Err.LastDllError)
Exit Function
End If
' カレントディレクトリ取得
FtpPwd = Left$(strDir, _
InStr(1, strDir, New String(Chr(0), 1), 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)
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 = New String(Chr(0), MAX_PATH)
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)) = typData.cFileName
If (typData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = _
FILE_ATTRIBUTE_DIRECTORY Then
strRtnVal(UBound(strRtnVal)) = strRtnVal(UBound(strRtnVal)) & "/"
End If
FtpLs = strRtnVal
' ２個目以降のファイル名取得要求送信
Do
typData.cFileName = New String(Chr(0), MAX_PATH)
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)) = typData.cFileName
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)
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 = New String(Chr(0), MAX_PATH)
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)) = typData.cFileName
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 = New String(Chr(0), MAX_PATH)
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)) = typData.cFileName
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(ByVal 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(ByVal 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 = New String(Chr(0), lngLength + 1)
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 Integer
Dim lngDll As Integer
Dim lngRtn As Integer
Dim strBuffer As String : strBuffer = New String(Chr(0), 1024)
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, 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
End Module
★テスト用フォームモジュール(Form1.vb)
Public Class Form1
' FormにButtonを12個貼り付けてお試しください。
Private Sub Button1_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button1.Click
On Error GoTo ErrHandler
' FTPサーバ接続
FtpConnectServer("localhost", "anonymous", "")
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button2_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button2.Click
On Error GoTo ErrHandler
' FTPサーバ切断
FtpDisconnectServer()
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button3_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button3.Click
On Error GoTo ErrHandler
' FTPサーバのディレクトリ変更
FtpCd("/ftp")
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button4_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button4.Click
On Error GoTo ErrHandler
' FTPサーバのカレントディレクトリ取得
Dim strPwd As String
strPwd = FtpPwd()
' デバッグ表示
System.Diagnostics.Debug.WriteLine(strPwd)
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button5_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button5.Click
On Error GoTo ErrHandler
' FTPサーバのディレクトリリスト取得
Dim strLs() As String
strLs = FtpLs()
' デバッグ表示
Dim i As Long
For i = 0 To UBound(strLs)
System.Diagnostics.Debug.WriteLine(strLs(i))
Next i
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button6_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button6.Click
On Error GoTo ErrHandler
' FTPサーバのディレクトリリスト取得
Dim strDir() As String
strDir = FtpDir()
' デバッグ表示
Dim i As Long
For i = 0 To UBound(strDir)
System.Diagnostics.Debug.WriteLine(strDir(i))
Next i
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button7_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button7.Click
On Error GoTo ErrHandler
' FTPサーバのディレクトリ作成
FtpMkdir("test")
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button8_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button8.Click
On Error GoTo ErrHandler
' FTPサーバのディレクトリ削除
FtpRmdir("test")
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button9_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button9.Click
On Error GoTo ErrHandler
' ファイルをFTPサーバから受信(ダウンロード)
FtpGet("c:\temp\a.txt", "a.txt")
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button10_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button10.Click
On Error GoTo ErrHandler
' ファイルをFTPサーバへ送信(アップロード)
FtpPut("c:\temp\b.txt", "b.txt")
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
Private Sub Button11_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button11.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 Button12_Click( _
ByVal sender As System.Object, ByVal e As System.EventArgs) _
Handles Button12.Click
On Error GoTo ErrHandler
' FTPサーバのファイル削除
FtpDelete("b.txt")
Exit Sub
ErrHandler:
MsgBox(Err.Description)
End Sub
End Class
★このサンプルの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.
