(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料

Dylan67 wrote:
我有付費這個網址https://www.104woo.com.tw/成為會員

Dylan67 wrote:
https://lvr.land.moi.gov.tw/，不行了，太久沒玩，好像要先取得Token，然後是json格式，拼了一上午找不到真實網址

Dylan67 wrote:
左邊是1552樓您公開資訊觀測站損益表的代碼，右邊是我用Fiddler嘗試找所有參數的畫面，我的疑問是，我並沒有辦法找到所有您代碼中的setRequestHeader(F12也找不到)

Dylan67 wrote:
可是找不到"檔案"

Sub Google_Drive_File_Name_ID_20251208()

    Dim URL As String, GetXml As Object, Html As Object, Table
    Dim i As Integer, j As Integer, Target As String, googlefile As String
     
    On Error GoTo checkid
     
    Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set Html = CreateObject("HtmlFile")
    
        
    Target = "d:\excel\googletest\" '暫存目錄
    If Dir(Target, vbDirectory) = "" Then MkDir Target
    '注意，暫存目錄下的檔案，會在無任何提示下刪除
    If Dir(Target & "*.*") <> "" Then Kill Target & "*.*"
    
    '共用資料夾網址
    
    URL = "https://drive.google.com/drive/folders/19gf7B5C8TjJfLVqddJvmmzA1qD0mec6V?usp=sharing"
 
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Range("A1:F1") = Array("檔名", "上次修改時間", "檔案大小", "Fileid", "Real link", "存檔位置+測試用新檔名")
    
 
    With GetXml
        
        .Open "GET", URL, False
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        
        .send
        
        If InStr(.responsetext, "Error 404") > 0 Then
            MsgBox "無檔案 or 網址錯誤", vbOKOnly, "Error"
            Exit Sub
        End If
        
        Html.body.innerhtml = .responsetext
        
        
        Set Table = Html.all.tags("table")(0).Rows
        
        With Sheets("工作表1")
            For i = 1 To Table.Length - 1
                For j = 0 To Table(i).Cells.Length - 1
                    If j = 3 And .Cells(i + 1, 3) <> "—" Then
                        .Cells(i + 1, j + 1) = Mid(Split(Table(i).Cells(j).innerhtml, "ssk=")(1), 13, 33)
                        .Cells(i + 1, j + 2) = "https://drive.usercontent.google.com/download?id=" & .Cells(i + 1, j + 1) & "&export=download"
                        .Cells(i + 1, j + 3) = Target & Format(Now(), "yyyymmddhhmmss") & "_" & .Cells(i + 1, 1)
                    Else
                        .Cells(i + 1, j + 1) = Replace(Table(i).Cells(j).innertext, Chr(13) & Chr(10) & "已共用", "")
                    End If
                Next j
                
                DoEvents

                If .Cells(i + 1, 5) <> "" Then
                    
                    GetXml.Open "GET", .Cells(i + 1, 5), False
                    GetXml.send
                    
                    '下載速度，視檔案大小決定，可能要等一下才會出現在下載目錄內
                    
                    With CreateObject("ADODB.Stream")
                        .Open
                        .Type = 1
                        .Write GetXml.responseBody
                        .SaveToFile Sheets("工作表1").Cells(i + 1, 6), 2
                        .Close
                    End With
                    
                End If
                
            Next i
            
            .Cells.Columns.AutoFit
            
        End With
         
 
    End With
    
    Set GetXml = Nothing
    Set Html = Nothing
        
 
    MsgBox "tesk OK"
    
checkid:

    If Err.Number <> 0 Then
         Debug.Print Err.Description
    End If
    
End Sub