百度网盘 <-> Rclone 转存 OneDrive 自动化VBS脚本

SmartMover.vbs

'---------------------------------------------------
' 百度网盘 <-> Rclone 转存 OneDrive 自动化VBS脚本
' Version: 0.422
'
' 功能：
'  - 按目录结构转存
'  - 配合 Folder Monitor 等文件夹监控工具
'  - 转存完毕后可删除源文件，节省硬盘空间
'  - 可通过 Telegram 和 ServerChan 推送通知
'  - 可保存转存日志
'
'---------------------------------------------------


Const BD_BASE = "C:\BaiduNetDiskDownload" '百度网盘下载默认目录，不用加斜杠！
Const OD_BASE = "greenpeer:/BaiduNetDiskMigration" '要使用Rclone上传到的目录，不用加斜杠！

Const RCLONE_PATH = "C:\rclone\" 'Rclone 所在目录
Const DEBUG_RUN = False '是否启用 -vv 运行命令（日常不建议开启，会导致日志文件和内存占用巨大）
Const DEL_SRCFILE = True ' 传输完成后删除源文件

Const LOG_ENABLED = False ' 是否启用详细日志
Const LOG_DIR = "C:\rclone\logs\" ' 日志文件夹

Const SC_ENABLED = True ' ServerChan 通知
Const SC_KEY = "" 'ServerChan推送

Const TG_ENABLED = True ' Telegram 机器人通知
Const TG_API_DOMAIN = "" ' Telegram API 域名，若网络环境受限请使用 https://github.com/manzoorwanijk/telegram-bot-api-worker 搭建反向代理
Const TG_BOT_KEY = "" ' Telegram Bot API Key
Const TG_CHAT = "" ' 收信人的 Telegram Chat ID，可通过 @myidbot 获得

'-------------------以下为程序源码-------------------

' Http Post
Function HttpPost (url, req)
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    xmlhttp.open "POST", url, False
    xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlhttp.setRequestHeader "Content-Length", Len(req)
    xmlhttp.send req
    ' MsgBox xmlhttp.responseText
    ' 出现问题请取消上方注释调试
End Function

' 递归创建文件夹
Function CreateFolderPr(fso, path)
    If fso.FolderExists(path) Then
        Exit Function
    End If
    If Not fso.FolderExists(fso.GetParentFolderName(path)) Then
        CreateFolderPr fso, fso.GetParentFolderName(path)
    End If
    fso.CreateFolder(path)
End Function

Function CreateFolder(path)
    Set fso = CreateObject("Scripting.FileSystemObject")
    CreateFolderPr fso, path
    Set fso = Nothing
End Function

' 日期格式化
Dim g_oSB : Set g_oSB = CreateObject("System.Text.StringBuilder")
Function sprintf(sFmt, aData)
   g_oSB.AppendFormat_4 sFmt, (aData)
   sprintf = g_oSB.ToString()
   g_oSB.Length = 0
End Function

Dim dt : dt = now()

' 写日志头
Function WriteLogHeader(logfile, execStatusTips, filename, start_at, cmd_minutes, cmdline, pid)
    Set adoStream = CreateObject("ADODB.Stream")
    With adoStream
            .Type = 2
            .Open
            .Charset = "UTF-8"
            .Position = 0
            .WriteText "File Name: " & filename & vbCrLf
            .WriteText "Task started at: " & start_at & vbCrLf
            .WriteText "Task Status: " & execStatusTips & vbCrLf
            .WriteText "Time: " & cmd_minutes & " min." & vbCrLf
            .WriteText "command line: " & cmdline & vbCrLf
            .WriteText "PID: " & pid & vbCrLf & vbCrLf
    End With
    Set binStream = CreateObject("ADODB.Stream")
    With binStream
            .Type = 1
            .Mode = 3
            .Open
    End With
    ' Skip BOM bytes
    With adoStream
            .Position = 3
            .CopyTo binStream
            .Flush
            .Close
    End With
    binStream.SaveToFile logfile, 2
    binStream.Close
    Set binStream = Nothing
    Set adoStream = Nothing
End function


