| |
どうもFileCopy に時間がかかるようなので、
Windows APIの FileCopyOperation 使って Copyするサンプル書いてみました。
ウラ（画面の）でコピーしていると不安になるけど、コピーの情況が出るので、
同じ時間がかかっても安心できます(^^
'---------------------------------------------- 新しい標準モジュール
Option Explicit
Declare Function FileCopyOperation Lib "shell32.dll" Alias _
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Public Const FO_DELETE = &H3
Public Const FOF_ALLOWUNDO = &H40
Public Const FOF_NOCONFIRMATION = &H10
Public Const FO_COPY = &H2
Public Sub opFileCopy(SrcFile As String, DestFile As String)
Dim FT As SHFILEOPSTRUCT
Dim ok As Long
FT.hwnd = Application.hwnd
FT.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
FT.wFunc = FO_COPY
FT.pFrom = SrcFile
FT.pTo = DestFile
ok = FileCopyOperation(FT)
End Sub
Private Function FileSearch(PathFilename As String, fData) As Long
Dim tmpPath As String
Dim sCmd As String
Dim ok As Long
tmpPath = Environ$("Temp") & "\Dir.tmp" '一時ファイルパス
sCmd = "DIR """ & PathFilename & """ /s /b > """ & tmpPath & """"
ok = CreateObject("WScript.Shell") _
.Run("%ComSpec% /C " & sCmd, 7, True) 'Dirコマンド実行
If FileLen(tmpPath) > 0 Then
Dim buf() As Byte
Dim io As Integer
io = FreeFile()
Open tmpPath For Binary As io
ReDim buf(1 To LOF(io))
Get io, , buf
Close io
Kill tmpPath
fData = Split(vbCrLf & StrConv(buf, vbUnicode), vbCrLf)
FileSearch = UBound(fData) - 1
End If
End Function
Sub Try3()
Dim fData
Dim i&, j&
Dim n&
Dim ss$
Const TOP_FOLDER = "C:\Test1"
Const COPY_TO = "C:\Test2"
n = FileSearch(TOP_FOLDER & "\*a*.csv", fData)
If n = 0 Then Exit Sub
For i = 1 To n
j = InStrRev(fData(i), "\")
opFileCopy CStr(fData(i)), COPY_TO & Mid$(fData(i), j)
Next
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
