从图片库中批量查找指定的图片并按自己的要求命名

        晚上用VB写了一个导照片的程序，其问题如下：已知有一个图片库，图片库中的图片都以学生身份证命名， 我想在这大量的图片库中找出自已班级学生的照片，然后以姓名命名，如果手动一个一个查找还要改名相当麻烦，就算使用WINDOWS系统自带的搜索功能，一次最多找到四个身份证的图片（不知是什么原因或许系统自带的搜索对输入查找字符有限制，因身份证很长所以只能找到少数的图片）。我的解决思路：首先自己创建一个EXCEL表格，一列放学生姓名，一列放学生身份证号，然后程序读取EXCEL的身份证单元格到图片库中查找，找到后COPY到目的地文件夹，COPY到目的文件夹的时候马上到EXCEL里查找该身份证对应的姓名，以姓名命名保存，程序从EXCEL第一行一直读到最后一行就完成了所有工作。其源码如下：

Dim source As StringDim destination  As StringDim saveDir As String

Private Sub Command1_Click()Dim adoConnection As New ADODB.ConnectionDim adoRecordset As New ADODB.RecordsetadoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & source & ";Extended Properties='Excel 8.0;HDR=Yes'"adoRecordset.Open "select * from [Sheet1$]", adoConnection, adOpenKeyset, adLockOptimisticWhile Not adoRecordset.EOF

Str1 = "CMD  /c Copy " & destination & "/" & adoRecordset.Fields("身份证") & ".jpg " & saveDir & "/" & adoRecordset.Fields("姓名") & ".jpg"Debug.Print Str1Shell Str1, vbHideadoRecordset.MoveNextWend

End Sub

Private Sub Command2_Click()CommonDialog1.Filter = "xls|*.xls"CommonDialog1.ShowOpensource = CommonDialog1.FileNamesourcepath.Text = sourceEnd Sub

Private Sub Command3_Click()Dim strDir As StringstrDir = SelectDir("C:/", "请选择图片所在文件夹")picpath.Text = strDirdestination = picpath.Text

End Sub

Private Sub Command4_Click()saveDir = SelectDir("C:/", "请选择所目的文件夹")depath.Text = saveDirEnd Sub

Option Explicit

Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _    ByVal hWnd As Long, _    ByVal wMsg As Long, _    ByVal wParam As Long, _    ByVal lParam As String) As LongDeclare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _    ByVal pidl As Long, _    ByVal pszPath As String) As LongDeclare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _    lpBrowseInfo As BROWSEINFO) As LongType BROWSEINFO    hOwner As Long    pidlRoot As Long    pszDisplayName As String    lpszTitle As String    ulFlags As Long    lpfnCallback As Long    lParam As Long    iImage As LongEnd TypeDim xStartPath As String

Function SelectDir(Optional StartPath As String, Optional Titel As String) As String    Dim iBROWSEINFO As BROWSEINFO    With iBROWSEINFO        .lpszTitle = IIf(Len(Titel), Titel, "【请选择文件夹】")        .ulFlags = 7        If Len(StartPath) Then        xStartPath = StartPath & vbNullChar        .lpfnCallback = GetAddressOf(AddressOf CallBack)        End If    End With    Dim xPath As String, NoErr As Long: xPath = Space$(512)    NoErr = SHGetPathFromIDList(SHBrowseForFolder(iBROWSEINFO), xPath)    SelectDir = IIf(NoErr, Left$(xPath, InStr(xPath, Chr(0)) - 1), "")End Function

Function GetAddressOf(Address As Long) As Long    GetAddressOf = AddressEnd Function

Function CallBack(ByVal hWnd As Long, _                  ByVal Msg As Long, _                  ByVal pidl As Long, _                  ByVal pData As Long) As Long    Select Case Msg        Case 1            Call SendMessage(hWnd, 1126, 1, xStartPath)        Case 2            Dim sDir As String * 64, tmp As Long            tmp = SHGetPathFromIDList(pidl, sDir)            If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir    End SelectEnd Function

写这个程序的过程中我学到VB中打开文件夹对话框要调用API与打开文件对话框不一样，shell内部DOS命令的时候使用方法，EXCEL数据的读取等