Code to generate a CrossHair over the entire excel screen.

[Jaafar Tribak]

Here is an improved version of a Cross-Hair I coded sometime ago. The user can choose the line color, width ...etc.

workbook demo.

The main code

'\Code to create a CrossHair in Excel.

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Private Type ChooseColor
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type


Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, _
ByVal lpClassName As String, _
ByVal lpWindowName As String, _
ByVal dwStyle As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hWndParent As Long, _
ByVal hMenu As Long, _
ByVal hInstance As Long, _
lpParam As Any) As Long

Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long

Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long

Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function IsWindow Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc1 As Long) As Long

Private Declare Function FillRect Lib "user32" _
(ByVal hdc1 As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long

Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Function WindowFromPoint Lib "user32.dll" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long

Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) _
As Long

Private Declare Function GetDesktopWindow _
Lib "user32" () As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, _
lpdwProcessId As Long) _
As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" () _
As Long

Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long


Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long

Private Declare Function SetCursor Lib "user32.dll" _
(ByVal hCursor As Long) As Long

Private Declare Function ChooseColor Lib "comdlg32.dll" _
Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function GetQueueStatus Lib "user32" _
(ByVal fuFlags As Long) As Long


Private Const WS_CHILD = &H40000000
Private Const WS_EX_TOOLWINDOW = &H80
Private Const QS_MOUSEMOVE = &H2
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private oVisibleRange As Range
Private CustomColors() As Byte
Private bStop As Boolean
Private lRightLine As Long


Public Sub ShowCrossHair( _
LineColor As Long, LineWidth As Long, ShowXLCursor As Boolean)

    Dim bFlag As Boolean
    Dim lCur As Long
    Dim lLeftLine As Long
    Dim lTopLine As Long
    Dim lBottomLine As Long
    Dim hdc1 As Long
    Dim hdc2 As Long
    Dim hdc3 As Long
    Dim hdc4 As Long
    Dim hBrush As Long
    Dim tRect1 As RECT
    Dim tRect2 As RECT
    Dim tRect3 As RECT
    Dim tRect4 As RECT
    Dim tPt As POINTAPI
    Dim LB As LOGBRUSH
    
    
    LB.lbColor = LineColor
    
    hBrush = CreateBrushIndirect(LB)
    
    lRightLine = CreateWindowEx(WS_EX_TOOLWINDOW, "STATIC", _
    vbNullString, WS_CHILD, 0, 0, 0, 0, GetDesktopWindow, 0, 0, 0)
    
    lLeftLine = CreateWindowEx(WS_EX_TOOLWINDOW, "STATIC", _
    vbNullString, WS_CHILD, 0, 0, 0, 0, GetDesktopWindow, 0, 0, 0)
    
    lTopLine = CreateWindowEx(WS_EX_TOOLWINDOW, "STATIC", _
    vbNullString, WS_CHILD, 0, 0, 0, 0, GetDesktopWindow, 0, 0, 0)
    
    lBottomLine = CreateWindowEx(WS_EX_TOOLWINDOW, "STATIC", _
    vbNullString, WS_CHILD, 0, 0, 0, 0, GetDesktopWindow, 0, 0, 0)
    
    hdc1 = GetDC(lRightLine)
    hdc2 = GetDC(lLeftLine)
    hdc3 = GetDC(lTopLine)
    hdc4 = GetDC(lBottomLine)
    
    
    bStop = False
    
    
    If Not ShowXLCursor Then
        lCur = SetCursor(0)
        Call ShowCursor(False)
    End If
    
    Do
    
        On Error Resume Next
        
        If oVisibleRange.Address <> _
        ActiveWindow.VisibleRange.Address Then
            On Error GoTo 0
            InvalidateRect 0, 0, 0
        End If
        
        GetCursorPos tPt
        
        If GetWindowThreadProcessId _
        (WindowFromPoint(tPt.x, tPt.y), ByVal 0&) _
        = GetCurrentThreadId Then
        
            bFlag = False
            
            MoveWindow lRightLine, tPt.x, tPt.y, _
            GetSystemMetrics(SM_CXSCREEN), LineWidth, 1
            
            MoveWindow lLeftLine, 0, tPt.y, tPt.x, LineWidth, 1
            
            MoveWindow lTopLine, tPt.x, 0, LineWidth, tPt.y, 1
            
            MoveWindow lBottomLine, tPt.x, tPt.y, LineWidth, _
            GetSystemMetrics(SM_CYSCREEN), 1
            
            GetClientRect lRightLine, tRect1
            GetClientRect lLeftLine, tRect2
            GetClientRect lTopLine, tRect3
            GetClientRect lBottomLine, tRect4
            
            
            With tRect1
                FillRect hdc1, tRect1, hBrush
                FillRect hdc2, tRect2, hBrush
                FillRect hdc3, tRect3, hBrush
                FillRect hdc4, tRect4, hBrush
            End With
            
            ShowWindow lRightLine, 1
            ShowWindow lLeftLine, 1
            ShowWindow lTopLine, 1
            ShowWindow lBottomLine, 1
        
        Else
        
            If Not bFlag Then
                bFlag = True
                ShowWindow lRightLine, 0
                ShowWindow lLeftLine, 0
                ShowWindow lTopLine, 0
                ShowWindow lBottomLine, 0
            End If
            
        End If
        
        Set oVisibleRange = ActiveWindow.VisibleRange
        
        If bStop Then Exit Do
        
        DoEvents
    
    Loop
    
    If Not ShowXLCursor Then
        SetCursor lCur
        ShowCursor True
    End If
    
    
    ReleaseDC lRightLine, hdc1
    ReleaseDC lLeftLine, hdc2
    ReleaseDC lLeftLine, hdc3
    ReleaseDC lLeftLine, hdc4
    
    DestroyWindow lRightLine
    DestroyWindow lLeftLine
    DestroyWindow lTopLine
    DestroyWindow lBottomLine

