遍历目录和文件--使用管道和cmd交互的应用

loquat · 发表于 2017-1-5 23:37

本帖最后由 loquat 于 2017-1-5 23:40 编辑

先推荐一篇帖子，裙子小姐的遍历知识普及贴：
http://club.excelhome.net/forum.php?mod=viewthread&tid=1185089

遍历文件有很多种方式：
1.使用Dir函数，配合递归
遍历文件是一个旧话题，这里有一篇帖子
http://club.excelhome.net/thread-1319867-1-1.html
思路很新颖，给了递归一次脱胎换骨
2.使用fso
fso配合递归，fso配合字典或数组
3.使用cmd dir
  这里是我之前的帖子，请直接跳到10#
  http://club.excelhome.net/thread-1063384-1-1.html
  目前调用有两种方式，方法一：直接弹窗cmd窗口，执行完命名直接读取结果
                                 方法二：后台执行cmd命令，执行完保存到临时文本文件，然后从临时文件读取
  本帖要讲的是另一种方式，建立Pipe（管道），后台执行cmd命令，将执行结果直接写入内存，然后从内存读取
  综合解决了方法一和方法二各自的弊端

不知道论坛封锁了什么特殊字符，不让上代码，直接上传附件吧。

文件搜索2-管道.rar (24.33 KB, 下载次数: 49)

loquat · 发表于 2017-1-5 23:41

代码是在wzsy2_mrf的附件的基础上做的改动。

loquat · 发表于 2017-1-5 23:41

Sub 遍历_管道()
Dim t: t = Timer
Dim a As New DosCMD
Dim arr
a.DosInput Environ$("comspec") & " /c dir " & Chr(34) & "c:\*.doc" & Chr(34) & " /s /b /a:-d"
arr = a.DosOutPutEx '默认等待时间120s
arr = Split(arr, vbCrLf) '分割成数组
arr = Filter(arr, ".doc", True, vbTextCompare)
arr = Filter(arr, "*", False, vbTextCompare)
arr = Filter(arr, "$", False, vbTextCompare)
Debug.Print Timer - t
End Sub

复制代码

loquat · 发表于 2017-1-5 23:42

'DosCMD类第1部分
Option Explicit
'延时函数部分
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Const WAIT_ABANDONED& = &H80&
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_FAILED& = -1&
Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_OBJECT_1& = 1
Private Const WAIT_TIMEOUT& = &H102&
Private Const INFINITE = &HFFFF
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
Private Const UNITS = 4294967296#
Private Const MAX_LONG = -2147483648#
Private Declare Function CreateWaitableTimer Lib "kernel32" Alias "CreateWaitableTimerA" (ByVal lpSemaphoreAttributes As Long, ByVal bManualReset As Long, ByVal lpName As String) As Long
Private Declare Function OpenWaitableTimer Lib "kernel32" Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Private Declare Function SetWaitableTimer Lib "kernel32" (ByVal hTimer As Long, lpDueTime As FILETIME, ByVal lPeriod As Long, ByVal pfnCompletionRoutine As Long, ByVal lpArgToCompletionRoutine As Long, ByVal fResume As Long) As Long
Private Declare Function CancelWaitableTimer Lib "kernel32" (ByVal hTimer As Long)
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private mlTimer As Long
Private Type STARTUPINFO '(CreateProcess)
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hfile As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Type PROCESS_INFORMATION '(CreateProcess)
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadID As Long
End Type
Private Type SECURITY_ATTRIBUTES '(CreateProcess)
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
'常数声明
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1
Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_QUERY_INFORMATION = &H400
'函数声明
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, ByVal lpBuffer As Long, ByVal nBufferSize As Long, ByRef lpBytesRead As Long, ByRef lpTotalBytesAvail As Long, ByRef lpBytesLeftThisMessage As Long) As Long
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hfile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hfile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Const DUPLICATE_SAME_ACCESS = &H2
Private PipeR4InputChannel As Long, PipeW4InputChannel As Long, hInputHandle As Long
Private PipeR4OutputChannel As Long, PipeW4OutputChannel As Long, hOutputHandle As Long
Private Proc As PROCESS_INFORMATION
Public Enum InitResult
ERROR_OK = 0
ERROR_INIT_INPUT_HANDLE = 1
ERROR_INIT_OUTPUT_HANDLE = 2
ERROR_DUP_READ_HANDLE = 3
ERROR_DUP_WRITE_HANDLE = 4
ERROR_CREATE_CHILD_PROCESS = 5
End Enum
Public Enum TermResult
ERROR_OK = 0
End Enum
Public Enum InputResult
ERROR_OK = 0
ERROR_QUERY_WRITE_INFO_SIZE = 1
ERROR_DATA_TO_LARGE = 2
ERROR_WRITE_INFO = 3
ERROR_WRITE_UNEXPECTED = 5
End Enum
Public Enum OutputResult
ERROR_OK = 0
ERROR_QUERY_READ_INFO_SIZE = 1
ERROR_ZERO_INFO_SIZE = 2
ERROR_READ_INFO = 3
ERROR_UNEQUAL_INFO_SIZE = 4
ERROR_READ_UNEXPECTED = 5
ERROR_QUERY_INFO_SIZE = 6
End Enum
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Dim OutPutData As String, ReadData As Boolean, OutData As String
Private IsExit As Boolean
Public Event Events()
Private Sub Class_Initialize()
If InitDosIO <> 0 Then
Debug.Print "DOS通道创建失败！"
End If
End Sub
Private Sub Class_Terminate()
On Error Resume Next
IsExit = True
Call EndDosIo
If mlTimer <> 0 Then CloseHandle mlTimer
End Sub

