<%@ Language="VBScript" CodePage="65001" %>
<%
Option Explicit
Response.Charset = "utf-8"
Response.CodePage = 65001
Dim srcUrl, saveVirtualDir, newFileName, msg
srcUrl         = "http://xxx.com/test.xlsx"
saveVirtualDir = "/files/test_folder/"                    ' 网站目录（虚拟路径）
newFileName    = "databasedoc.xlsx"   
msg = FetchFile(srcUrl, saveVirtualDir, newFileName)
Response.Write "<meta charset=""utf-8"">" & Server.HTMLEncode(msg)
'------------------------------------------------------------
' 主函数：下载并保存，返回结果说明文字
'------------------------------------------------------------
Function FetchFile(url, virtualDir, fileName)
    Dim fso, dirPath, relPath, savePath
    Dim http, stream, binData, errDesc
    '--- 1. 计算物理路径 -------------------------------------
    ' 说明：对尚未创建的目录，Server.MapPath(virtualDir) 有时会抛错，
    '       所以这里用 MapPath("/") 拼接相对路径，最稳。
    On Error Resume Next
    relPath = Replace(Trim(virtualDir), "/", "\")
    Do While Left(relPath, 1) = "\"
        relPath = Mid(relPath, 2)
    Loop
    dirPath = Server.MapPath("/")
    If Right(dirPath, 1) <> "\" Then dirPath = dirPath & "\"
    dirPath = dirPath & relPath
    If Right(dirPath, 1) = "\" Then dirPath = Left(dirPath, Len(dirPath) - 1)
    Set fso = Server.CreateObject("Scripting.FileSystemObject")
    If Err.Number <> 0 Then
        errDesc = Err.Description : Err.Clear : On Error GoTo 0
        FetchFile = "失败：无法创建 FileSystemObject - " & errDesc
        Exit Function
    End If
    On Error GoTo 0
    '--- 2. 目录不存在则自动创建 ------------------------------
    If Not EnsureFolder(fso, dirPath) Then
        FetchFile = "失败：目录不存在且创建失败 - " & dirPath
        Exit Function
    End If
    savePath = fso.BuildPath(dirPath, fileName)
    '--- 3. 创建 HTTP 组件 ------------------------------------
    Set http = CreateHttp()
    If http Is Nothing Then
        FetchFile = "失败：无法创建 HTTP 组件（MSXML2.ServerXMLHTTP / WinHttp.WinHttpRequest）"
        Exit Function
    End If
    '--- 4. 发送 GET 请求 -------------------------------------
    On Error Resume Next
    Err.Clear
    http.Open "GET", url, False
    If Err.Number = 0 Then
        http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36"
        http.setRequestHeader "Accept", "*/*"
        http.Send
    End If
    If Err.Number <> 0 Then
        errDesc = Err.Description : Err.Clear : On Error GoTo 0
        Set http = Nothing
        FetchFile = "失败：请求远程文件出错 - " & errDesc
        Exit Function
    End If
    On Error GoTo 0
    '--- 5. 校验 HTTP 状态 ------------------------------------
    If http.Status <> 200 Then
        errDesc = "HTTP " & http.Status & " " & http.statusText
        Set http = Nothing
        FetchFile = "失败：远程返回 " & errDesc
        Exit Function
    End If
    binData = http.responseBody      ' 二进制字节数组
    Set http = Nothing
    '--- 6. 用 ADODB.Stream 写二进制到磁盘 --------------------
    On Error Resume Next
    Err.Clear
    Set stream = Server.CreateObject("ADODB.Stream")
    stream.Type = 1                  ' adTypeBinary
    stream.Open
    stream.Write binData
    stream.SaveToFile savePath, 2    ' adSaveCreateOverWrite
    stream.Close
    Set stream = Nothing
    If Err.Number <> 0 Then
        errDesc = Err.Description : Err.Clear : On Error GoTo 0
        FetchFile = "失败：写入文件出错 - " & errDesc
        Exit Function
    End If
    On Error GoTo 0
    FetchFile = "成功：已保存到 " & savePath & "（" & LenB(binData) & " 字节）"
End Function
'------------------------------------------------------------
' 创建 HTTP 组件（多 ProgID 兼容，按顺序尝试）
'------------------------------------------------------------
Function CreateHttp()
    Dim h, progIds, i
    progIds = Array("MSXML2.ServerXMLHTTP.6.0", _
                    "MSXML2.ServerXMLHTTP.3.0", _
                    "MSXML2.ServerXMLHTTP", _
                    "WinHttp.WinHttpRequest.5.1")
    Set CreateHttp = Nothing
    For i = 0 To UBound(progIds)
        On Error Resume Next
        Err.Clear
        Set h = Server.CreateObject(progIds(i))
        If Err.Number = 0 And Not h Is Nothing Then
            ' 超时：解析/连接/发送/接收（毫秒）
            h.setTimeouts 30000, 30000, 60000, 180000
            ' 若目标站 SSL 证书有问题，可打开下面这行忽略证书错误（有安全风险）
            ' h.setOption 2, 13056
            On Error GoTo 0
            Set CreateHttp = h
            Exit Function
        End If
        Err.Clear
        On Error GoTo 0
    Next
End Function
'------------------------------------------------------------
' 递归创建目录（支持多级）
'------------------------------------------------------------
Function EnsureFolder(fso, folderPath)
    Dim parent
    On Error Resume Next
    If fso.FolderExists(folderPath) Then
        EnsureFolder = True
        Exit Function
    End If
    parent = fso.GetParentFolderName(folderPath)
    If Len(parent) > 0 Then
        If Not fso.FolderExists(parent) Then
            EnsureFolder fso, parent       ' 递归创建父目录
        End If
    End If
    fso.CreateFolder folderPath
    EnsureFolder = fso.FolderExists(folderPath)
    On Error GoTo 0
End Function
%>