End Sub


Public Function ShowColor() As Long
 
    Dim tChooseColor As ChooseColor
    Dim i As Integer
    Dim Custcolor(16) As Long
    Dim lReturn As Long
    
    ReDim CustomColors(0 To 16 * 4 - 1) As Byte
    
    For i = LBound(CustomColors) To UBound(CustomColors)
        CustomColors(i) = 0
    Next i
    
    tChooseColor.lStructSize = Len(tChooseColor)
    tChooseColor.hwndOwner = FindWindow(vbNullString, _
    CrossHairConfigfrm.Caption)
    tChooseColor.hInstance = 0
    tChooseColor.lpCustColors = StrConv(CustomColors, _
    vbUnicode)
    tChooseColor.flags = 0
    
    If ChooseColor(tChooseColor) <> 0 Then
        ShowColor = tChooseColor.rgbResult
        CustomColors = StrConv(tChooseColor.lpCustColors, _
        vbFromUnicode)
    Else
        ShowColor = -1
    End If
 
End Function

Public Sub ShowConfigForm()

    If IsWindow(lRightLine) Then
        bStop = True
        Sheet1.Shapes("Check Box 1").ControlFormat.Value = 0
    Else
        CrossHairConfigfrm.Show vbModeless
    End If

End Sub

 

[craig.penny]

This is really neat!

Thanks Jaafar

 

[Dryver14]

Public Sub ShowConfigForm()

    If IsWindow(lRightLine) Then
        bStop = True
        Sheet1.Shapes("Check Box 1").ControlFormat.Value = 0
    Else
        [B]CrossHairConfigfrm.Show vbModeless
[/B]    End If

End Sub

the bold line is generating an error for me

 

[Jaafar Tribak]

Thanks guys for the interest.

Dryver14,
You get that error because you have used only the code I posted which is not the entire code. The Project contains a userform called CrossHairConfigfrm to give the user an easy interface for applying the settings of the crosshair.

Download the provided workbook to see the full code and to see how the crosshair actually works.