VB 查找 判断 复制文件

思路：

既然是语音库，里面内容一定不少。如果按照2楼那么效率非常低。

所以我这里事先对语音库存在的文件进行记录（记录中每隔1秒刷新进度；每隔100个文件/目录进行Redim——效率很高，装有AdobeCS4全套+Office2003全套+VB等等的电脑，搜索Program files只用了8s）

然后对它进行快速排序（采用指针交换字符串 来提高速度。）。

搜索开始之后直接对记录进行二分查找，进一步缩短时间。

－－－－－－－－－－－－－－－－－－－－－－－－

放一个Label(lblState)，用于显示进度

放两个TextBox(Text1,Text2)(多行)，你自己输入搜索内容

放一个Command(cmdSearch)，用于启动搜索

然后输入以下代码

－－－－－－－－－－－－－－－－－－－－－－－－

Const Steps As Integer = 700

Private Type PathStruct

FileName As String

FilePath As String

End Type

Dim Files() As PathStruct

Dim Records() As String

Dim StartTimer As Long

Dim FileC As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Sub cmdSearch_Click()

Text1.Text = ""

lblState.Caption = "请稍后，正在分割记录文件...": DoEvents

SplitRecord

lblState.Caption = "请稍后，正在处理文件...": DoEvents

ProcessRecord

End Sub

Private Sub Form_Load()

Const SearchDir As String = "e:\新建\"

On Error GoTo Err

Me.Show

StartTimer = Timer: ReDim Files(Steps)

lblState.Caption = "请稍后，正在建立索引表。": DoEvents

CreateFileIndex SearchDir

Debug.Print UBound(Files)

lblState.Caption = "请稍后，正在为索引表排序。": DoEvents

QuickSort 0, UBound(Files)

lblState.Caption = "初始化完成，点击按钮开始。": DoEvents

cmdSearch.Enabled = True

Exit Sub

Err:

