在大量图片上加上图片本身的文件名

Question

我的图片保存在我的电脑的D：/YT文件夹下，我想把YT文件夹下所有图片都加上每一个图片本身的文件名后，再把新图片存放在D：/XY文件夹下，不用带扩展名。请高手指点，最好是完整的代码，我自己也批处理就行，我的系统是WINXP的，谢谢！

Answer 1

Dim varFSO As Variant, varFolder As Folder, varFile As File
Dim TempString As String, SourceFolder As String, Target As String    SourceFolder = "D:\YT\": Target = "D:\XY\"    Set varFSO = CreateObject("Scripting.FileSystemObject")
    If varFSO.FolderExists(Target) <> True Then MkDir Target
    Set varFolder = varFSO.GetFolder(SourceFolder)
    
    For Each varFile In varFolder.Files
        TempString = Trim(Mid(varFile, InStrRev(varFile, "\") + 1))
        If Right(LCase(Trim(TempString)), 4) = (".jpg") Then
            TempString = Mid(TempString, 1, InStr(TempString, ".") - 1)
            FileCopy varFile, Target & TempString
        End If
    Next

Answer 2

最后追加一句
Set varFSO = Nothing

Answer 3

另一种
Option ExplicitPrivate Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As LongConst MaxLFNPath = 260
Const INVALID_HANDLE_VALUE = -1Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End TypePrivate Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MaxLFNPath
    cShortFileName As String * 14
End TypePrivate Sub Form_Load()
Dim WFD As WIN32_FIND_DATA
Dim hFile&, Source$, Target$, aa$, FN$, k    Source = "D:\YT\": Target = "D:\XY\"
    hFile = FindFirstFile(Source & "*.jpg", WFD)
    If hFile <> INVALID_HANDLE_VALUE Then
        Do
            aa = Trim(Trim(Source) & Trim(WFD.cFileName))
            k = InStr(aa, Chr(0))
            If k > 0 Then
                FN = Mid(aa, 1, k - 1)
                Temp = Mid(FN, InStrRev(FN, "\") + 1)
                Temp = Mid(Temp, 1, InStrRev(Temp, ".") - 1)
                FileCopy FN, Target & Temp
'                Debug.Print FN & " " & Target & Temp
            End If
        Loop While FindNextFile(hFile, WFD)
        
        Call FindClose(hFile)
    End If
    
End Sub