FTPに関して (ID:91949)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

VB6でFTPを作っていまして、
InternetGetLastResponseInfoの使い方がよくわかりません。
エラーが０にしかなりません。
どこを直せばいいかよくわかりません。
よろしくお願いします。
----clsFTP----
Option Explicit

Private lngInethnd As Long       'InterNet Open Handle
    Private lngFtphnd As Long        'InterNet Connect Handle

Private msFtpSvr As String              'FTP Server IP
    Private msFtpDir As String              'FTP Server Dir
    Private msFtpUid As String              'FTP Login UserID
    Private msFtpPwd As String              'FTP Login Password
    Private msFtpFilNm As String            'FTP Target FileName
    Private msFtpLclDir As String           'FTP Local Dir
    Private msFtpSvrFile As String          'FTP Server File

'AccessType
    Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0&       'use registry configuration
    Private Const INTERNET_OPEN_TYPE_DIRECT = 1&          'direct to net
    Private Const INTERNET_OPEN_TYPE_PROXY = 3&           'via named proxy

'File Attribute
    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&

'FTP TransferType
    Private Const FTP_TRANSFER_TYPE_ASCII = &H1&
    Private Const FTP_TRANSFER_TYPE_BINARY = &H2&

'Cache Flags
    Private Const INTERNET_FLAG_RELOAD = &H80000000       'サーバからダウンロードを強制
    Private Const INTERNET_FLAG_DONT_CACHE = &H4000000    'キャッシュに加えない
    Private Const INTERNET_FLAG_RESYNCHRONIZE = &H800     'すべてを再読み込み
    Private Const INTERNET_FLAG_NEED_FILE = &H10          'キャッシュできないときテンポラリ生成
    Private Const INTERNET_FLAG_HYPERLINK = &H400         'リロードを強制

'ConnectServerPort
    Private Const INTERNET_INVALID_PORT_NUMBER = 0        'use the protocol-specific default
    Private Const INTERNET_DEFAULT_FTP_PORT = 21          'default for FTP servers
    Private Const INTERNET_DEFAULT_GOPHER_PORT = 70       'default for Gopher servers
    Private Const INTERNET_DEFAULT_HTTP_PORT = 80         'default for HTTP servers
    Private Const INTERNET_DEFAULT_HTTPS_PORT = 443       'default for HTTPS servers
    Private Const INTERNET_DEFAULT_SOCKS_PORT = 1080      'default for SOCKS firewall servers

'ConnectService
    Private Const INTERNET_SERVICE_FTP = 1&               'FTP
    Private Const INTERNET_SERVICE_GOPHER = 2&            'Gopher
    Private Const INTERNET_SERVICE_HTTP = 3&              'HTTP

'WinInet を初期化
    Private Declare 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

'(FTP, HTTP, Gopher)サービスに接続する
    Private Declare 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

'カレントディレクトリを変更
    Private Declare Function FtpSetCurrentDirectory Lib "Wininet.DLL" _
            Alias "FtpSetCurrentDirectoryA" _
           (ByVal hFtpSession As Long, ByRef lpszDirectory As Byte) As Long

'ファイルをサーバにコピー
    Private Declare 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

'ファイルをローカルディスクにコピー
    Private Declare Function FtpGetFile Lib "Wininet.DLL" _
            Alias "FtpGetFileA" _
           (ByVal hFtpSession As Long, ByRef lpszRemoteFile As Byte, _
            ByRef lpszNewFile As Byte, ByVal fFailIfExists As Long, _
            ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, _
            ByVal dwContext As Long) As Long

'WinInet で作成したハンドルをクローズ
    Private Declare Function InternetCloseHandle Lib "Wininet.DLL" _
           (ByVal hInternet As Long) As Long
    
    'WinInet で作成したハンドルのステータスを取得する
    Private Declare Function InternetGetLastResponseInfo Lib "Wininet.DLL" Alias "InternetGetLastResponseInfoA" ( _
    lpdwError As Long, _
    ByRef lpszBuffer As String, _
    lpdwBufferLength As Long) As Boolean

'FTPコマンド実行
    Private Declare Function FtpCommand Lib "Wininet.DLL" Alias "FtpCommandA" _
    (ByVal hConnect As Long, _
     fExpectResponse As Long, _
     ByVal dwFlags As Long, _
     ByRef lpszCommand As Byte, _
     ByVal dwContext As Long, _
     ByRef phFtpCommand As Long) As Long

'ファイルをサーバーから削除
    Private Declare Function FtpDeleteFile Lib "Wininet.DLL" Alias "FtpDeleteFileA" ( _
    ByVal hFtpSession As Long, _
    ByRef lpszFileName As Byte) As Long

'    ByVal lpszBuffer As String, _
'BOOL InternetGetLastResponseInfo(
'    OUT LPDWORD lpdwError,
'    OUT LPSTR lpszBuffer,
'    IN OUT LPDWORD lpdwBufferLength
');

