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

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

Dim source As String
Dim destination  As String
Dim saveDir As String

Private Sub Command1_Click()
Dim adoConnection As New ADODB.Connection
Dim adoRecordset As New ADODB.Recordset
adoConnection.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, adLockOptimistic
While Not adoRecordset.EOF

Str1 = "CMD  /c Copy " & destination & "/" & adoRecordset.Fields("身份证") & ".jpg " & saveDir & "/" & adoRecordset.Fields("姓名") & ".jpg"
Debug.Print Str1
Shell Str1, vbHide
adoRecordset.MoveNext
Wend

End Sub

Private Sub Command2_Click()
CommonDialog1.Filter = "xls|*.xls"
CommonDialog1.ShowOpen
source = CommonDialog1.FileName
sourcepath.Text = source
End Sub

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

End Sub

Private Sub Command4_Click()
saveDir = SelectDir("C:/", "请选择所目的文件夹")
depath.Text = saveDir
End 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 Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long
Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Dim 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 = Address
End 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 Select
End Function

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