Board logo

标题: [问题求助] [已解决]大佬能不能帮忙写个vbs复制图片到U盘 [打印本页]
作者: abcdsys    时间: 2023-11-14 13:23     标题: [已解决]大佬能不能帮忙写个vbs复制图片到U盘

本帖最后由 abcdsys 于 2023-11-16 17:26 编辑

各位大佬，能不能帮忙写个vbs，
需求是 后台复制当前打开的文件夹中图片格式的文件到U盘中，U盘的盘符不能确定。
感谢
作者: czjt1234    时间: 2023-11-15 21:12

  1. Option Explicit

  2. Dim oFSO, oShell, oRegExp, oDrive, s, i

  3. 

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

  5. 

  6. Set oFSO = CreateObject("Scripting.FileSystemObject")

  7. Set oShell = CreateObject("Shell.Application")

  8. Set oRegExp = CreateObject("VBScript.RegExp")

  9. oRegExp.IgnoreCase = True

  10. oRegExp.Pattern = "^file:///([c-z]:/.*)"

  11. 

  12. Do

  13.     For i = 67 To 90

  14.         s = Chr(i) & ":"

  15.         If oFSO.DriveExists(s) Then

  16.             Set oDrive = oFSO.GetDrive(s)

  17.             If oDrive.DriveType = 1 And oDrive.IsReady Then

  18.                 Call copyPic(oDrive.Path)

  19.             End If

  20.         End If

  21.     Next

  22.     WScript.Sleep 1000

  23. Loop

  24. 

  25. Sub copyPic(ByVal p)

  26.     Dim j, s, oFolder, oFolderItems, oFolderItem

  27.     p = p & "\"

  28.     For Each j In oShell.Windows()

  29.         If oRegExp.Test(j.LocationURL) Then

  30.             s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)

  31.         End If

  32.     Next

  33.     s = RePlace(s, "/", "\")

  34.     Set oFolder = oShell.NameSpace(s)

  35.     Set oFolderItems = oFolder.Items()

  36.     oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"

  37.     Set oFolder = oShell.NameSpace(p)

  38.     For Each oFolderItem In oFolderItems

  39.         If Not oFSO.FileExists(p & oFolderItem.Name) Then oFolder.CopyHere oFolderItem

  40.     Next

  41. End Sub
复制代码
未测试
作者: abcdsys    时间: 2023-11-16 15:40

回复 2# czjt1234


    感谢大佬，可以使用
还有一个问题，能不能静默复制，不要显示复制的进度条，还有可以指定复制到U盘的某个文件夹吗？
谢谢
作者: czjt1234    时间: 2023-11-16 16:19

本帖最后由 czjt1234 于 2023-11-16 21:29 编辑 
  1. Option Explicit

  2. Dim oFSO, oShell, oRegExp, oDrive, s, i

  3. 

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

  5. 

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

  7. 

  8. Set oFSO = CreateObject("Scripting.FileSystemObject")

  9. Set oShell = CreateObject("Shell.Application")

  10. Set oRegExp = CreateObject("VBScript.RegExp")

  11. oRegExp.IgnoreCase = True

  12. oRegExp.Pattern = "^file:///([c-z]:/.*)"

  13. 

  14. Do

  15.     For i = 67 To 90

  16.         s = Chr(i) & ":"

  17.         If oFSO.DriveExists(s) Then

  18.             Set oDrive = oFSO.GetDrive(s)

  19.             If oDrive.DriveType = 1 And oDrive.IsReady Then

  20.                 Call copyPic(oDrive.Path)

  21.             End If

  22.         End If

  23.     Next

  24.     WScript.Sleep 1000

  25. Loop

  26. 

  27. Sub copyPic(ByVal p)

  28.     Dim j, s, oFolder, oFolderItems, oFolderItem

  29.     p = p & "\"

  30.     For Each j In oShell.Windows()

  31.         If oRegExp.Test(j.LocationURL) Then

  32.             s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)

  33.         End If

  34.     Next

  35.     s = RePlace(s, "/", "\")

  36.     Set oFolder = oShell.NameSpace(s)

  37.     Set oFolderItems = oFolder.Items()

  38.     oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"

  39.     Set oFolder = oShell.NameSpace(p)

  40.     p = p & p1 & "\"

  41.     s = """" & p & """"

  42.     For Each oFolderItem In oFolderItems

  43.         If Not oFSO.FileExists(p & oFolderItem.Name) Then

  44.             oShell.ShellExecute "cmd.exe", "/c copy """ & oFolderItem.Path & """ " & s,,, 0

  45.         End If

  46.     Next

  47. End Sub
复制代码
作者: jyswjjgdwtdtj    时间: 2023-11-16 22:07

回复 4# czjt1234


    何必又用fso又用shell.application又用cmd呢
作者: czjt1234    时间: 2023-11-17 09:28

回复 5# jyswjjgdwtdtj


    隐藏复制的进度条
作者: abcdsys    时间: 2023-11-17 10:38

本帖最后由 abcdsys 于 2023-11-17 11:18 编辑

回复 4# czjt1234


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

本帖最后由 czjt1234 于 2023-11-17 12:39 编辑 
  1. Option Explicit

  2. Dim oFSO, oShell, oRegExp

  3. 

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

  5. 

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

  7. 

  8. Set oFSO = CreateObject("Scripting.FileSystemObject")

  9. Set oShell = CreateObject("Shell.Application")

  10. Set oRegExp = CreateObject("VBScript.RegExp")

  11. oRegExp.IgnoreCase = True

  12. oRegExp.Pattern = "^file:///([c-z]:/.*)"

  13. 

  14. Do

  15.     Call copyPic(oFSO.GetDriveName(WScript.ScriptFullname))

  16.     WScript.Sleep 1000

  17. Loop

  18. 

  19. Sub copyPic(ByVal p)

  20.     Dim j, s, oFolder, oFolderItems, oFolderItem

  21.     p = p & "\"

  22.     For Each j In oShell.Windows()

  23.         If oRegExp.Test(j.LocationURL) Then

  24.             s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)

  25.         End If

  26.     Next

  27.     s = RePlace(s, "/", "\")

  28.     Set oFolder = oShell.NameSpace(s)

  29.     Set oFolderItems = oFolder.Items()

  30.     oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"

  31.     Set oFolder = oShell.NameSpace(p)

  32.     p = p & p1 & "\"

  33.     s = """" & p & """"

  34.     For Each oFolderItem In oFolderItems

  35.         If Not oFSO.FileExists(p & oFolderItem.Name) Then

  36.             oShell.ShellExecute "cmd.exe", "/c copy """ & oFolderItem.Path & """ " & s,,, 0

  37.         End If

  38.     Next

  39. End Sub
复制代码
作者: jyswjjgdwtdtj    时间: 2023-11-17 22:28

回复 6# czjt1234


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



欢迎光临 批处理之家 (http://www.bathome.net/) Powered by Discuz! 7.2