VBAでFTPファイルアップロード

VBAを使って、ファイルをプットするためのプログラム。
これにはBASP21をインストールしておく必要がある。

使用用途としては、FTPのアカウントを教えたくない人に対して
これを使って、指定の位置へファイルをアップロードさせるためのもの。

HTML5になってからは、不要になりましたがIE8などは
まだ、FILE POSTにMultiが対応していないので、使えるのかなぁ～？

まぁ、VBAなのでプロジェクト保護してても、パスワードは抜き取られちゃうので
セキュリティ的には、ヘボヘボですが・・・・

一応、忘れないためにメモ。

Sub picture_uploader()
    Dim FTP, rc As Long, Server As String, User As String, Pass As String
    Dim Target As String, Folder As String
    Dim a           As String
    Dim folder_path As Object
    'FTPオブジェクト
   
    'TAKARA FTP設定(設定する場合は「'」を外してください。)
    Server = "ホスト"
    User = "ユーザーID"
    Pass = "ユーザーパスワード"

    Set folder_path = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 1, ",")
    If Not folder_path Is Nothing Then
        a = folder_path.Items.Item.Path
    End If
    If a = "" Then
        MsgBox "参照先が選択されませんでした。"
        Range("B1") = ""
        End
    Else
        fp = a
        Range("A1") = fp
        With Application.FileSearch
            .LookIn = fp
            .SearchSubFolders = True
            .FileType = msoFileTypeAllFiles
            .Filename = ".jpg"
            If .Execute(SortBy:=msoSortByFileName, _
                SortOrder:=msoSortOrderAscending) > 0 Then
                MsgBox .FoundFiles.Count & "個のファイルが見つかりました。"
                For i = 1 To .FoundFiles.Count
                    fname = .FoundFiles(i)
                    d = Len(fp)
                    fname1 = Len(fname)
                    fname2 = Right(fname, fname1 - d - 1)
                    'フォルダパス1を画像名から取り出す
                    'f_path1 = Len(fname2)
                    'f_path1_1 = Right(fname2, f_path1 - 3)
                    'f_path1_2 = Len(f_path1_1)
                    'f_path1 = Left(fname2, f_path1 - f_path1_2)
                    'フォルダパス2を画像名から取り出す
                    f_path2 = Replace(fname2, ".jpg", "")
                    f_path2_1 = Len(f_path2)
                    f_path2 = Left(f_path2, f_path2_1)
                    'Cells(i + 1, 2).Value = "/" & f_path1 & "/" & f_path2 & "/"
                    Cells(i + 1, 2).Value = fname2 'ファイル名
                Next i
            Else
                    MsgBox "条件を満たすファイルはありません。"
            End If
        End With

   
        Set FTP = CreateObject("basp21.ftp")
        'サーバー接続
        rc = FTP.Connect(Server, User, Pass)
        If rc <> 0 Then
            MsgBox "接続できませんでした。", vbCritical
            FTP.Close
            Exit Sub
        End If
        For i = 2 To 65536
            Range("B" & i).Activate
           
            If Range("B" & i) = "" Then
                Exit For
            Else
                'ローカルファイルの場所
                Target = Range("A1") & "\" & Range("B" & i)
                'FTP送信先
                Folder = "/IMAGES/"
           
                rc = FTP.PutFile(Target, Folder, 1)
                If rc <> 1 Then
                    MsgBox Range("B" & i) & "の画像がアップロード出来ませんでした。", vbCritical
                    FTP.Close
                    Exit Sub
                Else
                    Range("C" & i) = "OK"
                End If
            End If
        Next
        MsgBox "全ての画像がアップロード出来ました。", vbInformation
        FTP.Close
        Set FTP = Nothing
    End If
End Sub