MsgBox "记录出现了错误：" &vbCrLf &IIf(Err.Number = 9, "文件夹 """ &SearchDir &""" 下没有文件!", "错误描述:" &Err.Description), vbCritical, "错误"

lblState.Caption = "请检查记录，然后重新打开本程序。"

End Sub

Sub CreateFileIndex(strPath As String) '创建索引表 避免重复查找

On Error Resume Next

Dim strName As String

Dim Dirs() As String, DirC As Long

ReDim Dirs(Steps)

If Right(strPath, 1) <>"\" Then strPath = strPath + "\"

strName = Dir(strPath, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)

Do While strName <>""

If strName <>"." And strName <>".." Then

If (GetAttr(strPath &strName) And vbDirectory) = vbDirectory Then

If DirC Mod Steps = 0 And DirC >0 Then ReDim Preserve Dirs(DirC * 2)

Dirs(DirC) = strName

DirC = DirC + 1

Else

If FileC Mod Steps = 0 And FileC >0 Then ReDim Preserve Files(FileC * 2)

Files(FileC).FilePath = strPath

Files(FileC).FileName = LCase(strName)

FileC = FileC + 1

End If

End If

strName = Dir

If Timer - StartTimer >= 2 Then

lblState.Caption = "请稍后，正在建立索引表。目录: " &strPath: DoEvents

StartTimer = Timer

End If

Loop

For i = 0 To DirC - 1

Call CreateFileIndex(strPath + Dirs(i))

Next i

ReDim Preserve Files(FileC)

End Sub

Sub SwapStr(lA As String, lB As String) '指针交换字符串 原因是这样速度非常快

Dim t As Long

CopyMemory t, ByVal VarPtr(lA), 4

CopyMemory ByVal VarPtr(lA), ByVal VarPtr(lB), 4

CopyMemory ByVal VarPtr(lB), t, 4

End Sub

Sub QuickSort(ByVal l As Long, ByVal r As Long) '对索引进行快速排序 这样就能用二分查找减少搜索时间

Dim i As Long, j As Long, intLoop As Long

i = l: j = r

Do

While Files(i).FileName <= Files(j).FileName And i <j: i = i + 1: Wend

If i <j Then SwapStr Files(i).FileName, Files(j).FileName: SwapStr Files(i).FilePath, Files(j).FilePath

While Files(i).FileName <= Files(j).FileName And i <j: j = j - 1: Wend

If i <j Then SwapStr Files(i).FileName, Files(j).FileName: SwapStr Files(i).FilePath, Files(j).FilePath

Loop Until i = j

i = i - 1: j = j + 1

If i >l Then Call QuickSort(l, i)

If j <r Then Call QuickSort(j, r)

End Sub

Sub SplitRecord() '对Text1的待搜索记录进行分割

Records = Split(LCase(Text1.Text), vbCrLf)

End Sub

Sub ProcessRecord() '对分割后的记录进行处理

On Error GoTo Err

Dim i As Integer, id As Long

For i = 0 To UBound(Records)

If Len(Records(i)) >0 Then

If i Mod 10 = 0 Then lblState.Caption = "请稍后，正在处理文件...(" &CStr(i) &"/" &CStr(UBound(Records)) &")": DoEvents '显示状态

id = SearchStr(Records(i) &".mp3")

If id = -1 Then

Text2.Text = Text2.Text &Records(i) &".mp3 未找到" &vbCrLf

Else

FileCopy Files(id).FilePath &Files(id).FileName, "d:\good"

End If

End If

Next

Text2.Text = Left(Text2.Text, Len(Text2.Text) - 1)

lblState.Caption = "处理完成!"

Exit Sub

Err:

MsgBox "搜索内容有误，请检查。", vbCritical, "错误"

End Sub

Public Function SearchStr(ByVal MatchString As String) As Long '在索引中按文件名进行二分查找

Dim SearchMin As Long, SearchMax As Long

Dim i As Long

SearchStr = -1

SearchMin = LBound(Files)

SearchMax = UBound(Files)

Do

i = (SearchMax + SearchMin) \ 2

If Files(i).FileName = MatchString Then

SearchStr = i

Exit Do

End If

If Files(i).FileName >MatchString Then

SearchMax = i - 1

Else

SearchMin = i + 1

End If

Loop While SearchMax >= SearchMin

End Function

是VB6版本吗？建议下载对应版本的msdn帮助，对于初学者帮助非常大。

可以用fso对象检查文件是否存在，或者用简单的DIR函数：

'复制前检查文件，注意myfile=""时，即长度为0时 if语句仍会执行删除命令

If Len(Dir(myfile)) Then Kill myfile

FileCopy Text1.txt & ".jpg", myfile

-------------分隔符-------------

FileCopy 语句

复制一个文件。

语法

FileCopy source, destination

FileCopy 语句的语法含有以下这些命名参数：

部分          描述  

source            必要参数。字符串表达式，用来表示要被复制的文件名。source 可以包含目录或文件夹、以及驱动器。

destination       必要参数。字符串表达式，用来指定要复制的目地文件名。destination 可以包含目录或文件夹、以及驱动器。

说明

如果想要对一个已打开的文件使用 FileCopy 语句，则会产生错误。

------------------     分割线     --------------------

MsgBox函数

描述

在对话框中显示消息，等待用户单击按钮，并返回一个值指示用户单击的按钮。

语法

MsgBox(prompt[, buttons][, title][, helpfile, context])

参数                描述  

prompt    

作为消息显示在对话框中的字符串表达式。prompt 的最大长度大约是 1024 个字符，这取决于所使用的字符的宽度。如果 prompt 中包含多个行，则可在各行之间用回车符 (Chr(13))、换行符 (Chr(10)) 或回车换行符的组合 (Chr(13) &Chr(10)) 分隔各行。  

buttons    

数值表达式，是表示指定显示按钮的数目和类型、使用的图标样式，默认按钮的标识以及消息框样式的数值的总和。有关数值，请参阅“设置”部分。如果省略，则 buttons 的默认值为 0。  

title    

显示在对话框标题栏中的字符串表达式。如果省略 title，则将应用程序的名称显示在标题栏中。  

helpfile    

字符串表达式，用于标识为对话框提供上下文相关帮助的帮助文件。如果已提供 helpfile，则必须提供 context。在 16 位系统平台上不可用。  

context    

数值表达式，用于标识由帮助文件的作者指定给某个帮助主题的上下文编号。如果已提供 context，则必须提供 helpfile。在 16 位系统平台上不可用。

buttons 参数可以有以下值：（写代码时会自动提示，这里忽略） 

下面的示例利用MsgBox 函数显示一信息框并且返回值说明了按下的是那一个按钮:

Dim MyVar

MyVar = MsgBox ("Hello World!", 65, "MsgBox 例子")

另外在编程环境按下F2键搜索msgbox你也会得到帮助。

'代码最好不要写在 Form_Load() 事件中

'注意在标题栏显示的状态

'可以根据需要，不加 Caption ,Print 和 MsgBox 语句

Set ws = CreateObject("WScript.Shell")

Set FSO = CreateObject("Scripting.FileSystemObject")

Caption="正在记录文件名，请稍后..."

ws.Run "cmd /c dir C:\*.jpg /a:-d /b /s>>a.txt", 0, True

Caption="正在查找和复制符合条件的文件..."

Open "a.txt" For Input As #1

Do Until EOF(1)

Line Input #1, fn

Set f = FSO.GetFile(fn)

If DateValue(f.DateCreated) = DateAdd("d", -1, Date) _

And DateValue(f.DateLastModified) = Date Then

f.Copy "D:\"

Print fn '在窗体上显示已复制的文件名

End If

DoEvents '减慢运行速度

Loop

Close #1

Kill "a.txt"

Caption="已完成"

MsgBox "全部完成"

---