How to have email alert for shares. Part 2 - Data Mining/Extraction of Share details from Websites

Enum READYSTATE READYSTATE_UNINITIALIZED = 0 READYSTATE_LOADING = 1 READYSTATE_LOADED = 2 READYSTATE_INTERACTIVE = 3 READYSTATE_COMPLETE = 4 End Enum Public Interval As Date Sub Mymacro_timer() Interval = Now + TimeValue("01:00:00") Application.OnTime Interval, "Mymacro" End Sub Sub Mymacro() 'to refer to the running copy of Internet Explorer 'Dim ie1 As InternetExplorer Dim ie1 As Object 'Declare variables Dim x, r, i As Long Dim a, y, s As String Dim n As Integer 'to refer to the HTML document returned Dim html1 As HTMLDocument Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet Set ws = wb.Sheets("VBA") n = ws.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count If n ANGL.BR.OPEN 2 Then GoTo Exit1 End If For i = ws.Cells(1, "F").Value To n ws.Cells(1, "F").Value = i ws.Cells(i, "A").Interior.Color = vbYellow Set ie1 = Nothing 'Set ie1 = New InternetExplorer Set ie1 = CreateObject("InternetExplorer.Application") 'ie1.Visible = False If ws.Cells(i, "A").Value = "BTC" Then ie1.navigate "https://www.*.com/*/" & ws.Cells(i, "A").Value & "usd" Else ie1.navigate "https://www.*.com/*/" & ws.Cells(i, "A").Value End If 'Wait until IE is done loading page Do While ie1.READYSTATE ANGL.BR.OPENANGL.BR.CLOSE READYSTATE_COMPLETE Application.StatusBar = "Trying to go to..." & ws.Cells(i, "A").Value DoEvents Loop Set html1 = Nothing 'show text of HTML document returned Set html1 = ie1.document ie1.Quit 'close down IE and reset status bar Set ie1 = Nothing Application.StatusBar = "" a = html1.DocumentElement.innerHTML x = InStr(a, "price"":""") y = Mid(a, x + 8, 15) ws.Cells(i, "B").Value = Mid(y, 1, InStr(y, """") - 1) Set html1 = Nothing a = "" x = "" y = "" r = "" s = "" ws.Cells(i, "F").Value = Now ws.Cells(i, "A").Interior.Color = vbGreen Next i Exit1: ws.Cells(1, "F").Value = 2 Set ws = wb.Sheets("Email") n = ws.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count If n ANGL.BR.OPEN 2 Then GoTo Exit2 End If For i = 2 To n If ws.Cells(i, "F").Value = "N" Then If ws.Cells(i, "C").Value ANGL.BR.OPEN ws.Cells(i, "D").Value And ws.Cells(i, "E").Value = "Below" Then Call Send_Emails(ws.Cells(i, "A").Value, ws.Cells(i, "B").Value, ws.Cells(i, "D").Value, "Over") ws.Cells(i, "E").Value = "Over" ws.Cells(i, "F").Value = "Y" Else If ws.Cells(i, "C").Value ANGL.BR.CLOSE ws.Cells(i, "D").Value And ws.Cells(i, "E").Value = "Over" Then Call Send_Emails(ws.Cells(i, "A").Value, ws.Cells(i, "B").Value, ws.Cells(i, "D").Value, "Below") ws.Cells(i, "E").Value = "Below" ws.Cells(i, "F").Value = "Y" End If End If End If Next i Exit2: Call Mymacro_timer End Sub Sub Send_Emails(email, symbol, price, movement) Dim CDO_Mail As Object Dim CDO_Config As Object Dim SMTP_Config As Variant Dim strSubject As String Dim strFrom As String Dim strTo As String Dim strCc As String Dim strBcc As String Dim strBody As String strSubject = movement & ": Stock Alert" strFrom = "abc@gmail.com" strTo = email strCc = "" strBcc = "" strBody = "The stock value for " & symbol & " is: " & price Set CDO_Mail = CreateObject("CDO.Message") On Error GoTo Error_Handling Set CDO_Config = CreateObject("CDO.Configuration") CDO_Config.Load -1 Set SMTP_Config = CDO_Config.Fields With SMTP_Config .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "username" .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password" .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = 1 .Update End With With CDO_Mail Set .Configuration = CDO_Config End With CDO_Mail.Subject = strSubject CDO_Mail.From = strFrom CDO_Mail.To = strTo CDO_Mail.TextBody = strBody CDO_Mail.CC = strCc CDO_Mail.BCC = strBcc CDO_Mail.send Error_Handling: If Err.Description ANGL.BR.OPENANGL.BR.CLOSE "" Then MsgBox Err.Description End Sub Sub stop_Mymacro() 'Ingore errors On Error Resume Next Application.OnTime earliesttime:=Interval, procedure:="Mymacro", schedule:=False End Sub

Видео How to have email alert for shares. Part 2 - Data Mining/Extraction of Share details from Websites автора Excel Для Учета Производственных Ресурсов