Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,589
- Office Version
- 2016
- Platform
- Windows
Workbook example.
I have just written this code and would like to share it with you here.
The code adds a screen crosshair that extends to the full excel screen. One scenario it could be useful for is to determine the X and Y coordinates in maps.
Upon opening the workbook,the code adds a temporary floating toolbar on the fly. You just click on the toolbar CrossHair icon and you get the CrossHair.
FYI,the bytes of the CrossHair Icon on the floating Toolbar are stored in the hidden worksheet ( CrossHairIconBytes )
Main Code in a Standard Module :
Code in the Configuration userform ( CrossHairConfigfrm )
Code in the Workbook module :
This workbook could be best made into an addIn.
I have just written this code and would like to share it with you here.
The code adds a screen crosshair that extends to the full excel screen. One scenario it could be useful for is to determine the X and Y coordinates in maps.
Upon opening the workbook,the code adds a temporary floating toolbar on the fly. You just click on the toolbar CrossHair icon and you get the CrossHair.
FYI,the bytes of the CrossHair Icon on the floating Toolbar are stored in the hidden worksheet ( CrossHairIconBytes )
Main Code in a Standard Module :
Code:
'\Jaafar Tribak 14/10/2010.
'\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 Const CROSSHAIRBMP_PATH_NAME = "C:\CrossHair.bmp"
Private oVisibleRange As Range
Private oCrossButton As CommandBarButton
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 GetQueueStatus(QS_MOUSEMOVE) Then
With oCrossButton
.Caption = "X: " & tPt.x & " " & "Y: " & tPt.y
.Visible = False
.Visible = True
End With
End If
If bStop Then Exit Do
DoEvents
Loop
oCrossButton.Caption = Space(25)
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 AddCrossHairControl()
Dim oToolBar As CommandBar
Set oToolBar = Application.CommandBars.Add _
("CrossHair", msoBarFloating, , True)
Set oCrossButton = oToolBar.Controls.Add _
(msoControlButton)
With oCrossButton
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = Space(25)
.TooltipText = "Display CrossHair"
.Picture = LoadPicture(CROSSHAIRBMP_PATH_NAME)
.OnAction = "ShowConfigForm"
End With
oToolBar.Visible = True
End Sub
Public Sub CreateCrossHairBMP()
Dim Bytes() As Byte
Dim lFileNum As Integer
Dim avar
Dim x As Long
avar = ThisWorkbook.Worksheets("CrossHairIconBytes").UsedRange.Value
'
ReDim Bytes(LBound(avar) To UBound(avar))
For x = LBound(avar) To UBound(avar)
Bytes(x) = CByte(avar(x, 1))
Next
lFileNum = FreeFile
Open CROSSHAIRBMP_PATH_NAME For Binary As #lFileNum
Put #lFileNum, 1, Bytes
Close lFileNum
End Sub
Public Sub CleanUp()
Kill CROSSHAIRBMP_PATH_NAME
End Sub
Private Sub ShowConfigForm()
If IsWindow(lRightLine) Then
bStop = True
Else
CrossHairConfigfrm.Show vbModeless
End If
End SubCode in the Configuration userform ( CrossHairConfigfrm )
Code:
Option Explicit
Private Sub UserForm_Initialize()
Me.txtLW = 1
Me.txtLC.BackColor = vbBlue
Me.btnOK.SetFocus
End Sub
Private Sub btnLC_Click()
Dim lLC As Long
lLC = ShowColor
If lLC <> -1 Then
Me.txtLC.BackColor = lLC
End If
End Sub
Private Sub btnOK_Click()
Unload Me
ShowCrossHair txtLC.BackColor, txtLW, Not CbxHC
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub SpnLW_SpinDown()
If Me.txtLW = 1 Then Exit Sub
Me.txtLW.Value = Me.txtLW.Value - 1
End Sub
Private Sub SpnLW_SpinUp()
If Me.txtLW = 10 Then Exit Sub
Me.txtLW.Value = Me.txtLW.Value + 1
End Sub
Private Sub txtLW_Change()
If Len(txtLW) = 0 Then Exit Sub
If txtLW.Value < 1 Or Not IsNumeric(txtLW) Then txtLW.Value = 1
If txtLW.Value > 10 Then txtLW.Value = 10
End SubCode in the Workbook module :
Code:
Option Explicit
Private Sub Workbook_Open()
Call CreateCrossHairBMP
Call AddCrossHairControl
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call CleanUp
End SubThis workbook could be best made into an addIn.
