How to trap a LEFT click mouse event in Excel VBA?

Ace_McCloud

New Member
Joined
Apr 4, 2017
Messages
2
Usage: I want to add a list of Companies to an Excel spreadsheet. The Companies are obtained from Screener.in. I want to trap LEFT Click (so that when I LEFT Click on a Company, it will be added to my Excel Spreadsheet)

Note: I've already posted the same question on stackoverflow. Here's the link:

https://stackoverflow.com/questions/...24324_47968379

Code:
Option Explicit
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
' Declare virtual key event listener
 Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" _
            (ByVal vKey As Long) As Integer
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
 Private Declare Function GetAsyncKeyState Lib "user32" _
            (ByVal vKey As Long) As Integer
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
' Left mouse button
 Private Const VK_LBUTTON = &H1
' Right mouse button
 Private Const VK_RBUTTON = &H2

 Private Const VK_F9 = &H78

 Enum BrowserNavConstants
        navOpenInNewWindow = 1
        navNoHistory = 2
        navNoReadFromCache = 4
        navNoWriteToCache = 8
        navAllowAutosearch = 16
        navBrowserBar = 32
        navHyperlink = 64
        navEnforceRestricted = 128
        navNewWindowsManaged = 256
        navUntrustedForDownload = 512
        navTrustedForActiveX = 1024
        navOpenInNewTab = 2048
        navOpenInBackgroundTab = 4096
        navKeepWordWheelText = 8192
        navVirtualTab = 16384
        navBlockRedirectsXDomain = 32768
        navOpenNewForegroundTab = 65536
 End Enum

 Function OpenNewTab(ByVal CTA As Variant, IE As Variant)

    Dim SubStrings() As String
    Dim Substitute As String
    Dim Url As String

    Substitute = "https://www.screener.in"

'    Debug.Print CTA

    SubStrings = Split(CTA, """")

'    /^<a href="([^"]++)".*?<\/a>/gm
'    [url]https://www.screener.in\1[/url]

'    Debug.Print Substitute & SubStrings(1)

    Url = Substitute & SubStrings(1)

    IE.Visible = True
    IE.Navigate Url, BrowserNavConstants.navOpenInNewTab

 End Function


 Sub SearchAndGetCompanyList()
    Dim SW As SHDocVw.ShellWindows
    Dim IE As SHDocVw.InternetExplorer
    Dim Sh As Worksheet
    Dim Url As String
    Dim SUrl, DUrl, RUrl As MSHTML.HTMLDocument
    Dim Login, RunThisQuery As MSHTML.HTMLButtonElement
    Dim Table As MSHTML.HTMLTable
    Dim TableRowCollection As MSHTML.IHTMLElementCollection
    Dim TableRow As MSHTML.HTMLTableRow
    Dim TableAnchor As MSHTML.HTMLAnchorElement
'    Dim CompanyToAdd As MSHTML.HTMLDocument
    Dim CompanyToAdd As MSHTML.HTMLTableCell
    Dim a, b, c As Long

    Url = "https://www.screener.in/login/"

    Set Sh = ActiveWorkbook.ActiveSheet

'           Debug.Print Sh.Type

    Set SW = New SHDocVw.ShellWindows
    Set IE = New SHDocVw.InternetExplorerMedium

    IE.Visible = True
    IE.Navigate Url

'    Wait till the Internet Explorer has finished loading
                Do While IE.ReadyState <> READYSTATE_COMPLETE
                Loop

'    Stores a reference to the HTML Document in that variable
                Set SUrl = IE.Document

'    Wait for document to load
                If SUrl.ReadyState = "complete" Then

                    SUrl.getElementsByTagName("input")(1).Value = "ivk2k17@gmail.com"

                    SUrl.getElementsByTagName("input")(2).Value = "screener12345"

                    Set Login = SUrl.getElementsByClassName("btn btn-primary").Item(0)

                        Login.Click

                    Application.Wait (Now + TimeValue("00:00:05"))

                    Set DUrl = IE.Document

                    DUrl.getElementsByClassName("form-control")(1).Value = "Price to earning < 15 AND Return on capital employed > 20%"

                    Application.Wait (Now + TimeValue("00:00:05"))

                    Set RunThisQuery = DUrl.getElementsByClassName("btn btn-primary").Item(2)

                        RunThisQuery.Click

                    Application.Wait (Now + TimeValue("00:00:05"))

                    Set RUrl = IE.Document

'                    Debug.Print RUrl.Location

                    Set TableRowCollection = RUrl.getElementsByTagName("table").Item(0).getElementsByTagName("tr")

'                        Debug.Print TableRowCollection.Length

                        For a = 1 To TableRowCollection.Length - 1

                    Set CompanyToAdd = RUrl.getElementsByTagName("table").Item(0).getElementsByTagName("tr").Item(a).getElementsByTagName("td").Item(1)

                        Next


                        If CompanyToAdd.hasAttributes Then

[B]Question:  I've tried using [B]addEventListener, but couldnt make it work!

'                            CompanyToAdd.addEventListener("onmouseenter", myFunction(), False)

'                                   Function myFunction()

'                                      If GetAsyncKeyState(VK_LBUTTON) Then

'                                        if LEFT mouse button is pressed
                                         Call OpenNewTab(CompanyToAdd.innerHTML, IE)


'                                      ElseIf GetAsyncKeyState(VK_RBUTTON) Then

'                                        if RIGHT mouse button is pressed
'                                        Call AddCompanyName(CompanyToAdd.innerHTML, IE)

'                                      End If

'                                   End Function

                       End If

                End If

 End Sub[/B][/B]
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Forum statistics

Threads
1,223,227
Messages
6,170,849
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top