'***************************************************************************************************
' FTPでファイル一覧を取得する Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'06/01/14(1.00)新規作成
'20/03/02(1.10)*.xlsm化、他
'***************************************************************************************************
Option Explicit
'===================================================================================================
Public Const g_cnsTEST As Integer = 1 ' テストモ-ド
'Public Const g_cnsTEST As Integer = 0 ' 本番モード(Debug出力なし)
'---------------------------------------------------------------------------------------------------
Private tblPath(1 To 50) As String ' フォルダ名表示用テーブル
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :TEST_FTP
'* 機能 :FTPでファイル一覧を取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年01月14日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub TEST_FTP()
'-----------------------------------------------------------------------------------------------
Dim objFTP As Object ' BASP21.FTP
Dim vntRet As Variant ' 処理結果
Dim swOpen As Boolean ' 接続判定
Dim blnResult As Boolean ' フォーム登録結果
Dim strAddr As String ' 接続先ホストアドレス
Dim strUser As String ' 接続ユーザー名
Dim strPass As String ' パスワード
Dim strRoot As String ' ホスト側ルートフォルダ
Dim strMSG As String ' メッセージWORK
'-----------------------------------------------------------------
On Error Resume Next
Set objFTP = CreateObject("BASP21.FTP")
' 接続失敗は終了(未インストール等)
If Err.Number <> 0 Then
MsgBox "「BASP21」に接続できません。"
Exit Sub
End If
On Error GoTo 0
'-----------------------------------------------------------------
' ユーザーフォーム(FRM_FTP)から接続情報を受け取る
With FRM_FTP
' ユーザーフォームを表示
.Show
blnResult = .prpResult
' 登録されたか
If blnResult Then
strAddr = .prpAddr
strUser = .prpUser
strPass = .prpPass
strRoot = .prpRoot
End If
End With
Unload FRM_FTP
' フォーム上でキャンセルされたら終了
If Not blnResult Then GoTo TEST_FTP_EXIT
'-----------------------------------------------------------------
' ホスト接続
vntRet = objFTP.Connect(strAddr, strUser, strPass)
strMSG = objFTP.GetReply()
' 接続不成功か
If vntRet <> 0 Then
MsgBox "FTPサーバ(" & strAddr & ")接続不成功, Rc=" & vntRet & vbCr & strMSG
GoTo TEST_FTP_EXIT
End If
swOpen = True
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print strMSG
' ↑↑↑テストモ-ド対応↑↑↑
ActiveSheet.Cells.ClearContents
'=================================================================
' ルートフォルダより処理開始
Call GP_FTP_GetDir(objFTP, strRoot, 1, 1)
'=================================================================
' ホスト切断(QUIT発行)
vntRet = objFTP.Command("QUIT")
strMSG = objFTP.GetReply()
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print strMSG
' ↑↑↑テストモ-ド対応↑↑↑
If swOpen = True Then objFTP.Close
'===================================================================================================
' 終了
TEST_FTP_EXIT:
Application.StatusBar = False
Set objFTP = Nothing
ThisWorkbook.Saved = True
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_FTP_GetDir
'* 機能 :フォルダ単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = BASP21.FTP(Object)
'* Arg2 = フォルダ名(String)
'* Arg3 = シート上の行(Long) ※Ref参照
'* Arg4 = シート上の列(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年01月14日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:本処理は再帰動作、サンプルのため処理例外対応無し
'***************************************************************************************************
Private Sub GP_FTP_GetDir(ByRef objFTP As Object, _
ByVal strPath As String, _
ByRef lngRow As Long, _
ByVal lngCol As Long)
'-----------------------------------------------------------------------------------------------
Dim vntRet As Variant ' 処理結果
Dim lngIx As Long ' テーブルINDEX
Dim strCMDText As String ' FTPコマンド
Dim strPath2 As String ' フォルダパス(編集)
' ↓↓↓テストモ-ド対応↓↓↓
' ※テストモードでは100件を超えたら下層のフォルダ探索は打ち切り
If ((g_cnsTEST = 1) And (lngRow > 100)) Then Exit Sub
' ↑↑↑テストモ-ド対応↑↑↑
'-----------------------------------------------------------------
' フォルダ名(階層状態を編集)を表示
lngIx = 2
Do While lngIx < lngCol
strPath2 = strPath2 & tblPath(lngIx) & "/"
lngIx = lngIx + 1
Loop
strPath2 = strPath2 & strPath
Application.StatusBar = strPath2 & " 処理中...."
' フォルダ名を登録
Cells(lngRow, lngCol).Value = "[" & strPath & "]" ' 自フォルダ名
tblPath(lngCol) = strPath
' 行・列を加算
lngRow = lngRow + 1
lngCol = lngCol + 1
'-----------------------------------------------------------------
' 当該フォルダに移動
strCMDText = "CWD " & strPath
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print strCMDText
' ↑↑↑テストモ-ド対応↑↑↑
vntRet = objFTP.Command(strCMDText)
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print objFTP.GetReply()
' ↑↑↑テストモ-ド対応↑↑↑
' 配下のサブフォルダを取得
vntRet = objFTP.GetDir("", 1)
' 配列が作成されたか
If IsArray(vntRet) Then
For lngIx = LBound(vntRet) To UBound(vntRet)
' 下層のフォルダを参照(再帰呼び出し)
Call GP_FTP_GetDir(objFTP, Trim(vntRet(lngIx)), lngRow, lngCol)
Next lngIx
Else
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print objFTP.GetReply()
' ↑↑↑テストモ-ド対応↑↑↑
End If
'-----------------------------------------------------------------
' 本フォルダのファイルリストを作成
vntRet = objFTP.GetDir("", 2)
' 配列が作成されたか
If IsArray(vntRet) Then
For lngIx = LBound(vntRet) To UBound(vntRet)
' ファイルである条件を抽出(これが全てかは不明)
If ((Left(vntRet(lngIx), 1) <> "d") And _
(InStr(1, vntRet(lngIx), "<DIR>", vbTextCompare) = 0)) Then
' ファイル情報を登録
Cells(lngRow, lngCol).Value = vntRet(lngIx)
' 次の行へ
lngRow = lngRow + 1
End If
Next lngIx
Else
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print objFTP.GetReply()
' ↑↑↑テストモ-ド対応↑↑↑
End If
'-----------------------------------------------------------------
' 上位フォルダに移動
strCMDText = "CDUP"
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print strCMDText & "[" & strPath2 & "]"
' ↑↑↑テストモ-ド対応↑↑↑
vntRet = objFTP.Command(strCMDText)
' ↓↓↓テストモ-ド対応↓↓↓
If g_cnsTEST = 1 Then Debug.Print objFTP.GetReply()
' ↑↑↑テストモ-ド対応↑↑↑
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
' FTPでファイル一覧を取得する FRM_FTP(UserForm)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'06/01/14(1.00)新規作成
'20/03/02(1.10)*.xlsm化、他
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private g_strAddr As String ' 接続先ホストアドレス
Private g_strUser As String ' 接続ユーザー名
Private g_strPass As String ' パスワード
Private g_strRoot As String ' ホスト側ルートフォルダ
Private g_blnResult As Boolean ' 処理結果
'***************************************************************************************************
' ■■■ コントロールイベント ■■■
'***************************************************************************************************
'* 処理名 :CMD_OK_Click
'* 機能 :「処理開始」ボタンイベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年01月14日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CMD_OK_Click()
'-----------------------------------------------------------------------------------------------
g_strAddr = Trim(TXT_ADDR.Text) ' 接続先ホストアドレス
g_strUser = Trim(TXT_USER.Text) ' 接続ユーザー名
g_strPass = Trim(TXT_PASS.Text) ' パスワード
g_strRoot = Trim(TXT_ROOT.Text) ' ホスト側ルートフォルダ
g_blnResult = True ' 処理結果
Me.Hide
End Sub
'***************************************************************************************************
' ■■■ フォームイベント ■■■
'***************************************************************************************************
'* 処理名 :UserForm_Initialize
'* 機能 :フォーム初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年01月14日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Initialize()
'-----------------------------------------------------------------------------------------------
If g_cnsTEST = 1 Then
' テストモード
TXT_ADDR.Text = "ftp.hoge.co.jp"
TXT_USER.Text = "anonymous"
TXT_PASS.Text = "hoge@hoge.co.jp"
TXT_ROOT.Text = "Pub"
Else
' 本番モード
TXT_ADDR.Text = ""
TXT_USER.Text = ""
TXT_PASS.Text = ""
TXT_ROOT.Text = ""
End If
g_blnResult = False
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_QueryClose
'* 機能 :ユーザーフォーム閉鎖動作
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年01月14日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'-----------------------------------------------------------------------------------------------
' 閉じる[×]ボタンか
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub
'***************************************************************************************************
' ■■■ プロパティ ■■■
'***************************************************************************************************
' 接続先ホストアドレス
'---------------------------------------------------------------------------------------------------
Friend Property Get prpAddr() As String
prpAddr = g_strAddr
End Property
'===================================================================================================
' 接続ユーザー名
'---------------------------------------------------------------------------------------------------
Friend Property Get prpUser() As String
prpUser = g_strUser
End Property
'===================================================================================================
' パスワード
'---------------------------------------------------------------------------------------------------
Friend Property Get prpPass() As String
prpPass = g_strPass
End Property
'===================================================================================================
' ホスト側ルートフォルダ
'---------------------------------------------------------------------------------------------------
Friend Property Get prpRoot() As String
prpRoot = g_strRoot
End Property
'===================================================================================================
' 処理結果
'---------------------------------------------------------------------------------------------------
Friend Property Get prpResult() As Boolean
prpResult = g_blnResult
End Property
'----------------------------------------<< End of Source >>----------------------------------------