设为首页收藏本站
切换到宽版

 找回密码
 注册
搜索
批处理之家»论坛 › 其他脚本区 › VBS求助&讨论 › [已解决]大佬能不能帮忙写个vbs复制图片到U盘 ...
[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发新帖
查看: 14456|回复: 8

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

[复制链接]
abcdsys
发表于 2023-11-14 13:23:48 | 显示全部楼层 |阅读模式
本帖最后由 abcdsys 于 2023-11-16 17:26 编辑

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

举报

czjt1234
发表于 2023-11-15 21:12:29 | 显示全部楼层
  1. Option Explicit
  2. Dim oFSO, oShell, oRegExp, oDrive, s, i

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

  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]:/.*)"

  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

  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:06 | 显示全部楼层
回复 2# czjt1234


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

举报

czjt1234
发表于 2023-11-16 16:19:52 | 显示全部楼层
本帖最后由 czjt1234 于 2023-11-16 21:29 编辑
  1. Option Explicit
  2. Dim oFSO, oShell, oRegExp, oDrive, s, i

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

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

  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]:/.*)"

  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

  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
复制代码

评分

参与人数 1技术 +1 收起 理由
abcdsys + 1 感谢大佬

查看全部评分

回复

举报

jyswjjgdwtdtj
发表于 2023-11-16 22:07:27 | 显示全部楼层
回复 4# czjt1234


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

举报

czjt1234
发表于 2023-11-17 09:28:46 | 显示全部楼层
回复 5# jyswjjgdwtdtj


    隐藏复制的进度条
回复

举报

abcdsys
 楼主| 发表于 2023-11-17 10:38:17 | 显示全部楼层
本帖最后由 abcdsys 于 2023-11-17 11:18 编辑

回复 4# czjt1234


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

举报

czjt1234
发表于 2023-11-17 12:38:08 | 显示全部楼层
本帖最后由 czjt1234 于 2023-11-17 12:39 编辑
  1. Option Explicit
  2. Dim oFSO, oShell, oRegExp

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

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

  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]:/.*)"

  14. Do
  15.     Call copyPic(oFSO.GetDriveName(WScript.ScriptFullname))
  16.     WScript.Sleep 1000
  17. Loop

  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:08 | 显示全部楼层
回复 6# czjt1234


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

举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

Archiver|手机版|小黑屋|批处理之家 ( 渝ICP备10000708号 )

GMT+8, 2026-3-17 06:24 , Processed in 0.021401 second(s), 9 queries , File On.

Powered by Discuz! X3.5

© 2001-2026 Discuz! Team.

快速回复 返回顶部 返回列表