'-----------------------------------------------------------------------------------------------------

' 入力プロパティー
Public Property Let FtpServer(pFtpSvr As String)
    msFtpSvr = pFtpSvr
End Property

Public Property Let FtpSvrDir(pFtpSvrDir As String)
    msFtpDir = pFtpSvrDir
End Property

Public Property Let FtpUser(pFtpUser As String)
    msFtpUid = pFtpUser
End Property

Public Property Let FtpPwd(pFtpPwd As String)
    msFtpPwd = pFtpPwd
End Property

Public Property Let FtpLocalFileName(pFtpFilNm As String)
    msFtpFilNm = pFtpFilNm
End Property

Public Property Let FtpLocalFilePath(pFtpFilePath As String)
    msFtpLclDir = pFtpFilePath
End Property

Public Property Let FtpSvrFile(pFtpSvrFile As String)
    msFtpSvrFile = pFtpSvrFile
End Property

' 出力プロパティー
Public Property Get FtpServer() As String
    FtpServer = msFtpSvr
End Property

Public Property Get FtpSvrDir() As String
    FtpSvrDir = msFtpDir
End Property

Public Property Get FtpUser() As String
    FtpUser = msFtpUid
End Property

Public Property Get FtpPwd() As String
    FtpPwd = msFtpDir
End Property

Public Property Get FtpLocalFileName() As String
    'FtpFileName = msFtpFilNm
End Property

Public Property Get FtpLocalFilePath() As String
    'FtpFilePath = msFtpLclDir
End Property

Public Property Get FtpSvrFile() As String
    FtpSvrFile = msFtpSvrFile
End Property

Public Function ConnectFtpServer() As Integer
    
    Dim lngRet As Long          '戻り値

On Error GoTo FTPDATAGETINI_ERR

'InternetOpen (Handle を取得)
    lngInethnd = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
                                            vbNullString, vbNullString, 0)

'InternetConnect (上記で取得した Handle で FTP Server に Connect)
    lngFtphnd = InternetConnect(lngInethnd, msFtpSvr, INTERNET_DEFAULT_FTP_PORT, _
                                            msFtpUid, msFtpPwd, INTERNET_SERVICE_FTP, 0, 0)

ConnectFtpServer = 0
    If lngFtphnd = 0 Then
        MsgBox "サーバ接続出来ませんでした"
        ConnectFtpServer = 1
        End
    End If
    Exit Function
    
FTPDATAGETINI_ERR:

'InternetConnect がされた後なのか判断
    If lngFtphnd <> 0 Then
        'Internet Handle Close 処理
        lngRet = InternetCloseHandle(lngFtphnd)
    End If
    
    ConnectFtpServer = 1

End Function

Public Function PutFile() As Integer
    
    Dim lngRet As Long          '戻り値
    Dim bytFtpBuff() As Byte    'UpLoad したい FTP Server 内の Directory
    Dim bytLclBuff() As Byte    'UpLoad したいファイル名
    Dim bytSvrBuff() As Byte    'UpLoad したいサーバーファイル名
    Dim bytCommand() As Byte
    Dim hResponse As Long
    
On Error GoTo FTPDATAGETINI_ERR

'UpLoad したい FTP Server 内の Directory
    bytFtpBuff = StrConv((msFtpDir & vbNullChar), vbFromUnicode)

'FTP Server の CurrentDirectory を変更
    lngRet = FtpSetCurrentDirectory(lngFtphnd, bytFtpBuff(0))

