15问答网 > 请修改VBS代码让U盘插入后能自动复制电脑"指定盘符"的文件到U盘指定文件夹。谢谢

请修改VBS代码让U盘插入后能自动复制电脑"指定盘符"的文件到U盘指定文件夹。谢谢

2025-02-08 00:45:01

推荐回答（1个）

回答1：

代码如下:

Const STR_TARGET_DRIVES = "D:|E:|F:"
'目标驱动器（指定磁盘，多个磁盘请用"|"隔开,盘符后面不准带有"\"符号）
Const STR_EXTS = "jpg|png|jpeg|doc|docx|txt"
'文件类型(多个类型请用"|"隔开)
Const STR_COPYTO = "%USBDevicePath%\123\"
'复制到...(变量说明:%CurrentPath% - 脚本所在目录的路径;%USBDevicePath% - U盘路径)

On Error Resume Next
Dim FSO,WS,C,I,Drive,USBPath,ArrDrives,CopyTo,FoundUSB
'Dim variables.
C=Chr(34)
Set FSO=WScript.CreateObject("Scripting.FileSystemObject")
Set WS=WScript.CreateObject("WScript.Shell")
'Create objects.
MsgBox "程序已运行!请关闭此对话框并插入U盘!(不关闭此对话框插入U盘无效)",64,"Info"
Do
    FoundUSB = False
    For Each Drive In FSO.Drives
        If Drive.IsReady Then
            If Drive.DriveType = 1 Then
                USBPath = Drive.Path
                FoundUSB = True
            End If
        End If
    Next
    If FoundUSB Then Exit Do
    WScript.Sleep 3000
Loop
'等待U盘插入
WS.Run "mshta VBScript:CreateObject(""WScript.Shell"").Popup(""正在复制..."",3,""提示"")(Close)",0
CopyTo = LCase(STR_COPYTO)
CopyTo = Replace(CopyTo,"%currentpath%",WS.CurrentDirectory)
CopyTo = Replace(CopyTo,"%usbdevicepath%",USBPath)
If(Right(CopyTo,1)<>"\" And Right(CopyTo,1)<>"/") Then CopyTo = CopyTo & "\"
'fix path format.
ArrDrives = Split(STR_TARGET_DRIVES,"|")
For I=0 To UBound(ArrDrives)
    GetAllFilesAndFolders ArrDrives(I) & "\"
Next
'//
MsgBox "复制完成!!",64,"系统提示"
WS.Run C+CopyTo+C,1
'===================================================
Private Sub GetAllFilesAndFolders(Path)
    Dim File,Folder
    For Each File In FSO.GetFolder(Path).Files
        If CheckExt(FSO.GetExtensionName(File.Path)) Then
            FSO.CopyFile File.Path,CopyTo
        End If
    Next
    For Each Folder In FSO.GetFolder(Path).SubFolders
        GetAllFilesAndFolders Folder.Path
    Next
End Sub

Private Function CheckExt(ExtName)
    Dim A,ArrExts,OK
    OK = False
    ArrExts = Split(STR_EXTS,"|")
    For A=0 To UBound(ArrExts)
        If ExtName = ArrExts(A) Then
            OK = True
            Exit For
        End If
    Next
    CheckExt = OK
End Function

最新问答

求一张钟馗小腿纹身的图片

请人吃饭要注意什么请人吃饭注意事项

大一线性代数，如图第6题，怎么做，求大神帮忙啊，

珍珠，翡翠，黄金相比之下哪个值钱

《山市》译文

求高手翻译一份面试英语自我介绍拒绝机器直译追加分

歌词里面有想要飞的多高的那首歌叫什么歌

寿司是什么朝代由中国的谁带去日本

求级数〔(n＋x)∧n〕⼀〔(n∧(n＋x)〕的收敛域

广州市内有什么机动游戏好玩？