Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
Private StopFlag As Boolean
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Sub FileSearch(ByVal sPath As String, ByVal Filter As String)
Static lngFiles As Long
Dim sDir As String
Dim sSubDirs() As String
Dim lngIndex As Long
Dim lngTemp&
DoEvents
If StopFlag = True Then Exit Sub
Label1.Caption = "当前路径" &sPath
If Right(sPath, 1) <>局带 "\" Then sPath = sPath &"\"
sDir = Dir(sPath &Filter)
Do While Len(sDir)
lngFiles = lngFiles + 1
List1.AddItem sPath &sDir
sDir = Dir
Loop
lngIndex = 0
sDir = Dir(sPath &"*.*", vbDirectory)
Do While Len(sDir)
If Left(sDir, 1) <>"." And Left(sDir, 1) <桐并芦>".." Then
If GetAttr(sPath &sDir) And vbDirectory Then
lngIndex = lngIndex + 1
ReDim Preserve sSubDirs(1 To lngIndex)
sSubDirs(lngIndex) = sPath &sDir &"\"蔽芹
End If
End If
sDir = Dir
Loop
For lngTemp = 1 To lngIndex
Call FileSearch(sSubDirs(lngTemp), Filter)
Next lngTemp
End Sub
Public Sub StartSearch(ByVal Filter As String)
Dim nType As Long, s As String, sDrive As String, d As String
Dim pos As Integer
s = String(256, Chr(0))
GetLogicalDriveStrings Len(s), s
Do
pos = InStr(s, Chr(0))
sDrive = Left(s, pos - 1)
If Len(sDrive) = 0 Then Exit Do
s = Mid(s, pos + 1)
nType = GetDriveType(sDrive)
If nType = DRIVE_FIXED Then
d = Left(sDrive, 2) &"\"
FileSearch d, Filter
End If
Loop Until pos <= 0
End Sub
Private Sub Command1_Click() '测试
StartSearch "*.jpg"
End Sub
Private Sub Form_Unload(Cancel As Integer)
StopFlag = True
End Sub
'QQ加你了
用API的方式丛早比Dir也快不了多少的,因为目前而言,电脑运行速度的最大瓶颈就是硬盘,不管CPU、主板、内存、显卡有多快,在执行文件 *** 作时都不得不慢下来等待硬盘,所以不管软件编得多好多努力,对速度的提升都不大的。就像几十万辆车要排队过一条小桥,一次只能过一辆,那么即使所有车都是法拉利、保时捷,通过小桥的速度也比几十万台拖拉机甚至牛车快不了多少的!乎郑毁关键是要拓宽桥的宽度岁备,或者多建几座桥,比如把机械硬盘换成固态硬盘,速度就会有明显提升的。excel vba调用windows API 快速查找所选择的文件excel选中悉氏文件名清单、自动从“a1"文件夹中查找相应的文件。
ShellExecuteA,DataObject,Clipboard,find,SendKeys
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _
String, ByVal lpszFile As String, ByVal lpszParams As String, _
ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
Const SW_SHOW = 5
Sub test()
Selection.Copy
Dim MyData As DataObject
Dim sTemp As String, s As String
Set MyData = New DataObject
MyData.GetFromClipboard
sTemp = MyData.GetText
s = Replace(sTemp, vbCrLf, "")
s = Replace(s, vbTab, "")
MyData.SetText (s)
MyData.PutInClipboard
ShellExecute 0&, "find", Range("a1"笑型), _
vbNullString, vbNullString, SW_SHOW
Application.Wait (Now + TimeValue("0:00:02"睁升散))
SendKeys s &"{ENTER}"
End Sub
欢迎分享,转载请注明来源:内存溢出
评论列表(0条)