If lngRet = False Then
        MsgBox "サーバーのディレクトリ変更に失敗しました" & vbCrLf & "error = " & lngRet, vbCritical, "FTP ERROR"
        PutFile = 1
        Exit Function
    End If
    
    'Fileの有無をチェック
    If Dir(msFtpLclDir & "\" & msFtpFilNm) = "" Then
        MsgBox "送信元のファイルが存在しません", vbCritical, "FTP ERROR"
        PutFile = 1
    End If
    
    
    'Local の CurrentDrive を変更
    ChDrive (Mid(msFtpLclDir, 1, 2))

'Local の CurrentDirectory を変更
    ChDir (Mid(msFtpLclDir, 3, Len(msFtpLclDir)))

'UpLoad したいファイルの名前
    bytLclBuff = StrConv((msFtpFilNm & vbNullChar), vbFromUnicode)
    
    'UpLoad したいサーバーファイルの名前
    bytSvrBuff = StrConv((msFtpSvrFile & vbNullChar), vbFromUnicode)

'UpLoad (BINARY-MODEの場合)
    lngRet = FtpPutFile(lngFtphnd, bytLclBuff(0), bytSvrBuff(0), _
                                    FTP_TRANSFER_TYPE_BINARY, 1)

PutFile = 0
    If lngRet = False Then
        MsgBox "ファイルの出力に失敗しました" & vbCrLf & "error = " & lngRet, vbCritical, "FTP ERROR"
        Call DelFile
        PutFile = 1
    Else
        MsgBox "ファイルの出力に成功しました"
    End If
    
    'UPLOADファイルのパーミッション変更
'    bytCommand = StrConv(("site chmod 777 " & msFtpSvrFile & vbNullChar), vbFromUnicode)
'    lngRet = FtpCommand(lngFtphnd, 1, FTP_TRANSFER_TYPE_ASCII, bytCommand(0), 0, hResponse)
    
    Exit Function
    
FTPDATAGETINI_ERR:

'InternetConnect がされた後なのか判断
    If lngFtphnd <> 0 Then
        'Internet Handle Close 処理
        lngRet = InternetCloseHandle(lngFtphnd)
    End If

PutFile = 1
    
End Function

Public Function GetFile() As Integer
    Dim lngRet As Long          '戻り値
    Dim strLclDir As String     'DownLoad したファイルを保存する Directory
    Dim bytFtpBuff() As Byte    'FTP Server 内の Download するファイル名
    Dim bytLclBuff() As Byte    'Download したファイルを保存するファイル名
    
    Dim lngResponse As Long
    Dim strResponse As String
    Dim lngLength As Long
    
    On Error GoTo FTPDATAGETINI_ERR

'FTP Server の取得ファイルが存在する Directory
    bytFtpBuff = StrConv((msFtpDir & vbNullChar), vbFromUnicode)

'FTP Server の CurrentDirectory を変更
    lngRet = FtpSetCurrentDirectory(lngFtphnd, bytFtpBuff(0))

'FTP Server から取得するファイルの名前
    bytFtpBuff = StrConv((msFtpSvrFile & vbNullChar), vbFromUnicode)

'DownLoad 先をフルパスで指定
    strLclDir = msFtpLclDir & IIf(Right(msFtpLclDir, 1) = "\", "", "\") & msFtpFilNm
    bytLclBuff = StrConv((strLclDir & vbNullChar), vbFromUnicode)
'    strLclDir = "e:\teruteru.txt"
'    bytLclBuff = StrConv((strLclDir & vbNullChar), vbFromUnicode)

'ローカルに、すでに同一ファイル名が存在する場合は削除
    If Dir(strLclDir) <> "" Then
        Kill strLclDir
    End If
    lngRet = 0

'DownLoad (ASCII-MODEの場合＆キャッシュを使わずサーバからダウンロードを強制)
    lngRet = FtpGetFile(lngFtphnd, bytFtpBuff(0), bytLclBuff(0), 1, FILE_ATTRIBUTE_NORMAL, _
                                                  FTP_TRANSFER_TYPE_BINARY Or INTERNET_FLAG_RELOAD, 0)

GetFile = 0
    
    If lngRet = False Then
        MsgBox "ファイルの出力に失敗しました" & vbCrLf & "error = " & lngRet, vbCritical, "FTP ERROR"
        lngRet = InternetGetLastResponseInfo(lngResponse, strResponse, lngLength)
        GetFile = 1
    Else
        MsgBox "ファイルの出力に成功しました"
    End If

Exit Function

FTPDATAGETINI_ERR:

'InternetConnect がされた後なのか判断
    If lngFtphnd <> 0 Then
        'Internet Handle Close 処理
        lngRet = InternetCloseHandle(lngFtphnd)
    End If

GetFile = 1

End Function

Public Function DelFile() As Integer
    Dim lngRet As Long          '戻り値
    Dim bytFtpBuff() As Byte    'FTP Server 内の Delete するファイル名

On Error GoTo FTPDATADELINI_ERR

'FTP Server の取得ファイルが存在する Directory
    bytFtpBuff = StrConv((msFtpDir & vbNullChar), vbFromUnicode)

'FTP Server の CurrentDirectory を変更
    lngRet = FtpSetCurrentDirectory(lngFtphnd, bytFtpBuff(0))

'FTP Server から取得するファイルの名前
    bytFtpBuff = StrConv((msFtpSvrFile & vbNullChar), vbFromUnicode)

lngRet = 0

'ファイルの削除
    lngRet = FtpDeleteFile(lngFtphnd, bytFtpBuff(0))

DelFile = 0
    
'    If lngRet = False Then
'        MsgBox "ファイルの削除に失敗しました" & vbCrLf & "error = " & lngRet, vbCritical, "FTP ERROR"
'        DelFile = 1
'    End If
    
    Exit Function

FTPDATADELINI_ERR:

'InternetConnect がされた後なのか判断
    If lngFtphnd <> 0 Then
        'Internet Handle Close 処理
        lngRet = InternetCloseHandle(lngFtphnd)
    End If

DelFile = 1

End Function

Public Function ConnectClose() As Integer

Dim lngRet As Long          '戻り値

'InternetConnect がされた後なのか判断
    If lngFtphnd <> 0 Then
        'Internet Handle Close 処理
        lngRet = InternetCloseHandle(lngFtphnd)
    End If

End Function

←解決時は質問者本人がここをチェックしてください。

戻る