| |
Public Const strAgent = "Lightbox"
' ------------------------------------------------------
' インターネットセッション
' ------------------------------------------------------
Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long _
) As Long
' ------------------------------------------------------
' セッションクローズ
' ------------------------------------------------------
Public Declare Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As Long _
) As Integer
' ------------------------------------------------------
' インターネット接続
' ------------------------------------------------------
Public Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long _
) As Long
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_INVALID_PORT_NUMBER = 0
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_FLAG_PASSIVE = &H8000000
Const ERROR_NO_MORE_FILES = 18
Const MAX_PATH = 260
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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
' ------------------------------------------------------
' 属性
' ------------------------------------------------------
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Const FILE_ATTRIBUTE_OFFLINE = &H1000
' ------------------------------------------------------
' 初回検索
' ------------------------------------------------------
Public Declare 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
' ------------------------------------------------------
' ２件目以降の検索
' ------------------------------------------------------
Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" ( _
ByVal hFind As Long, _
lpvFindData As WIN32_FIND_DATA _
) As Long
' ------------------------------------------------------
' 日付処理用
' ------------------------------------------------------
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Declare Function FileTimeToSystemTime Lib "kernel32" ( _
lpFiletime As FILETIME, _
lpSystemTime As SYSTEMTIME _
) As Long
Declare Function FileTimeToLocalFileTime Lib "kernel32" ( _
lpFiletime As FILETIME, _
lpLocalFileTime As FILETIME _
) As Long
' ------------------------------------------------------
' ダウンロード
' ------------------------------------------------------
Public Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, _
ByVal fFailIfExists As Boolean, _
ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long _
) As Boolean
' ------------------------------------------------------
' フラグ
' ------------------------------------------------------
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_FLAG_RELOAD = &H80000000
' ------------------------------------------------------
' アップロード
' ------------------------------------------------------
Public Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long _
) As Boolean
' ------------------------------------------------------
' 関数用グローバル
' ------------------------------------------------------
Global hSes As Long
Global hCon As Long
' ******************************************************
' 接続
' ******************************************************
Public Function lbFTPConnect( _
Server As String, _
User As String, _
Password As String, _
bPassive As Boolean _
) As Boolean
hSes = InternetOpen(strAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If hSes = 0 Then
lbFTPConnect = False
Exit Function
End If
Dim nPassive As Long
If bPassive Then
nPassive = INTERNET_FLAG_PASSIVE
Else
nPassive = 0
End If
hCon = InternetConnect( _
hSes, _
Server, _
INTERNET_INVALID_PORT_NUMBER, _
User, _
Password, _
INTERNET_SERVICE_FTP, _
nPassive, _
0 _
)
If hCon = 0 Then
lbFTPConnect = False
Call InternetCloseHandle(hSes)
Exit Function
End If
lbFTPConnect = True
End Function
' ******************************************************
' 接続解除
' ******************************************************
Public Function lbFTPDisconnect()
Call InternetCloseHandle(hCon)
Call InternetCloseHandle(hSes)
End Function
' ******************************************************
' 一覧の取得
' ******************************************************
Public Function lbFTPEnum( _
strDirectory As String, _
strTarget As String, _
Grid As Object _
) As Long
Dim bFirst As Boolean
Dim lpData As WIN32_FIND_DATA
Dim hFind As Long
Dim nRet As Long
Dim nLastDllError As Long
bFirst = True
Grid.Clear
Grid.Cols = 8
Grid.Rows = 2
With Grid
.TextMatrix(0, 1) = "FileName"
.TextMatrix(0, 2) = "CreationTime"
.TextMatrix(0, 3) = "LastAccessTime"
.TextMatrix(0, 4) = "LastWriteTime"
.TextMatrix(0, 5) = "FileAttributes"
.TextMatrix(0, 6) = "FileName"
.TextMatrix(0, 7) = "FileSizeLow"
End With
Do
If bFirst Then
bFirst = False
hFind = FtpFindFirstFile(hCon, strDirectory & "/" & strTarget, lpData, 0, 0)
nLastDllError = Err.LastDllError
If hFind = 0 Then
If (nLastDllError = ERROR_NO_MORE_FILES) Then
lbFTPEnum = 0
Else
lbFTPEnum = -1
End If
Exit Function
End If
Else
nRet = InternetFindNextFile(hFind, lpData)
nLastDllError = Err.LastDllError
If nRet = 0 Then
If (nLastDllError = ERROR_NO_MORE_FILES) Then
Exit Do
Else
lbFTPEnum = -1
Call InternetCloseHandle(hFind)
Exit Function
End If
End If
Grid.Rows = Grid.Rows + 1
End If
With Grid
.TextMatrix(.Rows - 1, 0) = .Rows - 1
.TextMatrix(.Rows - 1, 1) = lpData.cFileName
.TextMatrix(.Rows - 1, 2) = StringDateTime(lpData.ftCreationTime)
.TextMatrix(.Rows - 1, 3) = StringDateTime(lpData.ftLastAccessTime)
.TextMatrix(.Rows - 1, 4) = StringDateTime(lpData.ftLastWriteTime)
.TextMatrix(.Rows - 1, 5) = Hex(lpData.dwFileAttributes)
.TextMatrix(.Rows - 1, 6) = lpData.cFileName
.TextMatrix(.Rows - 1, 7) = lpData.nFileSizeLow
End With
Loop
Call InternetCloseHandle(hFind)
With Grid
.Col = 5
.ColSel = 6
.Sort = 1
End With
lbFTPEnum = Grid.Rows - 1
End Function
' ******************************************************
' FILETIMEを文字列に変換
' ******************************************************
Public Function StringDateTime(lpFiletime As FILETIME) As String
Dim lpSystemTime As SYSTEMTIME
Call FileTimeToSystemTime(lpFiletime, lpSystemTime)
StringDateTime = _
Format(lpSystemTime.wYear, "0000") & "/" & _
Format(lpSystemTime.wMonth, "00") & "/" & _
Format(lpSystemTime.wDay, "00") & " " & _
Format(lpSystemTime.wHour, "00") & ":" & _
Format(lpSystemTime.wMinute, "00") & ":" & _
Format(lpSystemTime.wSecond, "00")
End Function
' ******************************************************
' ダウンロード
' ******************************************************
Public Function lbFTPDownload( _
RemoteTarget As String, _
LocalTarget As String _
) As String
Dim bRet As Boolean
Dim nLastDllError As Long
bRet = FtpGetFile( _
hCon, _
RemoteTarget, _
LocalTarget, _
False, _
FILE_ATTRIBUTE_NORMAL, _
FTP_TRANSFER_TYPE_BINARY Or INTERNET_FLAG_RELOAD, _
0)
nLastDllError = Err.LastDllError
If bRet Then
lbFTPDownload = ""
Else
lbFTPDownload = "(" & nLastDllError & ") " & Err.Description
End If
End Function
' ******************************************************
' アップロード
' ******************************************************
Public Function lbFTPUpload( _
RemoteTarget As String, _
LocalTarget As String _
) As String
Dim bRet As Boolean
Dim nLastDllError As Long
bRet = FtpPutFile( _
hCon, _
LocalTarget, _
RemoteTarget, _
FTP_TRANSFER_TYPE_BINARY, _
0)
nLastDllError = Err.LastDllError
If bRet Then
lbFTPUpload = ""
Else
lbFTPUpload = "(" & nLastDllError & ") " & Err.Description
End If
End Function
| |
