麻辣家族討論版版 - Powered by Discuz! Board

https://www.pinkoi.com/

複製代碼

Sub test()
'PS:要自己先用ie開啟https://www.pinkoi.com/網址
'並且用FB點選登入,不然下列語法將會找不到傳送訊息的部分,要有登入才可傳送訊息給別人
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate "https://www.pinkoi.com/user/testpkko"
Do While IE.Busy Or IE.readyState <> 4: DoEvents: Loop
With IE.Document
i = 0: On Error Resume Next
For Each E In .GetElementsByTagName("A")
A = E.Text
If CStr(A) = "傳送訊息" Then
E.Click '這邊呼叫出傳送訊息的視窗
'要如何控制該視窗輸入主旨+內文+選擇檔案呢?
Call WEB_DETAIL(IE) '我用網頁元素的部分無法查不出相關資訊
End If
Next
End With
End Sub

複製代碼

Sub WEB_DETAIL(IE)
With IE
Do While .Busy Or .readyState <> 4: DoEvents: Loop
With .Document
i = 0: On Error Resume Next
For Each E In .ALL
i = i + 1
Cells(i, "a") = E.tagname
Cells(i, "b") = E.ID
Cells(i, "c") = E.Name
Cells(i, "d") = E.Value
Cells(i, "e") = E.innertext
Cells(i, "f") = E.Type
Cells(i, "g") = E.href
Cells(i, "H") = E.Text
Next
End With
End With
End Sub

複製代碼

Sub test()
Dim ie As Object 'SHDocVw.InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")
Call login(ie) 'just for login
Call show_the_form(ie) 'My problem in here
End Sub
Sub login(ie)
ie.Visible = True
ie.Navigate "https://www.pinkoi.com/user/testpkko"
Do While ie.Busy Or ie.readyState <> 4: DoEvents: Loop
Dim anchorTags As Object 'MSHTML.IHTMLElementCollection
Set anchorTags = ie.document.GetElementsByTagName("A")
Dim oAnchorLoop As Object 'MSHTML.IHTMLAnchorElement
For Each oAnchorLoop In anchorTags
Dim anchorText As String
anchorText = oAnchorLoop.Text
If anchorText = ChrW(20659) & ChrW(36865) & ChrW(35338) & ChrW(24687) Then
Dim oAnchorLogon As Object 'MSHTML.IHTMLAnchorElement2
Set oAnchorLogon = oAnchorLoop
oAnchorLogon.Click
Exit For
End If
Next
Do While ie.Busy Or ie.readyState <> 4: DoEvents: Loop
'* so now logon form should be visible
On Error Resume Next
Dim oUserNameInput As Object 'MSHTML.IHTMLInputElement
Set oUserNameInput = ie.document.getElementById("n-login-id")
nowtime = Timer
Do While ie.Busy Or ie.readyState <> 4 Or oUserNameInput Is Nothing
DoEvents
If Timer - nowtime > 1 Then Exit Do 'Already logoin
Set oUserNameInput = ie.document.getElementById("n-login-id")
Loop
oUserNameInput.Value = "testpkko"
Dim oUserPassword As Object 'MSHTML.IHTMLInputElement
Set oUserPassword = ie.document.getElementById("n-login-password")
oUserPassword.Value = "abc123"
Dim oListElement As Object 'MSHTML.HTMLLIElement
Set oListElement = oUserNameInput.parentElement
Dim oUnorderedList As Object 'MSHTML.IHTMLUListElement
Set oUnorderedList = oListElement.parentElement
Dim oForm As Object 'MSHTML.IHTMLFormElement
Set oForm = oUnorderedList.parentElement
Dim oSubmitInputElememt As Object 'MSHTML.HTMLInputElement
Set oSubmitInputElememt = Nothing
Dim lFormChildrenLoop As Long
For lFormChildrenLoop = 1 To oForm.all.Length
If oForm.elements.Item(lFormChildrenLoop).Type = "submit" Then
Set oSubmitInputElememt = oForm.elements.Item(lFormChildrenLoop)
Exit For
End If
Next lFormChildrenLoop
If Not oSubmitInputElememt Is Nothing Then
'Stop '* get ready .....
oSubmitInputElememt.Click
Do While ie.Busy Or ie.readyState <> 4: DoEvents: Loop
End If
End Sub
Sub show_the_form(ie)
Application.Wait Now + TimeValue("00:00:03")
ie.Navigate "https://www.pinkoi.com/user/testpkko2" 'After login we can trip to other people website
Do While ie.Busy Or ie.readyState <> 4: DoEvents: Loop
With ie.document
On Error Resume Next
For Each E In .GetElementsByTagName("A")
a = E.Text
If CStr(a) = "傳送訊息" Then
E.Click '這邊會跳出寄送的表單,要如何輸入主旨以及內文和選擇檔案並按下寄送按鈕呢?
End If
Next
End With
End Sub

複製代碼

Set objShell = CreateObject("Shell.Application")
Set objAllWindows = objShell.Windows
For Each ow In objAllWindows
If (InStr(1, ow, "Internet Explorer", vbTextCompare)) Then
If (InStr(1, ow.LocationURL, "https://www.google.com.tw", vbTextCompare)) Then
執行的程式碼
end if
end if

複製代碼

Do While (ow.Busy And errorcount < 5)
errorcount = errorcount + 1
ow.document.writeln ("<script type=""text/javascript"">window.focus()</script>")
'For i = 1 To 50000
'Next
'ow.Visible = False
'ow.Visible = True
Application.SendKeys ("{Enter}")
Loop

複製代碼

Do While ie.readyState <> 4 Or ow.Busy:
DoEvents
If ie.Busy Then
ie.Visible = False ''就是從新隱藏使用視窗
ie.Visible = True ''接著又重新顯示active使用視窗
ie.document.Focus
DoEvents
Application.SendKeys "{ENTER}", True '**按下鍵
End If
Loop

複製代碼

ie.Visible = False ''就是從新隱藏使用視窗
ie.Visible = True ''接著又重新顯示active使用視窗
ie.document.Focus

複製代碼