Private Declare Function InternetOpenS _
          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 Function InternetConnectS 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 Function FtpSetCurrentDirectoryS _
          Lib "WinInet.DLL" Alias "FtpSetCurrentDirectoryA" _
          (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Private Declare Function FtpPutFileB _
          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
Private Declare Function InternetCloseHandle _
          Lib "WinInet.DLL" _
          (ByVal hInet As Long) As Long

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

Sub FTP_Upload()
'FTPアップロードの例

  Const cstrServer As String = "******.com"   'FTPサーバー名
  Const cstrUserName As String = "******"     'アカウント名
  Const cstrPassword As String = "******"     'パスワード

  Dim strDir As String
  Dim strFrom As String
  Dim strTo As String
  Dim abytFrom() As Byte
  Dim abytTo() As Byte
  Dim lngInet As Long
  Dim lngFTP As Long
  Dim lngRet As Long

  'アップロード先ディレクトリを設定
  strDir = "homepage/images/"
  'アップロード元ファイル名を設定
  strFrom = "c:\image.gif"
  'アップロード先ファイル名を設定
  strTo = "image.gif"

  'FTPをオープン
  lngInet = InternetOpenS(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
                          vbNullString, vbNullString, 0&)
  If lngInet <> 0 Then
    '成功したらFTPサーバーに接続
    lngFTP = InternetConnectS(lngInet, cstrServer, _
                              INTERNET_DEFAULT_FTP_PORT, _
                              cstrUserName, cstrPassword, _
                              INTERNET_SERVICE_FTP, 0&, 0&)
    If lngFTP <> 0 Then
      '成功したとき
      'アップロード先ディレクトリへ移動
      FtpSetCurrentDirectoryS lngFTP, strDir
      'ファイル名をUnicodeから変換
      abytFrom = StrConv((strFrom & vbNullChar), vbFromUnicode)
      abytTo = StrConv((strTo & vbNullChar), vbFromUnicode)
      'ファイルをバイナリモードでアップロード
      '（ASCIIモードの場合はTRANSFER_TYPE_ASCIIを指定）
      lngRet = FtpPutFileB(lngFTP, abytFrom(0), abytTo(0), _
                            FTP_TRANSFER_TYPE_BINARY, 0&)
      If lngRet <> 0 Then
        '成功したとき
        MsgBox "ファイルのアップロードに成功しました！", vbOKOnly + vbInformation
      End If
    End If
    'FTPをクローズ
    InternetCloseHandle lngInet
  End If

End Sub