复制代码

loquat · 发表于 2017-1-5 23:43

'DosCMD类第2部分
Public Sub Wait(MilliSeconds As Long) '延时函数
On Error GoTo ErrHandler
Dim ft As FILETIME
Dim lBusy As Long
Dim lRet As Long
Dim dblDelay As Double
Dim dblDelayLow As Double
mlTimer = CreateWaitableTimer(0, True, "Timer" & Format$(Now(), "NNSS"))
If Err.LastDllError <> ERROR_ALREADY_EXISTS Then
ft.dwLowDateTime = -1
ft.dwHighDateTime = -1
lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
End If
dblDelay = CDbl(MilliSeconds) * 10000#
ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
ft.dwLowDateTime = CLng(dblDelayLow)
lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
Do
lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
DoEvents
Loop Until lBusy = WAIT_OBJECT_0 And IsExit = False
CloseHandle mlTimer
mlTimer = 0
Exit Sub
ErrHandler:
Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
End Sub
Private Function InitDosIO() As InitResult
Dim Sa As SECURITY_ATTRIBUTES, ret As Long
With Sa
.nLength = Len(Sa)
.bInheritHandle = 1&
.lpSecurityDescriptor = 0&
End With
ret = CreatePipe(PipeR4InputChannel, PipeW4InputChannel, Sa, 1024&)
If ret = 0 Then '建立进程输入管道
InitDosIO = ERROR_INIT_INPUT_HANDLE
Exit Function
End If
ret = CreatePipe(PipeR4OutputChannel, PipeW4OutputChannel, Sa, 4096&) '建立输出通道,若建立失败，则关闭管道，退出
If ret = 0 Then '建立进程的输出管道
CloseHandle PipeR4InputChannel
CloseHandle PipeW4InputChannel
InitDosIO = ERROR_INIT_OUTPUT_HANDLE
Exit Function
End If
ret = DuplicateHandle(GetCurrentProcess(), PipeW4InputChannel, GetCurrentProcess(), hInputHandle, 0, True, DUPLICATE_SAME_ACCESS)
If ret = 0 Then '转换写句柄
CloseHandle PipeR4InputChannel
CloseHandle PipeW4InputChannel
CloseHandle PipeR4OutputChannel
CloseHandle PipeW4OutputChannel
InitDosIO = ERROR_DUP_WRITE_HANDLE
Exit Function
End If
ret = CloseHandle(PipeW4InputChannel)
If ret = 0 Then
Debug.Print "Close Handle Err"
End If
ret = DuplicateHandle(GetCurrentProcess(), PipeR4OutputChannel, GetCurrentProcess(), hOutputHandle, 0, True, DUPLICATE_SAME_ACCESS)
If ret = 0 Then '转换读句柄
CloseHandle PipeR4InputChannel
CloseHandle PipeW4InputChannel
CloseHandle PipeR4OutputChannel
CloseHandle PipeW4OutputChannel
InitDosIO = ERROR_DUP_READ_HANDLE
Exit Function
End If
ret = CloseHandle(PipeR4OutputChannel)
If ret = 0 Then
Debug.Print "Close Handle 2 Err"
End If
Dim Start As STARTUPINFO, CmdStr As String
Start.cb = Len(Start)
Start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
Start.hStdOutput = PipeW4OutputChannel
Start.hStdError = PipeW4OutputChannel
Start.hStdInput = PipeR4InputChannel
CmdStr = "CMD" '需要打开的命令行外壳(CMD.EXE)
ret& = CreateProcessA(0&, CmdStr, Sa, Sa, True, NORMAL_PRIORITY_CLASS, 0&, 0&, Start, Proc)
If ret <> 1 Then '建立控制进程
CloseHandle PipeR4InputChannel
CloseHandle PipeW4InputChannel
CloseHandle PipeR4OutputChannel
CloseHandle PipeW4OutputChannel
InitDosIO = ERROR_CREATE_CHILD_PROCESS
Exit Function
End If
ReadData = True
End Function
Public Function DosInput(ByVal Str As String) As InputResult
Dim Buflen As Long, BtWritten As Long, rtn As Long
Dim BtTest() As Byte
ReadData = True
BtTest = StrConv(Str + vbCrLf, vbFromUnicode)
Buflen = UBound(BtTest) + 1
rtn = WriteFile(hInputHandle, StrPtr(BtTest), Buflen, BtWritten, ByVal 0&)
If BtWritten = 0 Then
DosInput = ERROR_WRITE_INFO
Exit Function
End If
DosInput = 0
End Function
Public Function DosOutPutEx(Optional TimeOut As Long = 1200000) As String '默认命令超时120秒
Dim OutPt As String, OldTime As Long, NewTime As Long, Tmp() As String
If ReadData = False Then Exit Function
OldTime = timeGetTime
OutPutData = ""
Do
DoEvents
If DosOutput(OutPt) = 0 Then
OutData = Left$(OutPt, Len(OutPt) - 1)
OutPutData = OutPutData & Left$(OutPt, Len(OutPt) - 1)
Call NowEvents
Tmp = Split(OutPt, Chr$(13))
If Len(Tmp(UBound(Tmp))) <> 0 Then
If InStr(Tmp(UBound(Tmp)), ":") = 3 And Right(Tmp(UBound(Tmp)), 2) = ">" & Chr$(0) Then Exit Do
End If
End If
NewTime = timeGetTime
Call Wait(1) '如需要更高实时性可以改为1
If NewTime - OldTime >= TimeOut Then Exit Do
Loop
DosOutPutEx = OutPutData
ReadData = False
End Function
Public Function GetOut() As String '实时数据
GetOut = OutData
End Function
Friend Sub NowEvents() '接口
RaiseEvent Events
End Sub
Private Function DosOutput(ByRef StrOutput As String) As OutputResult
Dim ret As Long, TmpBuf As String * 128, BtRead As Long, BtTotal As Long, BtLeft As Long
Dim rtn As Long, lngbytesread As Long
rtn = PeekNamedPipe(hOutputHandle, StrPtr(TmpBuf), 128, BtRead, BtTotal, BtLeft)
If rtn = 0 Then '查询信息量
DosOutput = ERROR_QUERY_INFO_SIZE
Exit Function
End If
If BtTotal = 0 Then '若信息为空，则退出
DosOutput = ERROR_ZERO_INFO_SIZE
Exit Function
End If
Dim Btbuf() As Byte, BtReaded As Long
ReDim Btbuf(BtTotal)
ret = ReadFile(hOutputHandle, VarPtr(Btbuf(0)), BtTotal, lngbytesread, 0&)
If ret = 0 Then
DosOutput = ERROR_READ_INFO
Exit Function
End If
If BtTotal <> lngbytesread Then
DosOutput = ERROR_UNEQUAL_INFO_SIZE
End If
Dim strBuf As String
strBuf = StrConv(Btbuf, vbUnicode)
StrOutput = strBuf
End Function
Private Function EndDosIo() As Long
Dim ret As Long
CloseHandle PipeR4InputChannel
CloseHandle PipeW4InputChannel
CloseHandle PipeR4OutputChannel
CloseHandle PipeW4OutputChannel
CloseHandle Proc.hThread
CloseHandle Proc.hProcess
If EndProcess(Proc.dwProcessId) = False Then
Debug.Print "主服务程序[CMD.EXE]没有关闭，请您手动关闭 ", vbInformation, "不好意思"
End If
End Function
Private Function EndProcess(ByVal ProcessID As Long) As Boolean
Dim hProcess As Long, ExitCode As Long, Rst As Long
hProcess = OpenProcess(PROCESS_TERMINATE Or PROCESS_QUERY_INFORMATION, True, ProcessID)
If hProcess <> 0 Then
GetExitCodeProcess hProcess, ExitCode
If ExitCode <> 0 Then
Rst = TerminateProcess(hProcess, 0)
CloseHandle hProcess
If Rst = 0 Then
EndProcess = False
Else
EndProcess = True
End If
Else
EndProcess = False
End If
Else
EndProcess = False
End If
End Function

复制代码

zhanglei1371 · 发表于 2017-1-6 07:43

感谢分享，好东西收藏了！

413191246se · 发表于 2017-1-7 13:25

虽然看不懂，但作为楼主的老朋友，热烈祝贺！

loquat · 发表于 2017-1-18 16:56

代码在64位Office上可能会有问题

loquat · 发表于 2017-1-18 17:00

代码在64位Office上可能会有问题

		自动登录	找回密码
密码			免费注册

[分享] 遍历目录和文件--使用管道和cmd交互的应用