こちらの記事では ACCESS VBAでのFTP接続に関する処理サンプルを掲載しています。
Windows APIのwininet.dllを利用する事で、FTPでのファイルアップロードやダウンロード等が一通り行えます。サンプルには呼び出す側のソースはありませんので別途作成が必要です。
以下に掲載するサンプルソースは標準モジュールに書き込んで、フォームの各処理から呼び出して利用します。
主な処理は下記の目次の通りになります。
必須）WindowsAPI、グローバル変数、定数の宣言
いずれの処理を使う場合もこの部分の記載は必須です。
FTP_HOST,FTP_USER,FTP_DIRは環境に合わせて修正が必要です。
32bitバージョンAccessの場合はPrivate Declare PtrSafe の部分から PtrSafe を削除します。
Option Compare Database
Option Explicit
Private Declare PtrSafe Function InternetOpen _
Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, _
ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function InternetConnect Lib _
"wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal lpszServerName As String, _
ByVal nServerPort As Integer, ByVal lpszUsername As String, _
ByVal lpszPassword As String, ByVal dwService As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare PtrSafe Function FtpSetCurrentDirectory _
Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Private Declare PtrSafe Function FtpPutFile _
Lib "wininet.dll" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByRef lpszLocalFile As Byte, _
ByRef lpszNewRemoteFile As Byte, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare PtrSafe Function FtpGetFile _
Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Long, _
ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare PtrSafe Function FtpDeleteFile _
Lib "wininet.dll" Alias "FtpDeleteFileA" _
(ByVal hConnect As Long, ByVal lpszFileName As String) As Long
Private Declare PtrSafe Function InternetCloseHandle _
Lib "wininet.dll" _
(ByVal hInet As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal lngFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_SERVICE_FTP = 1&
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
'以下３つの定数は環境に応じて設定してください。
Private Const FTP_HOST As String = "*****.ne.jp" 'FTPホスト
Private Const FTP_USER As String = "*****" 'FTPアカウント
Private Const FTP_DIR As String = "/ftp/dir" 'FTPサーバ上の参照先ディレクトリパス
Private Const MAX_PATH As Long = 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
cAlternateFileName As String * 14
End Type
Public AryFile() As String 'ファイル名一覧
FTPでファイル一覧を取得
FTPサーバー上のファイル一覧を取得する処理です。
取得結果はグローバル配列の AryFile() に格納されます。
'----------------------------------------------------------------------------
' Summary: FTPファイル一覧を取得
' Description. 取得結果はグローバル配列の AryFile() に格納されます.
' return boolean: True=ファイルあり,False=失敗orファイルなし
'----------------------------------------------------------------------------
Public Function GetFTPFileList() As Boolean
On Error GoTo ErrorHandler
Dim w32FindData As WIN32_FIND_DATA
Dim lngInet As Long 'インターネットサービスのハンドル
Dim lngFTP As Long 'FTPセッションのハンドル
Dim lngRet As Long
Dim lngFind As Long
Dim lngCount As Long
Dim result As Long
Dim strPass As String
Dim strFile As String
GetFTPFileList = False
'前回接続時のFTPパスワードを取得
strPass = GetFTPPass
lngInet = 0
lngFTP = 0
lngCount = -1
Erase AryFile
'インターネットサービスのハンドル取得
lngInet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
If (lngInet <> 0) Then 'ハンドル取得成功
OpenFTP:
'FTPサーバーに接続
lngFTP = InternetConnect(lngInet, FTP_HOST, _
INTERNET_DEFAULT_FTP_PORT, _
FTP_USER, strPass, _
INTERNET_SERVICE_FTP, 0&, 0&)
If lngFTP <> 0 Then
Call UpdateFTPPass(strPass) 'FTPパス更新
'FTPサーバカレントディレクトリを変更
result = FtpSetCurrentDirectory(lngFTP, FTP_DIR)
If (result <> 0) Then
'CSVファイルのみを対象にする場合は"*.csv"と指定
lngFind = FtpFindFirstFile(lngFTP, "*", w32FindData, INTERNET_FLAG_RELOAD, 0)
If (lngFind = 0) Then
MsgBox "FTPサーバ上にファイルがありません。"
Else
Do
strFile = Trim(Left(w32FindData.cFileName, InStr(w32FindData.cFileName, vbNullChar) - 1))
lngCount = lngCount + 1
ReDim Preserve AryFile(lngCount)
AryFile(lngCount) = strFile
'次のファイル名を取得
Loop Until InternetFindNextFile(lngFind, w32FindData) = 0
GetFTPFileList = True
End If
Else
MsgBox "ディレクトリ取得に失敗しました。"
End If
Else
strPass = InputBox("FTP接続に失敗しました。" & vbNewLine & "パスワードを入力してください。", "FTPサーバ接続", strPass)
If StrPtr(strPass) <> 0 Then
GoTo OpenFTP 'リトライ
End If
End If
Else
MsgBox "FTP接続に失敗しました。"
End If
GoTo Finally
ErrorHandler:
MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical, "エラーが発生しました。"
Finally:
'FTPセッションクローズ
If (lngFTP <> 0) Then InternetCloseHandle lngFTP
'インターネットサービスクローズ
If (lngInet <> 0) Then InternetCloseHandle lngInet
End Function
FTPでファイルをダウンロード
FTPサーバー上のファイルをダウンロードする処理です。
上記に記載している、FTPファイル一覧を取得する処理、GetFTPFileList関数で取得したファイル名のいずれかと、保存先ファイル名のフルパスを指定します。
'----------------------------------------------------------------------------
' Summary: FTPダウンロード
' Discription:GetFTPFileList関数で取得したファイル名のいずれかと、保存先ファイル名のフルパスを指定します。
' param strFrom:ダウンロードするファイル名
' param strTo:ダウンロード後の保存先ファイルのフルパス
' return boolean: True=成功,False=失敗
'----------------------------------------------------------------------------
Public Function FtpDownload(ByVal strFrom As String, ByVal strTo As String) As Boolean
On Error GoTo ErrorHandler
Dim lngInet As Long
Dim lngFTP As Long
Dim lngRet As Long
Dim strPass As String
Dim strFile As String
FtpDownload = False
'前回接続時のFTPパスワードを取得
strPass = GetFTPPass
lngInet = 0
lngFTP = 0
'FTPをオープン
lngInet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, vbNullString, 0&)
If lngInet <> 0 Then
OpenFTP:
'FTPサーバ接続
lngFTP = InternetConnect(lngInet, FTP_HOST, _
INTERNET_DEFAULT_FTP_PORT, _
FTP_USER, strPass, _
INTERNET_SERVICE_FTP, 0&, 0&)
If lngFTP <> 0 Then
'FTP接続成功
Call UpdateFTPPass(strPass) 'FTPパス更新
'ダウンロード先ファイルがあったら削除
If Len(Dir(strTo)) > 0 Then Kill strTo
'ダウンロード元ディレクトリへ移動
FtpSetCurrentDirectory lngFTP, FTP_DIR
'バイナリモードFTP_TRANSFER_TYPE_BINRYでダウンロード
'ASCIIの場合はFTP_TRANSFER_TYPE_ASCIIを指定
lngRet = FtpGetFile(lngFTP, strFrom, strTo, _
1&, FILE_ATTRIBUTE_NORMAL, _
FTP_TRANSFER_TYPE_BINARY, 0&)
If lngRet <> 0 Then FtpDownload = True
Else
strPass = InputBox("FTP接続に失敗しました。" & vbNewLine & "パスワードを入力してください。", "FTPサーバ接続", strPass)
If StrPtr(strPass) <> 0 Then
GoTo OpenFTP 'リトライ
End If
End If
End If
GoTo Finally
ErrorHandler:
MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical, "エラーが発生しました。"
Finally:
'FTPセッションクローズ
If (lngFTP <> 0) Then InternetCloseHandle lngFTP
'インターネットサービスクローズ
If (lngInet <> 0) Then InternetCloseHandle lngInet
End Function
FTPでファイルをアップロード
FTPでアップロードする処理です。
'----------------------------------------------------------------------------
' Summary: FTPアップロード
' param strFrom:アップロード元ローカルファイルのフルパス
' param strTo:アップロード先に配置する時のファイル名
'----------------------------------------------------------------------------
Public Function FtpUpload(ByVal strFrom As String _
, Optional ByVal strTo As String)
On Error GoTo ErrorHandler
Dim strPass As String
Dim abytFrom() As Byte
Dim abytTo() As Byte
Dim lngInet As Long
Dim lngFTP As Long
Dim lngRet As Long
lngInet = 0
lngFTP = 0
'前回接続時のFTPパスワードを取得
strPass = GetFTPPass
'インターネットサービスのハンドル取得
lngInet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, vbNullString, 0&)
If lngInet <> 0 Then
OpenFTP:
'FTPサーバ接続
lngFTP = InternetConnect(lngInet, FTP_HOST, _
INTERNET_DEFAULT_FTP_PORT, _
FTP_USER, strPass, _
INTERNET_SERVICE_FTP, 0&, 0&)
If lngFTP <> 0 Then
Call UpdateFTPPass(strPass) 'FTPパス更新
'アップロード先ディレクトリへ移動
FtpSetCurrentDirectory lngFTP, FTP_DIR
'ファイル名をUnicodeからシステムの規定コードに変換
abytFrom = StrConv((strFrom & vbNullChar), vbFromUnicode)
abytTo = StrConv((strTo & vbNullChar), vbFromUnicode)
'バイナリモードFTP_TRANSFER_TYPE_BINRYでアップロード
'ASCIIの場合はFTP_TRANSFER_TYPE_ASCIIを指定
lngRet = FtpPutFile(lngFTP, abytFrom(0), abytTo(0), _
FTP_TRANSFER_TYPE_BINARY, 0&)
If lngRet <> 0 Then
'FTPアップロード成功
MsgBox "ファイルのアップロードが完了しました。", vbOKOnly + vbInformation
Else
MsgBox "FTPアップロードに失敗しました。"
End If
Else
strPass = InputBox("FTP接続に失敗しました。" & vbNewLine & "パスワードを入力してください。", "FTPサーバ接続", strPass)
If StrPtr(strPass) <> 0 Then
GoTo OpenFTP 'リトライ
End If
End If
Else
MsgBox "FTP接続に失敗しました。"
End If
GoTo Finally
ErrorHandler:
MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical, "エラーが発生しました。"
Finally:
'FTPセッションクローズ
If (lngFTP <> 0) Then InternetCloseHandle lngFTP
'インターネットサービスクローズ
If (lngInet <> 0) Then InternetCloseHandle lngInet
End Function
FTPサーバー上のファイルを削除
FTPサーバー上のファイルを削除する処理です。
削除するファイル名の指定が無い場合は全て削除します。
'----------------------------------------------------------------------------
' Summary: FTPサーバー上のファイルを削除
' Description. 削除ファイル名の指定が無い場合は全て削除.
' param strFile: 削除ファイル名
' return boolean: True=成功,False=失敗
'----------------------------------------------------------------------------
Public Function FtpDelete(Optional ByVal strFile As String = "") As Boolean
On Error GoTo ErrorHandler
Dim w32FindData As WIN32_FIND_DATA
Dim lngInet As Long 'インターネットサービスのハンドル
Dim lngFTP As Long 'FTPセッションのハンドル
Dim lngRet As Long
Dim lngFind As Long
Dim result As Long
Dim strPass As String
FtpDelete = False
'前回接続時のFTPパスワードを取得
strPass = GetFTPPass
lngInet = 0
lngFTP = 0
Erase AryFile
'インターネットサービスのハンドル取得
lngInet = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
If (lngInet <> 0) Then 'ハンドル取得成功
OpenFTP:
'FTPサーバーに接続
lngFTP = InternetConnect(lngInet, FTP_HOST, _
INTERNET_DEFAULT_FTP_PORT, _
FTP_USER, strPass, _
INTERNET_SERVICE_FTP, 0&, 0&)
If lngFTP <> 0 Then
Call UpdateFTPPass(strPass) 'FTPパス更新
'FTPサーバカレントディレクトリを変更
result = FtpSetCurrentDirectory(lngFTP, FTP_DIR)
If (result <> 0) Then 'ディレクトリ変更成功
'csvファイルのみを対象とする場合は *.csv と指定
lngFind = FtpFindFirstFile(lngFTP, "*", w32FindData, INTERNET_FLAG_RELOAD, 0)
If (lngFind = 0) Then
'ファイルなし
Else
If strFile = "" Then
Do
strFile = Left(w32FindData.cFileName, InStr(w32FindData.cFileName, vbNullChar) - 1)
result = FtpDeleteFile(lngFTP, strFile)
Loop Until InternetFindNextFile(lngFind, w32FindData) = 0 '次のファイル名を取得
Else
result = FtpDeleteFile(lngFTP, strFile)
End If
End If
If result Then FtpDelete = True
Else
MsgBox "ディレクトリの移動に失敗しました。" & Err.LastDllError
End If
Else
strPass = InputBox("FTP接続に失敗しました。" & vbNewLine & "パスワードを入力してください。", "FTPサーバ接続", strPass)
If StrPtr(strPass) <> 0 Then
GoTo OpenFTP 'リトライ
End If
End If
Else
MsgBox "FTP接続に失敗しました。"
End If
GoTo Finally
ErrorHandler:
MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical, "エラーが発生しました。"
Finally:
'FTPセッションクローズ
If (lngFTP <> 0) Then InternetCloseHandle lngFTP
'インターネットサービスクローズ
If (lngInet <> 0) Then InternetCloseHandle lngInet
End Function
FTPパスワードを取得
ローカルテーブルで管理するFTPパスワードを取得する処理です。
ローカルACCESSファイル内に T_FTP テーブルが自動的に作成されます。
テーブルの存在チェックに ADO Extライブラリを 利用しているため、予め下記手順でADO Extライブラリを追加してください。
Visual Basic Editorのメニュー [ツール] ⇒ [参照設定] より『Microsoft ADO Ext. 6.0 for DDL and Security』を追加。
'----------------------------------------------------------------------------
' Summary:FTPパスワードを取得
' ※暗号化してないので、利用者が複数なら暗号化するか都度入力する方向に。
'----------------------------------------------------------------------------
Private Function GetFTPPass() As String
On Error GoTo ErrorHandler
Dim sql As String
Dim cn As ADODB.Connection
Set cn = CurrentProject.Connection
Dim rs As ADODB.Recordset
Set rs = cn.OpenSchema(adSchemaTables)
'T_FTPテーブル存在チェック
Dim isExist As Boolean
Do Until rs.EOF
If rs!TABLE_NAME = "T_FTP" Then
isExist = True
Exit Do
End If
rs.MoveNext
Loop
rs.Close
If isExist = False Then
'T_FTPテーブル作成
Dim cat As New ADOX.Catalog
cat.ActiveConnection = cn
Dim tbl As New ADOX.Table
tbl.Name = "T_FTP"
Set tbl.ParentCatalog = cat
tbl.Columns.Append "FTP_USER", adVarWChar
tbl.Columns.Append "FTP_PASS", adVarWChar
cat.Tables.Append tbl
Set cat = Nothing
cn.Execute "CREATE INDEX index1 ON T_FTP (FTP_USER);"
End If
sql = "SELECT * FROM T_FTP WHERE T_FTP.FTP_USER='" & FTP_USER & "'"
rs.Open sql, cn, adOpenStatic, adLockReadOnly
If rs.RecordCount = 1 Then
GetFTPPass = rs!FTP_PASS
Else
GetFTPPass = ""
End If
GoTo Finally
ErrorHandler:
GetFTPPass = ""
MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical, "エラーが発生しました。"
Finally:
If Not cn Is Nothing Then
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End If
End Function
FTPパスワードを更新
ローカルテーブルで管理するFTPパスワードを更新する処理です。
'----------------------------------------------------------------------------
' Summary:FTPパスワードを更新
' ※暗号化していないので、利用者が複数なら暗号化するか都度入力する方向に。
' param strPass 新FTPパスワード
'----------------------------------------------------------------------------
Private Function UpdateFTPPass(ByVal strPass As String) As String
On Error GoTo ErrorHandler
Dim sql As String
Dim rs As New ADODB.Recordset
Dim cn As ADODB.Connection
Set cn = CurrentProject.Connection
sql = "SELECT * FROM T_FTP" & _
" WHERE T_FTP.FTP_USER='" & FTP_USER & "'"
rs.CursorLocation = adUseClient
rs.Open sql, cn, adOpenDynamic, adLockOptimistic
cn.BeginTrans
If rs.RecordCount = 1 Then
rs.Update "FTP_PASS", strPass
Else
'新規登録
sql = "INSERT INTO T_FTP (FTP_USER, FTP_PASS)"
sql = sql & " VALUES ("
sql = sql & "'" & FTP_USER & "'"
sql = sql & ",'" & strPass & "'"
sql = sql & ")"
cn.Execute sql
End If
cn.CommitTrans
GoTo Finally
ErrorHandler:
MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical, "エラーが発生しました。"
Finally:
If Not cn Is Nothing Then
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End If
End FunctionFTP接続時のパスワードをローカルテーブルで管理するようにしています、FTP接続が失敗した場合はパスワードの再入力を促してきます。正常に接続できた場合は、新しいパスワードをテーブルに保存します。この機能が不要な場合はパスワードの取得( GetFTPPass )と更新関数( UpdateFTPPass )の呼び出し箇所を修正してパスワード直接指定に変更してください。
パスワード保存機能を利用する場合は T_FTP テーブルが作成されている必要があります。T_FTPテーブルは「FTPパスワードを取得」の処理部分で自動作成されるようになっています。
