ドラッグアンドドロップで別のフォルダのファイル検索
概要
- 手元にあるファイルをドラッグアンドドロップでして、どこかアーカイブフォルダ的なところにあるファイルを開く
- 投げ込むのはpdf、開くのはdxfなどの図面ファイル、という指定もできるように
- 複数同時投げ込みOK
- 投げ込んだファイル名と検索結果が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
コード ユーザーフォーム
ユーザーフォームにListViewwを配置しておく。
↓ユーザーフォーム部分はほとんどこちらから流用させていただきました。
ドラッグ&ドロップで指定ファイルを処理し、更にその結果を表示する。
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
Author And Source
この問題について(ドラッグアンドドロップで別のフォルダのファイル検索), 我々は、より多くの情報をここで見つけました https://qiita.com/taleau/items/231f465353729ac70217著者帰属:元の著者の情報は、元のURLに含まれています。著作権は原作者に属する。
Content is automatically searched and collected through network algorithms . If there is a violation . Please contact us . We will adjust (correct author information ,or delete content ) as soon as possible .