strainny wrote:
另原文問的現在還想不通,譬如"丁",他對應的網址是https://www.cns11643.gov.tw/wordView.jsp?ID=82979此網址中的ID=82979和丁的關聯是?
Clark741224 wrote:
1頁基本上都沒有問題,但如是台股全部2048頁該如何抓呢?
Sub get_all()
Dim i As Integer, UrL As String
For i = 3 To 10 'i=3~n
UrL = "https://concords.moneydj.com/z/zc/zca/zca_" & Sheets("工作表1").Cells(i, 2) & ".djhtm"
Call Get_moneydj(UrL, i)
'延遲用，時間愈長，被網站ban的可能性愈低，不用也行，建議加上
'2秒
Application.Wait (Now + TimeValue("0:00:02"))
Next i
End Sub
Sub Get_moneydj(UrL As String, i As Integer)
Dim HTML As Object, GetXml As Object, j As Integer
Set HTML = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
On Error Resume Next
Sheets("工作表1").Range("c" & i & ":ac" & i).Clear
Sheets("工作表1").Cells(i, 5) = "最高本益比"
Sheets("工作表1").Cells(i, 14) = "最低本益比"
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
HTML.body.innerhtml = .responsetext
Set Table = HTML.all.tags("table")(2).Rows
Sheets("工作表1").Cells(i, 3) = Table(4).Cells(1).innertext
Sheets("工作表1").Cells(i, 4) = Table(20).Cells(1).innertext
Set Table = HTML.all.tags("table")(3).Rows
For j = 1 To 8
Sheets("工作表1").Cells(i, j + 5) = Table(3).Cells(j).innertext
Sheets("工作表1").Cells(i, j + 14) = Table(4).Cells(j).innertext
Next j
End With
Set HTML = Nothing
Set GetXml = Nothing
End Sub
smart3135 wrote:
原本IE是設定Visible，但不知如何修改成CHROME
Sub test_Ctrla_Ctrlc()
Dim chrome As New Selenium.ChromeDriver, keys As New keys, UrL As String
UrL = "https://www.mobile01.com/topiclist.php?f=511"
With chrome
.Get UrL
'.Window.Maximize
.Wait 5000
.Keyboard.KeyDown (keys.Control)
.SendKeys "a"
.Keyboard.KeyUp (keys.Control)
'.Wait 1000
.Keyboard.KeyDown (keys.Control)
.SendKeys "c"
.Keyboard.KeyUp (keys.Control)
'.Wait 3000
End With
With Sheets("工作表1")
.Select
Call SheetClear("工作表1")
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=False ' true
.Columns.AutoFit
.Cells(1, 1).Select
End With
chrome.Quit
Set chrome = Nothing
End Sub
Sub test_Clipboard()
Dim chrome As New Selenium.ChromeDriver, Clipboard As Object, UrL As String
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
UrL = "https://www.mobile01.com/topiclist.php?f=511"
With chrome
.Get UrL
'.Window.Maximize
.Wait 5000
'Dim s As String
's = .FindElementByTag("body").Text
'Debug.Print s
Clipboard.SetText .FindElementByTag("body").Text
Clipboard.PutInClipboard
End With
With Sheets("工作表1")
.Select
Call SheetClear("工作表1")
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=True
.Columns.AutoFit
.Cells(1, 1).Select
End With
chrome.Quit
Set chrome = Nothing
End Sub
Sub SheetClear(sheetName As String)
Dim all_shape As shape
Sheets(sheetName).Cells.Clear
Debug.Print sheetName, Sheets(sheetName).Shapes.Count
For Each all_shape In Sheets(sheetName).Shapes
all_shape.Delete
Next
End Sub
smart3135 wrote:
但公司目前的資安非常嚴格，連外網都沒辦法連，更不用說讓我去安裝一些從網上抓的軟體
smart3135 wrote:
把VBA的程式碼改成開啟EDGE呢
#If Win64 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub test()
Dim Target As String, Wsh As Object, Run_App As Object, UrL As String, title As String
Set Wsh = CreateObject("WScript.Shell")
UrL = "https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=123"
title = "(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料 (第123頁) - Mobile01 - Google Chrome"
Target = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe " & UrL
'這裡要特別注意，視窗標題，是工作管理員裡面看到的那個
'但也有例外，特殊符號、unicode、不可見字元…像edge的標題就不一樣
'title = "(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料 (第123頁) - Mobile01 - 設定檔 1 - Microsoft? Edge"
'Target = "C:\Program Files (x86)\Microsoft\Edge\Application\102.0.1245.33\msedge.exe " & UrL
Set Run_App = Wsh.exec(Target)
Sleep 5000
AppActivate title
Sleep 1000
SendKeys "^a", True
Sleep 3000
SendKeys "^c", True
Sleep 3000
With Sheets("工作表1")
.Select
.Cells.Clear
.Cells(1, 1).Select
Sleep 6000
.PasteSpecial NoHTMLFormatting:=True 'false
.Columns.AutoFit
.Cells(1, 1).Select
End With
If Run_App.Status = 0 Then Run_App.Terminate
Set Run_App = Nothing
Set Wsh = Nothing
End Sub
#If Win64 Then
Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
#Else
Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
#End If
Sub findtitle()
Dim AppTitle As String
AppTitle = find_windows_full_title("不定期") '輸入部份特定關鍵字即可
Debug.Print AppTitle, Len(AppTitle)
'Cells(1, 1) = AppTitle
End Sub
Function find_windows_full_title(s As String) As String
Dim apphWnd As Long, AppTitle As String
apphWnd = FindWindow(vbNullString, vbNullString)
While apphWnd
AppTitle = Space(255)
AppTitle = Left(AppTitle, GetWindowText(apphWnd, AppTitle, Len(AppTitle)))
If AppTitle Like "*" & s & "*" Then
find_windows_full_title = AppTitle
Exit Function
End If
apphWnd = GetWindow(apphWnd, 2)
Wend
End Function
snare wrote:
目前不行，微軟沒有做(恕刪)
smart3135 wrote:
另外您1228樓的程式碼，不需要另外安裝其它軟體，像SeleniumBasic這些嗎？
smart3135 wrote:
excel vba開啟IE的時候，必須要設定IE Visible=False，不能讓網頁開啟(但仍能複製網頁內容)，如果網頁開起來的話，在執行過程中就會出錯
smart3135 wrote:
不知道是不是有辦法讓chrome不要開啟，但一樣能複貼網址內容並貼上呢？
