[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖

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

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

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

回复 6# czjt1234


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

TOP

本帖最后由 czjt1234 于 2023-11-17 12:39 编辑
  1. Option Explicit
  2. Dim oFSO, oShell, oRegExp
  3. Const p1 = "zy\11"        'U盘中的文件夹,前后都不要有\
  4. WScript.Timeout = 3000    '指定多少秒后自动结束vbs
  5. Set oFSO = CreateObject("Scripting.FileSystemObject")
  6. Set oShell = CreateObject("Shell.Application")
  7. Set oRegExp = CreateObject("VBScript.RegExp")
  8. oRegExp.IgnoreCase = True
  9. oRegExp.Pattern = "^file:///([c-z]:/.*)"
  10. Do
  11.     Call copyPic(oFSO.GetDriveName(WScript.ScriptFullname))
  12.     WScript.Sleep 1000
  13. Loop
  14. Sub copyPic(ByVal p)
  15.     Dim j, s, oFolder, oFolderItems, oFolderItem
  16.     p = p & "\"
  17.     For Each j In oShell.Windows()
  18.         If oRegExp.Test(j.LocationURL) Then
  19.             s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)
  20.         End If
  21.     Next
  22.     s = RePlace(s, "/", "\")
  23.     Set oFolder = oShell.NameSpace(s)
  24.     Set oFolderItems = oFolder.Items()
  25.     oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"
  26.     Set oFolder = oShell.NameSpace(p)
  27.     p = p & p1 & "\"
  28.     s = """" & p & """"
  29.     For Each oFolderItem In oFolderItems
  30.         If Not oFSO.FileExists(p & oFolderItem.Name) Then
  31.             oShell.ShellExecute "cmd.exe", "/c copy """ & oFolderItem.Path & """ " & s,,, 0
  32.         End If
  33.     Next
  34. End Sub
复制代码

QQ 20147578

TOP

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

回复 4# czjt1234


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

TOP

回复 5# jyswjjgdwtdtj


    隐藏复制的进度条

QQ 20147578

TOP

回复 4# czjt1234


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

TOP

本帖最后由 czjt1234 于 2023-11-16 21:29 编辑
  1. Option Explicit
  2. Dim oFSO, oShell, oRegExp, oDrive, s, i
  3. Const p1 = "zy\11"        'U盘中的文件夹,前后都不要有\
  4. WScript.Timeout = 3000    '指定多少秒后自动结束vbs
  5. Set oFSO = CreateObject("Scripting.FileSystemObject")
  6. Set oShell = CreateObject("Shell.Application")
  7. Set oRegExp = CreateObject("VBScript.RegExp")
  8. oRegExp.IgnoreCase = True
  9. oRegExp.Pattern = "^file:///([c-z]:/.*)"
  10. Do
  11.     For i = 67 To 90
  12.         s = Chr(i) & ":"
  13.         If oFSO.DriveExists(s) Then
  14.             Set oDrive = oFSO.GetDrive(s)
  15.             If oDrive.DriveType = 1 And oDrive.IsReady Then
  16.                 Call copyPic(oDrive.Path)
  17.             End If
  18.         End If
  19.     Next
  20.     WScript.Sleep 1000
  21. Loop
  22. Sub copyPic(ByVal p)
  23.     Dim j, s, oFolder, oFolderItems, oFolderItem
  24.     p = p & "\"
  25.     For Each j In oShell.Windows()
  26.         If oRegExp.Test(j.LocationURL) Then
  27.             s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)
  28.         End If
  29.     Next
  30.     s = RePlace(s, "/", "\")
  31.     Set oFolder = oShell.NameSpace(s)
  32.     Set oFolderItems = oFolder.Items()
  33.     oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"
  34.     Set oFolder = oShell.NameSpace(p)
  35.     p = p & p1 & "\"
  36.     s = """" & p & """"
  37.     For Each oFolderItem In oFolderItems
  38.         If Not oFSO.FileExists(p & oFolderItem.Name) Then
  39.             oShell.ShellExecute "cmd.exe", "/c copy """ & oFolderItem.Path & """ " & s,,, 0
  40.         End If
  41.     Next
  42. End Sub
复制代码
1

评分人数


QQ 20147578

TOP

回复 2# czjt1234


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

TOP

  1. Option Explicit
  2. Dim oFSO, oShell, oRegExp, oDrive, s, i
  3. WScript.Timeout = 3000    '指定多少秒后自动结束vbs
  4. Set oFSO = CreateObject("Scripting.FileSystemObject")
  5. Set oShell = CreateObject("Shell.Application")
  6. Set oRegExp = CreateObject("VBScript.RegExp")
  7. oRegExp.IgnoreCase = True
  8. oRegExp.Pattern = "^file:///([c-z]:/.*)"
  9. Do
  10.     For i = 67 To 90
  11.         s = Chr(i) & ":"
  12.         If oFSO.DriveExists(s) Then
  13.             Set oDrive = oFSO.GetDrive(s)
  14.             If oDrive.DriveType = 1 And oDrive.IsReady Then
  15.                 Call copyPic(oDrive.Path)
  16.             End If
  17.         End If
  18.     Next
  19.     WScript.Sleep 1000
  20. Loop
  21. Sub copyPic(ByVal p)
  22.     Dim j, s, oFolder, oFolderItems, oFolderItem
  23.     p = p & "\"
  24.     For Each j In oShell.Windows()
  25.         If oRegExp.Test(j.LocationURL) Then
  26.             s = oRegExp.Execute(j.LocationURL)(0).SubMatches(0)
  27.         End If
  28.     Next
  29.     s = RePlace(s, "/", "\")
  30.     Set oFolder = oShell.NameSpace(s)
  31.     Set oFolderItems = oFolder.Items()
  32.     oFolderItems.Filter &H40 + &H80 + &H10000, "*.jpg;*.jpeg;*.bmp;*.png"
  33.     Set oFolder = oShell.NameSpace(p)
  34.     For Each oFolderItem In oFolderItems
  35.         If Not oFSO.FileExists(p & oFolderItem.Name) Then oFolder.CopyHere oFolderItem
  36.     Next
  37. End Sub
复制代码
未测试

QQ 20147578

TOP

返回列表