在excel vba中如何调用api函数实现快速查找文件名

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

Option Explicit

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加你了

---