''' Main 主程序
Set oArgs = WScript.Arguments
    For Each filepath In oArgs
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set f = fso.GetFile(filepath)
        Set fulldir = f.ParentFolder
        'MsgBox fulldir

        src = Replace(filepath, "\", "/", 1, -1, 1)
        'MsgBox src

        targetdir = Replace(fulldir, BD_BASE, OD_BASE, 1, -1, 1)
        targetdir = Replace(targetdir, "\", "/", 1, -1, 1)  + "/"

        'MsgBox targetdir

        'CreateFolder targetdir
        'f.Move targetdir
        
        If SC_ENABLED = True Then
            url = "https://sc.ftqq.com/" & SC_KEY & ".send"
            req = "text=" & f.Name & "已下载&desp=文件名：" & f.Name & "%0D%0D文件大小：" & f.Size & "字节%0D%0D文件正在上传，稍后将能在OneDrive中查看"
            HttpPost url, req
        End If

        If TG_ENABLED = True Then
            url = TG_API_DOMAIN & "/bot" & TG_BOT_KEY & "/sendMessage"
            req = "text=*" & f.Name & "*已下载%0A%0A文件大小：" & f.Size & "字节%0A文件正在上传，稍后将能在OneDrive中查看&chat_id=" & TG_CHAT & "&parse_mode=Markdown"
            HttpPost url, req
        End If

        If DEBUG_RUN = True Then
            rclone_cmd =  RCLONE_PATH & "rclone copy """ & src & """ """ & targetdir & """" & " -vv"
        Else
            rclone_cmd =  RCLONE_PATH & "rclone copy """ & src & """ """ & targetdir & """"
        End If 

        Set ws = CreateObject("WScript.Shell")
        Set oExec = ws.Exec(rclone_cmd)

        ' 等待Rclone执行完毕，并缓存输出
        While Not oExec.StdOut.AtEndOfStream
            sLine = oExec.StdOut.ReadLine
            If sLine <> "" Then strOutput = strOutput & sLine & vbCrLf
        Wend

        ' 检查执行结果
        Select Case oExec.Status
            Case 1 ' 成功
                execStatusTips = "Success!"
                'strOutput = oExec.StdOut.ReadAll()
            Case 2 ' 失败
                execStatusTips = "Failed."
                'strOutput = oExec.StdErr.ReadAll()
        End Select

        ' 命令执行时间
        Dim df : df = now()
        cmd_minutes = DateDiff("n", dt, df)

        If LOG_ENABLED = True Then
            '保存log
            CreateFolder LOG_DIR
            rclone_log_file = LOG_DIR & sprintf("{0:yyyyMMdd_HHmmss}", Array(dt)) & "_" & f.Name & ".log"

            ' UTF-8 写基本信息
            WriteLogHeader rclone_log_file, execStatusTips, f.Name, sprintf("{0:yyyy/MM/dd HH:mm:ss}", Array(dt)), cmd_minutes, rclone_cmd, oExec.ProcessID

            ' 往下写命令输出
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set o = fso.OpenTextFile(rclone_log_file, 8)
            o.writeline(strOutput)
            o.close()

            Set fso = Nothing
            ' MsgBox dt
        End If

        ' 发送通知
        If SC_ENABLED = True Then
            Select Case oExec.Status
            Case 1 ' 成功
                url = "https://sc.ftqq.com/" & SC_KEY & ".send"
                req = "text=" & f.Name & "已上传到OneDrive&desp=文件名：" & f.Name & "%0D%0D文件大小：" & f.Size & "字节%0D%0D文件已成功上传到OneDrive，耗时" & cmd_minutes & "分钟。"
                HttpPost url, req
            Case 2 ' 失败
                url = "https://sc.ftqq.com/" & SC_KEY & ".send"
                req = "text=" & f.Name & "上传到OneDrive失败了……&desp=文件名：" & f.Name & "%0D%0D文件大小：" & f.Size & "字节%0D%0D文件上传失败……建议您打开日志功能查看日志排查错误。命令耗时" & cmd_minutes & "分钟。"
                HttpPost url, req
            End Select
        End If

        If TG_ENABLED = True Then
            Select Case oExec.Status
            Case 1 ' 成功
                url = TG_API_DOMAIN & "/bot" & TG_BOT_KEY & "/sendMessage"
                req = "text=*" & f.Name & "*已上传到OneDrive%0A%0A文件大小：" & f.Size & "字节%0A文件已成功上传到OneDrive，耗时" & cmd_minutes & "分钟。&chat_id=" & TG_CHAT & "&parse_mode=Markdown"
                HttpPost url, req
            Case 2 ' 失败
                url = TG_API_DOMAIN & "/bot" & TG_BOT_KEY & "/sendMessage"
                req = "text=*" & f.Name & "*上传到OneDrive失败了……%0A%0A文件大小：" & f.Size & "字节%0A文件上传失败……建议您打开日志功能查看日志排查错误。命令耗时" & cmd_minutes & "分钟。&chat_id=" & TG_CHAT & "&parse_mode=Markdown"
                HttpPost url, req
            End Select
        End If
        
        '传输后删除源文件
        If DEL_SRCFILE = True Then
            Set fso = CreateObject("Scripting.FileSystemObject")
            fso.DeleteFile filepath
        End If
        
        Set fso = Nothing
        Set ws = Nothing
    Next
Set oArgs = Nothing