ファイルシステムへアクセスする制御ライブラリーなので、ワークシートと全く無関係に操作できるプログラミング ー ファイルシステムオブジェクト（その三 ）（VBA - FileSystem Object）

　　　

以前に投稿したその一と二で、プログラムに関わる概要を説明しておきました。

これを踏まえて、実際に書き上げたコードを今回の投稿で紹介するこにします。

このプログラムは、ファイル読み込み時、ユーザーフォームのみ立ち上げます。

そして、コード記述は、本体の”ThisWorkbook”と"UserForm1"に分かれます。

移動するフォルダーと移動先を指定し、クリックボタンを押すと実行されます。

作業時、移動先に同名フォルダーが見つけると、メッセージが出て作業は中断。

移動したくなければ、ユーザーフォーム右上のヘソボタンを押せば、終了です。

もし、移動先に同名フォルダーがないと、実行して結果をエクスプローラ展開。

移動内容を再確認する上で起動していますが、必要としない人もいるでしょう。

この場合は、”Call FrmCls(TrgtFldrNme)” の一行をコメント化すればOKです。

つまり、変数渡しのモジュールを呼び出さないように、分かりやすくしました。

というわけで、下記にその構文を貼っておきますので、ご自由にお使い下さい。

この他、ファイルシステムオブジェクトで必要なライブラリーがあり、参照設定が必ず必要になるので、使って見たいと思ったお方は、忘れずにチェックマークを付けていただきたいと思うのでした。

＜ThisWorkbookのコード＞

Private Sub Workbook_Open() 'ファイルサイズ28KB

   Application.WindowState = xlMinimized    

       Load UserForm1

           UserForm1.Show

End Sub

＜UserForm1のコード＞

Dim fso As FileSystemObject

 '参照ライブラリ：MicrosoftScriptingRuntime

Dim wsh As IWshRuntimeLibrary.WshShell

 '参照ライブラリ：WindowsScriptHostObjectModel

Dim TrgtFldrNme As String '変数のパブリック化

Option Explicit

Private Sub UserForm_Initialize()

Dim TrgtFldrs As Folders, Fldr As Folder, Strng As String

  UserForm1.ComboBox1.Clear

  UserForm1.ComboBox2.Clear

      Set fso = New FileSystemObject

      Set wsh = New IWshRuntimeLibrary.WshShell

Strng = ""

Strng = Strng & wsh.SpecialFolders("Desktop")

Strng = Strng & "\"

Strng = Strng & ""

    Set TrgtFldrs = fso.GetFolder(Strng).SubFolders

       For Each Fldr In TrgtFldrs

         UserForm1.ComboBox1.AddItem Fldr.Name

       Next

Set TrgtFldrs = Nothing

Set fso = Nothing

Set wsh = Nothing

   UserForm1.ComboBox2.AddItem "ドキュメント"

   UserForm1.ComboBox2.AddItem "ピクチャ"

   UserForm1.ComboBox2.AddItem "ダウンロード"

End Sub

Sub CommandButton1_Click()

Dim Splt As Variant, TrgtFldr As String, Dstntn As String

   Set fso = New FileSystemObject

   Set wsh = New IWshRuntimeLibrary.WshShell

On Error GoTo ErrLabel

   TrgtFldr = ""

   TrgtFldr = TrgtFldr & wsh.SpecialFolders("Desktop")

   TrgtFldr = TrgtFldr & "\"

   TrgtFldr = TrgtFldr & Me.ComboBox1

   TrgtFldr = TrgtFldr & ""

        Splt = Split(wsh.SpecialFolders("Desktop"), "\")

If UserForm1.ComboBox2 = "ドキュメント" Then

   Dstntn = ""

   Dstntn = Dstntn & wsh.SpecialFolders("MyDocuments")

   Dstntn = Dstntn & "\"

   Dstntn = Dstntn & ""

      ElseIf UserForm1.ComboBox2 = "ピクチャ" Then

         Dstntn = ""

         Dstntn = Dstntn & Splt(0)

         Dstntn = Dstntn & "\"

         Dstntn = Dstntn & Splt(1)

         Dstntn = Dstntn & "\"

         Dstntn = Dstntn & Splt(2)

         Dstntn = Dstntn & "\"

         Dstntn = Dstntn & "Pictures"

         Dstntn = Dstntn & "\"

         Dstntn = Dstntn & ""

             ElseIf UserForm1.ComboBox2 = "ダウンロード" Then

                 Dstntn = ""

                 Dstntn = Dstntn & Splt(0)

                 Dstntn = Dstntn & "\"

                 Dstntn = Dstntn & Splt(1)

                 Dstntn = Dstntn & "\"

                 Dstntn = Dstntn & Splt(2)

                 Dstntn = Dstntn & "\"

                 Dstntn = Dstntn & "Downloads"

                 Dstntn = Dstntn & "\"

                 Dstntn = Dstntn & ""

 End If

    TrgtFldrNme = ""

    TrgtFldrNme = TrgtFldrNme & Dstntn

    TrgtFldrNme = TrgtFldrNme & UserForm1.ComboBox1

    TrgtFldrNme = TrgtFldrNme & ""

Call fso.MoveFolder(TrgtFldr, Dstntn)

  ' フォルダ名を指定して移動、クラスモジュールの実行に相似

     Call FrmCls(TrgtFldrNme)  'フォルダ移動後の後処理

            GoTo EndUp

ErrLabel:

     MsgBox Err.Description

EndUp:

     Set fso = Nothing ' 後始末

     Set wsh = Nothing

End Sub

Sub FrmCls(ByVal TrgtFldrNme As String)

Dim rc As Integer

    rc = MsgBox("フォームを閉じますか？", vbYesNo + vbQuestion, "確認")

    If rc = vbYes Then

         MsgBox "フォームを閉じ、エクスプローラ起動"

         Call Explr(TrgtFldrNme)

         Unload Me

    Else

         MsgBox "処理を継続し、エクスプローラ起動"

         Call Explr(TrgtFldrNme)

         Call UserForm_Initialize

    End If

End Sub

Sub Explr(ByVal TrgtFldrNme As String)

Dim rc As Long, ExplrCmnd As String

   ExplrCmnd = ""

   ExplrCmnd = ExplrCmnd & "Explorer.exe  /e ,　/root, "

   ExplrCmnd = ExplrCmnd & TrgtFldrNme

   ExplrCmnd = ExplrCmnd & ""

       rc = Shell(ExplrCmnd, vbNormalFocus)

           If rc = 0 Then MsgBox "起動に失敗しました"

'移動先のフォルダーをエクスプローラ展開、エラーではメッセージ

End Sub

エラーメッセージも出るよ！

いいねと思ったら、三つポチっとね！
  
にほんブログ村    にほんブログ村      にほんブログ村