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 = "[email protected]"
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