我现在做了一个功能,就是根据数据库中的字段,将对应文件夹内的图片复制到另一个文件夹内,并把数据库中存在,但文件夹内不存在的图片的记录写到一个文本文件中,该功能已基本实现 Private Sub Command1_Click()
Dim fso As New FileSystemObject
If Dir("d:\ks_photo", vbDirectory) <> "" Then
MsgBox "文件夹:d:\ks_photo 已存在!您想再执行一次吧"
fso.DeleteFolder ("d:\ks_photo") ' 删除原来的文件夹
fso.DeleteFile ("d:\nophoto.txt") '删除原来的nophoto文件
fso.CreateFolder ("d:\ks_photo") ' 新建一个文件夹
Else
fso.CreateFolder ("d:\ks_photo") ' 新建一个文件夹
End If
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, filePath As String
cn.CursorLocation = adUseClient
cn.Open "Driver={Microsoft dBASE Driver (*.dbf)}; DriverID=277;Dbq=d:\" rs.Open "select * from zk.dbf ", cn, adOpenKeyset, adLockOptimistic
While Not rs.EOF
filePath = "z:\photo\" & rs(6) & ".jpg"
If Dir(filePath) <> "" Then ' 找到相对应的相片
FileCopy filePath, "D:\ks_photo\" & rs(6) & ".jpg" '拷贝文件
Else
Open "D:\nophoto.txt" For Append As #1 '生成txt文件
Write #1, rs(0), rs(1), rs(2), rs(3), rs(4), rs(5), rs(6)
Close 1
End If
rs.MoveNext
Wend
MsgBox "程序已执行完毕喽!"
End Sub现要增加一功能,现在图片是存放于一个文件夹内(z:\photo)的,如果这些图片是存放在一个文件夹内,这个文件夹内有好几个文件夹,怎么样才能实现调图片这个功能,比如照片是存放在z:\photo\content1\ z:\photo\content2\ 这些子目录下的,那我应该怎么改这些代码,谢谢
Dim fso As New FileSystemObject
If Dir("d:\ks_photo", vbDirectory) <> "" Then
MsgBox "文件夹:d:\ks_photo 已存在!您想再执行一次吧"
fso.DeleteFolder ("d:\ks_photo") ' 删除原来的文件夹
fso.DeleteFile ("d:\nophoto.txt") '删除原来的nophoto文件
fso.CreateFolder ("d:\ks_photo") ' 新建一个文件夹
Else
fso.CreateFolder ("d:\ks_photo") ' 新建一个文件夹
End If
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, filePath As String
cn.CursorLocation = adUseClient
cn.Open "Driver={Microsoft dBASE Driver (*.dbf)}; DriverID=277;Dbq=d:\" rs.Open "select * from zk.dbf ", cn, adOpenKeyset, adLockOptimistic
While Not rs.EOF
filePath = "z:\photo\" & rs(6) & ".jpg"
If Dir(filePath) <> "" Then ' 找到相对应的相片
FileCopy filePath, "D:\ks_photo\" & rs(6) & ".jpg" '拷贝文件
Else
Open "D:\nophoto.txt" For Append As #1 '生成txt文件
Write #1, rs(0), rs(1), rs(2), rs(3), rs(4), rs(5), rs(6)
Close 1
End If
rs.MoveNext
Wend
MsgBox "程序已执行完毕喽!"
End Sub现要增加一功能,现在图片是存放于一个文件夹内(z:\photo)的,如果这些图片是存放在一个文件夹内,这个文件夹内有好几个文件夹,怎么样才能实现调图片这个功能,比如照片是存放在z:\photo\content1\ z:\photo\content2\ 这些子目录下的,那我应该怎么改这些代码,谢谢
"content1\hello.jpg"
要么根据其他字段可以确定子目录名,比如:
ID 1~50000 的必定存放在 content1 下
ID 50001~100000 的必定存放在 content2 下
……
反正自己管理的文件,定好规则就可以,总比每个子目录下去查找要快很多。
但愿对你有所帮助Option Explicit
'獲取某目錄下的所有子目錄路徑及名稱和檔的路徑及名稱
Public Sub SeachFile(ByVal strPath As String, strSourceEx As String, strObjectEx As String)
On Error Resume Next
Dim Fso As Object
Dim Fol As Object
Dim Fil As Object
Dim DisFileName As String
Dim OldName As String '更新前的名称
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fol = Fso.GetFolder(strPath)
strSourceEx = UCase(strSourceEx)
strObjectEx = UCase(strObjectEx)
Dim sFileName As String '檔案名(不含副檔名)
Dim sFileNameEx As String '副檔名
Dim sFilePath As String '檔路徑
For Each Fil In Fol.Files
sFileNameEx = UCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(Fil.Name)) '副檔名
If Trim(sFileNameEx) = "" Then '如果副檔名為空,則跳出本次迴圈
GoTo NoEx
End If
sFileName = Left(Fil.Name, Len(Fil.Name) - Len(sFileNameEx) - IIf(Len(sFileNameEx) = 0, 0, 1))
OldName = sFileName
sFilePath = Fil.ParentFolder '取得父階文件夾路徑
sFilePath = sFilePath & "\"
labMsg.Caption = sFilePath & Chr(13) & Fil.Name
DoEvents
DisFileName = GetFileCreatedTime(CStr(Fil))
If DisFileName = OldName Then '如果更新前后名称一样,则不做修改
GoTo NoEx
End If
CheckFileName:
If Dir(sFilePath & DisFileName & "." & sFileNameEx, vbDirectory) <> "" Then '存在同名文件
DisFileName = DisFileName & "A"
GoTo CheckFileName
End If
Fso.MoveFile Fil, sFilePath & DisFileName & "." & sFileNameExNoEx:
Next
'掃描子目錄
If SubCheck.Value = 1 Then
For Each Fol In Fol.subfolders
SeachFile Fol, strSourceEx, strObjectEx
Next
End If
End SubPrivate Sub btnStart_Click()
Call SeachFile(txtPath.Text, "FDD", "FD")
MsgBox "OK"
End SubPrivate Sub DriveList_Change()
'On Error Resume Next
DirList.Path = DriveList.Drive
End SubPrivate Sub DirList_Change()
txtPath.Text = DirList.Path
End SubPrivate Function GetFileCreatedTime(lpFileNmae As String) As String
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(lpFileNmae)
Dim GetTime As String
GetFileCreatedTime = Format(f.DateLastModified, "YYYYMMDDHHMMSS")
End Function