Home >> ヒント・サンプル集 >> プログラムサンプル >> (VBA[関数] FTP送受信他

<VBA> [関数] FTP送受信他
DOSコマンドからFTPができますが、WinAPIでも可能です
送信、受信、ファイル削除、ファイルリネーム、フォルダ削除、ファイル一覧取得が可能です

Option Compare Database

' Constants - InternetOpen.lAccessType
 Public Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0&
 Public Const INTERNET_OPEN_TYPE_DIRECT As Long = 1&
 Public Const INTERNET_OPEN_TYPE_PROXY As Long = 3&
 Public Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY As Long = 4&

' Constants - InternetOpen.dwFlags
 Public Const INTERNET_FLAG_ASYNC As Long = &H10000000
 Public Const INTERNET_FLAG_FROM_CACHE As Long = &H1000000
 Public Const INTERNET_FLAG_OFFLINE As Long = INTERNET_FLAG_FROM_CACHE

' Constants - InternetConnect.nServerPort
 Public Const INTERNET_INVALID_PORT_NUMBER As Long = 0&
 Public Const INTERNET_DEFAULT_FTP_PORT As Long = 21&
 Public Const INTERNET_DEFAULT_GOPHER_PORT As Long = 70&
 Public Const INTERNET_DEFAULT_HTTP_PORT As Long = 80&
 Public Const INTERNET_DEFAULT_HTTPS_PORT As Long = 443&
 Public Const INTERNET_DEFAULT_SOCKS_PORT As Long = 1080&

' Constants - InternetConnect.dwService
 Public Const INTERNET_SERVICE_FTP As Long = 1&
 Public Const INTERNET_SERVICE_GOPHER As Long = 2&
 Public Const INTERNET_SERVICE_HTTP As Long = 3&

' Constants - InternetConnect.dwFlags
 Public Const INTERNET_FLAG_PASSIVE As Long = &H8000000

' Constants - FtpGetFile.dwFlags (FTP TransferType)
' Constants - FtpPutFile.dwFlags (FTP TransferType)
 Public Const FTP_TRANSFER_TYPE_UNKNOWN As Long = &H0&
 Public Const FTP_TRANSFER_TYPE_ASCII As Long = &H1&
 Public Const FTP_TRANSFER_TYPE_BINARY As Long = &H2&
 Public Const INTERNET_FLAG_TRANSFER_ASCII As Long = FTP_TRANSFER_TYPE_ASCII
 Public Const INTERNET_FLAG_TRANSFER_BINARY As Long = FTP_TRANSFER_TYPE_BINARY

' Constants - FtpGetFile.dwFlags (Cache Flags)
' Constants - FtpPutFile.dwFlags (Cache Flags)
 Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
 Public Const INTERNET_FLAG_RESYNCHRONIZE As Long = &H800
 Public Const INTERNET_FLAG_NEED_FILE As Long = &H10
 Public Const INTERNET_FLAG_HYPERLINK As Long = &H400

' Constants - FtpGetFile.dwFlagsAndAttributes
 Public Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
 Public Const FILE_ATTRIBUTE_ENCRYPTED As Long = &H4000
 Public Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
 Public Const FILE_ATTRIBUTE_NORMAL As Long = &H80
 Public Const FILE_ATTRIBUTE_OFFLINE As Long = &H1000
 Public Const FILE_ATTRIBUTE_READONLY As Long = &H1
 Public Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
 Public Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100
 Public Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
 Public Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800

 ' FILETIME 構造体
 Type FileTime
    dwLowDateTime As Long
    dwHighDateTime As Long
 End Type

 ' WIN32_FIND_DATA 構造体
 Public Const MAX_PATH = 260
 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
 
 Type SystemTime
    Year As Integer
    Month As Integer
    DayOfWeek As Integer
    Day As Integer
    Hour As Integer
    Minute As Integer
    Second As Integer
    Milliseconds As Integer
End Type

 Declare PtrSafe Function FileTimeToSystemTime Lib "KERNEL32.DLL" (ByRef lpFileTime As FileTime, ByRef lpSystemTime As SystemTime) As Long
 ' インターネットハンドルを取得します。
 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 LongPtr
 ' サーバへ接続します。
 Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal HINTERNET As LongPtr, 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 LongPtr) As LongPtr
 ' インターネットハンドルを閉じます。
 Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" (ByVal HINTERNET As LongPtr) As Integer
 ' サーバのカレントディレクトリを取得します。
 Declare PtrSafe Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hConnect As LongPtr, ByVal lpszCurrentDirectory As String, ByRef lpdwCurrentDirectory As Long) As Boolean
 ' サーバのカレントディレクトリを設定します。
 Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hConnect As LongPtr, ByVal lpszDirectory As String) As Long
 ' サーバからファイルを取得します。
 Declare PtrSafe Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As LongPtr, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As LongPtr) As Long
 ' サーバへファイルを転送します。
 Declare PtrSafe Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As LongPtr, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As LongPtr) As Long
 ' サーバのファイルを削除します。
 Declare PtrSafe Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hConnect As LongPtr, ByVal lpszFileName As String) As Long
 ' サーバのファイル名を変更します。
 Declare PtrSafe Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hConnect As LongPtr, ByVal lpszExisting As String, ByVal lpszNew As String) As Long
 ' サーバのディレクトリを削除します。
 Declare PtrSafe Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hConnect As LongPtr, ByVal lpszDirectory As String) As Long
 ' 指定されたディレクトリを検索します。
 Declare PtrSafe Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As LongPtr, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As LongPtr) As LongPtr
 ' 引き続き、ディレクトリを検索します。
 Declare PtrSafe Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As LongPtr, lpvFindData As WIN32_FIND_DATA) As Long


