ドラッグアンドドロップで別のフォルダのファイル検索

概要

• 手元にあるファイルをドラッグアンドドロップでして、どこかアーカイブフォルダ的なところにあるファイルを開く
• 投げ込むのはpdf、開くのはdxfなどの図面ファイル、という指定もできるように
• 複数同時投げ込みＯＫ
• 投げ込んだファイル名と検索結果がListViewに表示される

コード 標準モジュール

Option Explicit
Const folder = "C:\Users\***\探すフォルダ"
Const fExt = ".dxf"

Function SerchFile(Target As String) As String
  '探す
    Dim buf
    buf = Split(Target, ".")(0)
    buf = Dir(folder & "\" & buf & fExt)
    SerchFile = buf
  '開く
    Dim WSS
    Set WSS = CreateObject("WScript.Shell")
    WSS.Run folder & "\" & buf
End Function

Function OpenFile(Target As String) As String
    Dim WSS
    Set WSS = CreateObject("WScript.Shell")
    WSS.Run folder
End Function

コード ユーザーフォーム

ユーザーフォームにListViewｗを配置しておく。

↓ユーザーフォーム部分はほとんどこちらから流用させていただきました。
ドラッグ＆ドロップで指定ファイルを処理し、更にその結果を表示する。

Option Explicit

Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
  ' Microsoft Scripting Runtime参照済み
  ' https://infoment.hatenablog.com/entry/2019/04/29/065351より
  Dim FSO As FileSystemObject
  Set FSO = New FileSystemObject
  
  Dim OldFileName As String
  Dim NewFileName As String
  Dim ParentFolderPath As String
    ParentFolderPath = FSO.GetParentFolderName(Data.Files(1)) & "\"
  
  Dim i As Long
    For i = 1 To Data.Files.Count
      OldFileName = FSO.GetFileName(Data.Files(i))
      With ListView1.ListItems.Add
        .Text = OldFileName
        NewFileName = SerchFile(OldFileName)
        If NewFileName <> "" Then
          .SubItems(1) = NewFileName '"正常処理終了"
        Else
          .SubItems(1) = "見つかりませんでした"
        End If
      End With
    Next
End Sub

Private Sub UserForm_Initialize()
  With ListView1
    .View = lvwReport
    .LabelEdit = lvwManual
    .HideSelection = False
    .AllowColumnReorder = True
    .FullRowSelect = True
    .Gridlines = True
    
    .ColumnHeaders.Add , "_FileName", "ファイル名", 100
    .ColumnHeaders.Add , "_Result", "結果", 100
  End With
End Sub