'********************************************************
'* WinInetを使ったFTP処理の考え方
'*
'* 1 Internet Open (インターネットサービスのハンドル取得)
'* 2   OKなら InternetConnect(FTPサーバーへ接続)
'* 3     OKなら カレントディレクトリ変更
'* 4       OKなら、メイン処理
'* -----------------------------------------------------
'* このため、エラーコードの XYYYYY の
'*  Xの値が上記のStep No
'*   YYYYYがWinInetのエラーコード となるようにした
'* これでどこまでうまくいっているのかがすぐにわかるように
'*********************************************************

Const User_Agent = "FTP_VBA"

Function saPutFTP(FTP_Server, UID, PWD, Folder, FileName, Optional DestName) As Long
'*************************************************************************
'*  FTP File Put  (Upload)   Send by BINARY
'*************************************************************************
'     Folder  : Directory on FTP Server
'     FileName: Local File FullPath (Separated by |)
'     DestName: FileName (optional Separated by | )
'
'     ・FileName,DestNameは、|をセパレータとして複数指定できます
'     ・DestNameがないときは、送信元ファイル名がそのまま使われます
'     ・送信元ファイル名にワイルドカード(*/?が)が使われた時は、
'       DestNameは無視して送信元ファイル名を使用します
'     ・FileNameとDestNameのsplit後の数が同じでないときは、エラー499999
'-------------------------------------------------------------------------'
    
    Dim hOpen As LongPtr
    Dim hConnection As LongPtr
    Dim Result As Long
    hOpen = 0
    hConnection = 0

     hOpen = InternetOpen(User_Agent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
     If (hOpen <> 0) Then
         hConnection = InternetConnect(hOpen, FTP_Server, INTERNET_INVALID_PORT_NUMBER, _
             UID, PWD, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
         If (hConnection <> 0) Then
            Result = FtpSetCurrentDirectory(hConnection, Folder)
             If (Result <> 0) Then
                '------------------------------------------------ Upload Main ----------------
                Dim wDestName As String
                Dim FF() As String
                Dim TT() As String
                FF = Split(FileName, "|")
                If IsMissing(DestName) Then wDestName = "" Else wDestName = DestName
                If InStr(FileName, "*") <> 0 Or InStr(FileName, "?") <> 0 Then wDestName = ""
                If wDestName <> "" Then
                    TT = Split(wDestName, "|")
                    If UBound(FF) <> UBound(TT) Then
                        saPutFTP = 499999
                        Exit Function
                    End If
                End If
                Dim i As Long
                For i = 0 To UBound(FF)
                    If wDestName = "" Then
                        If InStr(FF(i), "*") <> 0 Or InStr(FF(i), "?") <> 0 Then
                            Dim wFF
                            wFF = Dir(FF(i), 0)
                            Do While wFF <> ""
                                Result = FtpPutFile(hConnection, Left(FF(i), InStrRev(FF(i), "\")) & wFF, wFF, FTP_TRANSFER_TYPE_BINARY, 0)
                                wFF = Dir()
                            Loop
                        Else
                            Result = FtpPutFile(hConnection, FF(i), Mid(FF(i), InStrRev(FF(i), "\") + 1), FTP_TRANSFER_TYPE_BINARY, 0)
                        End If
                    Else
                        Result = FtpPutFile(hConnection, FF(i), TT(i), FTP_TRANSFER_TYPE_BINARY, 0)
                    End If
                    If (Result = 0) Then
                      saPutFTP = i * 1000000 + 400000 + Err.LastDllError
                    Else
                      saPutFTP = 0
                    End If
                Next
                '------------------------------------------------ Upload Main End ------------
             Else
                saPutFTP = 300000 + Err.LastDllError
             End If
         Else
            saPutFTP = 200000 + Err.LastDllError
         End If
     Else
         saPutFTP = 100000 + Err.LastDllError
     End If
    If (hConnection <> 0) Then InternetCloseHandle hConnection
    If (hOpen <> 0) Then InternetCloseHandle hOpen
End Function

Function saGetFTP(FTP_Server, UID, PWD, Folder, FileName, DestName) As Long
'*********************************************************
'*  FTP File Get  (Download)
'*********************************************************
'     Folder  : Directory on FTP Server
'     FileName: FileName (Separated by | )
'     DestName: Local File FullPath (Separated by |)
'               フォルダのみ指定の場合はファイル名は同一(最後が\)
'               DestNameのsplit後の数が少ないときは、最後のフォルダ指定を使用して、同じファイル名でDL
'
'     ・FileName,DestNameは、|をセパレータとして複数指定できます
'     ・DestNameがないときは、送信元ファイル名がそのまま使われます
'     ・送信元ファイル名にワイルドカード(*/?が)が使われた時は、
'       DestNameは無視して送信元ファイル名を使用します
'     ・split後の数がFileName < DestNameのときは、エラー499999
        
    Dim hOpen As LongPtr
    Dim hConnection As LongPtr
    Dim Result As Long
    Dim w32FindData As WIN32_FIND_DATA
    hOpen = 0
    hConnection = 0

     hOpen = InternetOpen(User_Agent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
     If (hOpen <> 0) Then
         hConnection = InternetConnect(hOpen, FTP_Server, INTERNET_INVALID_PORT_NUMBER, _
             UID, PWD, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
         If (hConnection <> 0) Then
            Result = FtpSetCurrentDirectory(hConnection, Folder)
             If (Result <> 0) Then
                '------------------------------------------------ Download Main ----------------
                Dim wDestName As String
                Dim wDestFol As String
                Dim FF() As String
                Dim TT() As String
                FF = Split(FileName, "|")
                TT = Split(DestName, "|")
                    
                If UBound(FF) < UBound(TT) Then
                    saGetFTP = 499999
                    Exit Function
                End If
                
                Dim i As Long
                For i = 0 To UBound(FF)
                
                    If UBound(TT) >= i Then ' ttの指定があり、フォルダの指定があるなら、DL先フォルダを取得 なければ最後のDL先フォルダを使用する
                        If InStr(TT(i), "\") <> 0 Then wDestFol = Left(TT(i), InStrRev(TT(i), "\"))
                    End If
                    
                    If InStr(FF(i), "*") <> 0 Or InStr(FF(i), "?") <> 0 Then  '-------------------- Wildcard? ----
                        saGetFTP = 0
                
                        hFind = FtpFindFirstFile(hConnection, FF(i), w32FindData, INTERNET_FLAG_RELOAD, 0)
                        If (hFind = 0) Then
                            RtnCD = 400000 + Err.LastDllError
                        Else
                          Do
                            strFile = Left(w32FindData.cFileName, InStr(w32FindData.cFileName, vbNullChar) - 1)
                            'strFile = Mid(strFile, InStrRev(strFile, " ") + 1) '
                            If ((w32FindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = &H10) Then
                                ' it is Folder
                                Else
                                    wDestName = strFile '元のファイル名
                                    Result = FtpGetFile(hConnection, strFile, wDestFol & "\" & wDestName, False, _
                                       FILE_ATTRIBUTE_NORMAL, FTP_TRANSFER_TYPE_BINARY Or INTERNET_FLAG_RELOAD, 0)
                                    If (Result = 0) Then
                                      saGetFTP = i * 1000000 + 400000 + Err.LastDllError
                                    End If
                            End If
                          Loop Until InternetFindNextFile(hFind, w32FindData) = 0
                        End If
                    Else '--------------------------------------------------------------------- Not Wildcard ----
                        If UBound(TT) >= i Then                ' ttの指定があり、
                            If Right(TT(i), 1) = "\" Then          'フォルダ指定のみ
                                wDestName = FF(i)
                            Else
                                If InStr(TT(i), "\") <> 0 Then     'フォルダ+ファイル指定?
                                    wDestName = Mid(TT(i), InStrRev(TT(i), "\") + 1)
                                Else                               'ファイル指定のみ
                                    wDestName = TT(i)
                                End If
                            End If
                        Else                                       ' ttの指定なし
                            wDestName = FF(i)
                        End If
                        Result = FtpGetFile(hConnection, FF(i), wDestFol & "\" & wDestName, False, _
                           FILE_ATTRIBUTE_NORMAL, FTP_TRANSFER_TYPE_BINARY Or INTERNET_FLAG_RELOAD, 0)
                        If (Result = 0) Then
                          saGetFTP = i * 1000000 + 400000 + Err.LastDllError
                        Else
                          saGetFTP = 0
                        End If
                    End If
                Next
                '------------------------------------------------ Download Main End ------------
             Else
                saGetFTP = 300000 + Err.LastDllError
             End If
         Else
            saGetFTP = 200000 + Err.LastDllError
         End If
     Else
         saGetFTP = 100000 + Err.LastDllError
     End If
    If (hConnection <> 0) Then InternetCloseHandle hConnection
    If (hOpen <> 0) Then InternetCloseHandle hOpen
End Function

Function saDelFTP(FTP_Server, UID, PWD, Folder, FileName) As Long
'*********************************************************
'*  FTP File Delete
'*********************************************************
    'Folder:      Directory on FTP Server
    'FileName: FileName (Separated by |)
    '  and can use wildcard */?
        
    Dim hOpen As LongPtr
    Dim hConnection As LongPtr
    Dim Result As Long
    Dim w32FindData As WIN32_FIND_DATA
    hOpen = 0
    hConnection = 0
     hOpen = InternetOpen(User_Agent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
     If (hOpen <> 0) Then
         hConnection = InternetConnect(hOpen, FTP_Server, INTERNET_INVALID_PORT_NUMBER, _
             UID, PWD, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
         If (hConnection <> 0) Then
            Result = FtpSetCurrentDirectory(hConnection, Folder)
             If (Result <> 0) Then
                '------------------------------------------------ Delete Main ----------------
                Dim FF() As String
                FF = Split(FileName, "|")
                
                Dim i As Long
                For i = 0 To UBound(FF)
                    If InStr(FF(i), "*") <> 0 Or InStr(FF(i), "?") <> 0 Then  '-------------------- Wildcard? ----
                        saDelFTP = 0
                        hFind = FtpFindFirstFile(hConnection, FF(i), w32FindData, INTERNET_FLAG_RELOAD, 0)
                        If (hFind = 0) Then
                            RtnCD = 400000 + Err.LastDllError
                        Else
                            Do
                              strFile = Left(w32FindData.cFileName, InStr(w32FindData.cFileName, vbNullChar) - 1)
                              If ((w32FindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = &H10) Then
                                  '
                              Else
                                  Result = FtpDeleteFile(hConnection, strFile)
                                  If (Result = 0) Then
                                       saDelFTP = 400000 + Err.LastDllError
                                  End If
                              End If
                            Loop Until InternetFindNextFile(hFind, w32FindData) = 0
                        End If
                    Else '--------------------------------------------------------------------- Not Wildcard ----
                        Result = FtpDeleteFile(hConnection, FF(i))
                        If (Result = 0) Then
                             saDelFTP = 400000 + Err.LastDllError
                           Else
                             saDelFTP = 0
                        End If
                    End If
                Next
                '------------------------------------------------ Delete Main End ------------
             Else
                saDelFTP = 300000 + Err.LastDllError
             End If
         Else
            saDelFTP = 200000 + Err.LastDllError
         End If
     Else
         saDelFTP = 100000 + Err.LastDllError
     End If

    If (hConnection <> 0) Then InternetCloseHandle hConnection
    If (hOpen <> 0) Then InternetCloseHandle hOpen
End Function

Function saRenFTP(FTP_Server, UID, PWD, Folder, FileName, NewName) As Long
'*********************************************************
'*  FTP File Rename
'*********************************************************
    'Folder:      Directory on FTP Server
    'FileName: TargetFileName (Separated by |)
    'NewName:  NewFileName (Separated by |)
        
    Dim hOpen As LongPtr
    Dim hConnection As LongPtr
    Dim Result As Long
    hOpen = 0
    hConnection = 0

     hOpen = InternetOpen(User_Agent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
     If (hOpen <> 0) Then
         hConnection = InternetConnect(hOpen, FTP_Server, INTERNET_INVALID_PORT_NUMBER, _
             UID, PWD, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
         If (hConnection <> 0) Then
            Result = FtpSetCurrentDirectory(hConnection, Folder)
             If (Result <> 0) Then
                '------------------------------------------------ Rename Main ----------------
                saRenFTP = 0
                Dim FF() As String
                Dim TT() As String
                FF = Split(FileName, "|")
                TT = Split(NewName, "|")
                    
                If UBound(FF) <> UBound(TT) Then
                    saRenFTP = 499999
                    Exit Function
                End If
                
                Dim i As Long
                For i = 0 To UBound(FF)
                    Result = FtpRenameFile(hConnection, FF(i), TT(i))
                    If (Result = 0) Then
                      saRenFTP = i * 1000000 + 400000 + Err.LastDllError
                    End If
                Next
                '------------------------------------------------ Rename Main End ------------
             Else
                saRenFTP = 300000 + Err.LastDllError
             End If
         Else
            saRenFTP = 200000 + Err.LastDllError
         End If
     Else
         saRenFTP = 100000 + Err.LastDllError
     End If
    If (hConnection <> 0) Then InternetCloseHandle hConnection
    If (hOpen <> 0) Then InternetCloseHandle hOpen
End Function

Function saRemDirFTP(FTP_Server, UID, PWD, Folder, DelFolder) As Long
'*********************************************************
'*  FTP Remove Directory   1 Layer Only
'*      Delete [FolderName] Directory on [Folder] Directory
'*      Delete when Directory is empty
'*********************************************************
    'Folder:      Directory on FTP Server
    'FolderName: Remove Folder Name
        
    Dim hOpen As LongPtr
    Dim hConnection As LongPtr
    Dim Result As Long
    hOpen = 0
    hConnection = 0

     hOpen = InternetOpen(User_Agent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
     If (hOpen <> 0) Then
         hConnection = InternetConnect(hOpen, FTP_Server, INTERNET_INVALID_PORT_NUMBER, _
             UID, PWD, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
         If (hConnection <> 0) Then
            Result = FtpSetCurrentDirectory(hConnection, Folder)
             If (Result <> 0) Then
                Result = FtpRemoveDirectory(hConnection, DelFolder)
                 If (Result = 0) Then
                    saRemDirFTP = 400000 + Err.LastDllError
                    Else
                      saRemDirFTP = 0
                 End If
             Else
                saRemDirFTP = 300000 + Err.LastDllError
             End If
         Else
            saRemDirFTP = 200000 + Err.LastDllError
         End If
     Else
         saRemDirFTP = 100000 + Err.LastDllError
     End If
    If (hConnection <> 0) Then InternetCloseHandle hConnection
    If (hOpen <> 0) Then InternetCloseHandle hOpen
End Function

Function saGetListFTP(FTP_Server, UID, PWD, Folder, Search, ByRef FileList() As String)
'*********************************************************
'*  FTP Get File List
'*    Search: "*.*" など
'*    Return: FileList Table(File/Folder Name Only - NoPath)
'*       Folder Nameのとき、最後に/(Slash)がつきます
'*********************************************************
    'Folder:      Directory on FTP Server
        
    Dim hOpen As LongPtr
    Dim hConnection As LongPtr
    Dim Result As Long
    Dim w32FindData As WIN32_FIND_DATA
    Dim wSystemTime As SystemTime
    Dim wCreateDT As String
    hOpen = 0
    hConnection = 0

     hOpen = InternetOpen(User_Agent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
     If (hOpen <> 0) Then
         hConnection = InternetConnect(hOpen, FTP_Server, INTERNET_INVALID_PORT_NUMBER, _
             UID, PWD, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
         If (hConnection <> 0) Then
            Result = FtpSetCurrentDirectory(hConnection, Folder)
             If (Result <> 0) Then
                hFind = FtpFindFirstFile(hConnection, Search, w32FindData, INTERNET_FLAG_RELOAD, 0)
                If (hFind = 0) Then
                    RtnCD = 400000 + Err.LastDllError
                Else
                  'Dim FileList() As String
                  Dim Cnt As Long, i As Long
                  Cnt = -1
                  Do
                    strFile = Left(w32FindData.cFileName, InStr(w32FindData.cFileName, vbNullChar) - 1)
                    'strFile = Mid(strFile, InStrRev(strFile, " ") + 1) '
                    If ((w32FindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = &H10) Then
                        strFile = strFile & "/" 'Add / when it is Folder
                    End If
                    
                    'Caution!!!! FTPサーバーによっては、日付を返さなかったりすることもあるので注意!
                    'この処理も、2003では、最終更新日しか返してもらえなかったのでこれを使用しているだけ
                    
                    Call FileTimeToSystemTime(w32FindData.ftLastWriteTime, wSystemTime)
                    With wSystemTime
                        wCreateDT = .Year & "/" & Format(.Month, "00") & "/" & Format(.Day, "00") & " " & Format(.Hour, "00") & ":" & Format(.Minute, "00") & ":" & Format(.Second, "00")
                    End With
                    Cnt = Cnt + 1
                    ReDim Preserve FileList(Cnt)
                    FileList(Cnt) = wCreateDT & "\" & strFile ' 日付を先にしてあるので、あとで日付順にソートできる
                  Loop Until InternetFindNextFile(hFind, w32FindData) = 0
                End If
                'saGetListFTP = FileList
                RtnCD = 0
             Else
                RtnCD = 300000 + Err.LastDllError
             End If
         Else
            RtnCD = 200000 + Err.LastDllError
         End If
     Else
         RtnCD = 100000 + Err.LastDllError
     End If
    If (hConnection <> 0) Then InternetCloseHandle hConnection
    If (hOpen <> 0) Then InternetCloseHandle hOpen
    saGetListFTP = RtnCD
End Function


■■■ 送信 (saPutFTP) ■■■
《引数》
・Host Name、UserID、password、Host Folder、Target File、(option: Destination Name)
 送信ファイル名とアップロードのファイル名を変更したいときに第6パラメータを設定してください
 - Target File, Destinatioin Nameは、|をセパレータとして複数指定できます
 - Destinatioin Nameがないときは、送信元ファイル名がそのまま使われます
 - 送信元ファイル名にワイルドカード(*/?が)が使われた時は、
  Destinatioin Nameは無視して送信元ファイル名を使用します
 - Target FileとDestinatioin Nameのsplit後の数が同じでないときは、エラー499999
・リターンコード(long)にエラーコードが返ります

《サンプル》
・r = saPutFTP("ftp.your-domain.com.au", "UserID", "password", "/wwwroot", "\\Local_Web_Server\Web\SITE\DB.accdb","Web.accdb")
・r = saPutFTP("ftp.your-domain.com.au", "UserID", "password", "/wwwroot", "Z:\*.aspx")

■■■ 受信 (saGetFTP) ■■■
《引数》
・Host Name、UserID、password、Host Folder、Target File、Destination Name
 - Target File, Destinatioin Nameは、|をセパレータとして複数指定できます
 - Destinatioin Nameがフォルダ名のみのときは、送信元ファイル名がそのまま使われます
 - 送信元ファイル名にワイルドカード(*/?が)が使われた時は、
  Destinatioin Nameは無視して送信元ファイル名を使用します
 - Target FileとDestinatioin Nameのsplit後の数が同じでないときは、エラー499999
・リターンコード(long)にエラーコードが返ります

《サンプル》
r = saGetFTP("ftp.your-domain.com.au", "UserID", "password", "/wwwroot", "*.mdb","z:\test\")

■■■ ファイル削除 (saDelFTP) ■■■
《引数》
・Host Name、UserID、password、Host Folder、Target File
 - Target Fileは、|をセパレータとして複数指定できます
 - Target Fileにワイルドカード(*/?が)が使用可能です
・リターンコード(long)にエラーコードが返ります

《サンプル》
r = saDelFTP("ftp.your-domain.com.au", "UserID", "password", "/wwwroot", "*.mdb")

■■■ ファイル名変更 (saRenFTP) ■■■
《引数》
・Host Name、UserID、password、Host Folder、Target File、New Name
 - Target File、New Nameは、|をセパレータとして複数指定できます
・リターンコード(long)にエラーコードが返ります

《サンプル》
r = saRenFTP("ftp.your-domain.com.au", "UserID", "password", "/wwwroot", "A.mda","A.mdb")

■■■ フォルダ削除 (saRemDirFTP) ■■■
《引数》
・Host Name、UserID、password、Host Folder、Target Folder
・リターンコード(long)にエラーコードが返ります

《サンプル》
r = saRemDirFTP("ftp.your-domain.com.au", "UserID", "password", "/wwwroot", "DB")

■■■ ファイル一覧 (saGetListFTP) ■■■
《引数》
・Host Name、UserID、password、Host Folder、Searchコマンド、配列
・配列には、日付 + ”\” + ファイル名
 フォルダの場合は、最後に"/"が付加されます
・リターンコード(long)にエラーコードが返ります

《サンプル》
Dim a() As String
r = saGetListFTP("192.168.0.172", "regi", "Creqagah0", "/Work", "*.*", a)
If r = 0 Then
 For i = 0 To UBound(a)
  Debug.Print a(i)
 Next
Else
 Debug.Print r
End If

【その他】
WinInetのエラーコード一覧はこちら
 https://support.microsoft.com/ja-jp/help/193625/info-wininet-error-codes-12001-through-12156

【特記事項】
・IISでのみテストを行っています

  お気軽にご相談ください お問合せ・ご相談はこちら お問合せ・ご相談はこちら  
更新日:2017/03/04 10:37