Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing HyperLinkCtl.ctl (37.31 KB)
VERSION 5.00
Begin VB.UserControl HyperLinkCtl
ClientHeight = 480
ClientLeft = 0
ClientTop = 0
ClientWidth = 2310
KeyPreview = -1 'True
ScaleHeight = 480
ScaleWidth = 2310
ToolboxBitmap = "HyperLinkCtl.ctx":0000
Begin VB.Label DummyLabel
BackStyle = 0 'Transparent
Height = 315
Left = 0
TabIndex = 0
Top = 0
Visible = 0 'False
Width = 765
End
End
Attribute VB_Name = "HyperLinkCtl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Enum HLCTLAlign
aLeft = 0
aCenter = 1
aRight = 2
End Enum
Private m_Align As HLCTLAlign
Public Enum HLCTLBorderStyle
bdrNone = 0
bdrFlat = 1
bdrSunken = 2
End Enum
Private m_BorderStyle As HLCTLBorderStyle
Public Enum HLCTLClickStyle
clkDefault = 0
clkBoth = 1
End Enum
Private m_ClickStyle As HLCTLClickStyle
Public Enum HLCTLCursorType
curDefault = 0
curHand = 1
End Enum
Private m_CursorType As HLCTLCursorType
Private m_Caption As String
Private m_BackColor As Long
Private m_ClickColor As Long
Private m_oClickColor As OLE_COLOR
Public Enum HLCTLEnabledType
eblDefault = 0
eblOther = 1
End Enum
Private m_EnabledType As HLCTLEnabledType
Private m_ForeColor As Long
Private m_HoverColor As Long
Private m_oHoverColor As OLE_COLOR
Private m_HasHoverEffect As Boolean
Private m_bIsHovering As Boolean
Private m_ShowFocus As Boolean
Private m_SingleLine As Boolean
Private m_WordBreak As Boolean
Public Enum HLCTLStyle
styControlDrawn = 0
styOwnerDrawn = 1
End Enum
Private m_drawStyle As HLCTLStyle
Public Enum HLCTLEllipsis
elpNone = 0
elpEnd = 1
elpWord = 2
elpPath = 3
End Enum
Private m_EllipsisStyle As HLCTLEllipsis
Public Enum HLCTLVerticalAlign
vaTop = 0
vaCenter = 1
vaBottom = 2
End Enum
Private m_VAlign As HLCTLVerticalAlign
Private m_hWnd As Long
Private m_hWndparent As Long
Private m_hBackBrush As Long
Private m_bControlHasFocus As Boolean
Private m_bIsWin98OrLater As Boolean
Implements ISubclass
Private m_bSubClass As Boolean
Private m_bFontNotCreated As Boolean
Private m_hFnt As Long
Private m_hFntOld As Long
Private m_tlF As LOGFONT
Private m_hUFnt As Long
Private m_tULF As LOGFONT
Private m_IPAOHookStruct As IPAOHookStruct
Public Event BeforeClick()
Attribute BeforeClick.VB_Description = "Raised when a user clicks on the control (mouse down)."
Public Event Click()
Attribute Click.VB_Description = "Raised when a user clicks on the control (mouse up)."
Public Event DblClick()
Attribute DblClick.VB_Description = "Raised when the control is double clicked."
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Attribute KeyDown.VB_Description = "Raised when a Key is first pressed down for an item in the control."
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "Raised when a key is released in the control."
Public Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "Raised when a Key is Pressed in the control."
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Attribute MouseDown.VB_Description = "Raised when the user clicks on the control."
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Attribute MouseMove.VB_Description = "Raised when the user moves the mouse over the control."
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Attribute MouseUp.VB_Description = "Raised when the user releases the mouse over the control."
Public Event MouseEnter()
Attribute MouseEnter.VB_Description = "Raised when the user moves the mouse on the control."
Public Event MouseLeave()
Attribute MouseLeave.VB_Description = "Raised when the user moves the mouse off of the control."
Public Event DrawControl(hDC As Long, bEnabled As Boolean, LeftPixels As Long, TopPixels As Long, RightPixels As Long, BottomPixels As Long, hFntOld As Long)
Attribute DrawControl.VB_Description = "Raised when the control needs drawing if the DrawStyle is set to styOwnerDrawn."
Public Sub Refresh()
Attribute Refresh.VB_Description = "Refreshes the control."
pRefreshControl
End Sub
Friend Function TranslateAccelerator(lpMsg As VBOleGuids.MSG) As Long
TranslateAccelerator = S_FALSE
' Here you can modify the response to the key down
' accelerator command using the values in lpMsg. This
' can be used to capture Tabs, Returns, Arrows etc.
' Just process the message as required and return S_OK.
If lpMsg.message = WM_KEYDOWN Then
Select Case lpMsg.wParam And &HFFFF&
Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd, vbKeyReturn
SendMessageByLong m_hWnd, lpMsg.message, lpMsg.wParam, lpMsg.lParam
TranslateAccelerator = S_OK
End Select
End If
End Function
Private Sub pResize(ByVal lWidth As Long, ByVal lHeight As Long)
If (m_hWnd <> 0) Then MoveWindow m_hWnd, 0, 0, lWidth, lHeight, 1
End Sub
Private Sub pSubClass(ByVal bRealControl As Boolean)
If Not (bRealControl) Then
AttachMessage Me, UserControl.hWnd, WM_SIZE
AttachMessage Me, UserControl.hWnd, WM_COMMAND
AttachMessage Me, UserControl.hWnd, WM_DRAWITEM
AttachMessage Me, UserControl.hWnd, WM_SETFOCUS
AttachMessage Me, UserControl.hWnd, WM_GETFONT
AttachMessage Me, UserControl.hWnd, WM_CTLCOLORSTATIC
Else
If (m_hWnd <> 0) Then
AttachMessage Me, m_hWnd, WM_KEYDOWN
AttachMessage Me, m_hWnd, WM_KEYUP
AttachMessage Me, m_hWnd, WM_CHAR
AttachMessage Me, m_hWnd, WM_SETFOCUS
AttachMessage Me, m_hWnd, WM_MOUSEACTIVATE
AttachMessage Me, m_hWnd, WM_LBUTTONDOWN
AttachMessage Me, m_hWnd, WM_MBUTTONDOWN
AttachMessage Me, m_hWnd, WM_RBUTTONDOWN
AttachMessage Me, m_hWnd, WM_MOUSEMOVE
AttachMessage Me, m_hWnd, WM_MOUSELEAVE
AttachMessage Me, m_hWnd, WM_LBUTTONUP
AttachMessage Me, m_hWnd, WM_MBUTTONUP
AttachMessage Me, m_hWnd, WM_RBUTTONUP
AttachMessage Me, m_hWnd, WM_LBUTTONDBLCLK
AttachMessage Me, m_hWnd, WM_MBUTTONDBLCLK
AttachMessage Me, m_hWnd, WM_RBUTTONDBLCLK
End If
m_bSubClass = True
End If
End Sub
Private Sub pTerminate()
' Clear up subclassing messages:
If (m_bSubClass) Then
DetachMessage Me, m_hWndparent, WM_SIZE
DetachMessage Me, m_hWndparent, WM_COMMAND
DetachMessage Me, m_hWndparent, WM_DRAWITEM
DetachMessage Me, m_hWndparent, WM_SETFOCUS
DetachMessage Me, m_hWndparent, WM_GETFONT
DetachMessage Me, m_hWndparent, WM_CTLCOLORSTATIC
DetachMessage Me, m_hWnd, WM_KEYDOWN
DetachMessage Me, m_hWnd, WM_KEYUP
DetachMessage Me, m_hWnd, WM_CHAR
DetachMessage Me, m_hWnd, WM_SETFOCUS
DetachMessage Me, m_hWnd, WM_MOUSEACTIVATE
DetachMessage Me, m_hWnd, WM_LBUTTONDOWN
DetachMessage Me, m_hWnd, WM_MBUTTONDOWN
DetachMessage Me, m_hWnd, WM_RBUTTONDOWN
DetachMessage Me, m_hWnd, WM_MOUSEMOVE
DetachMessage Me, m_hWnd, WM_MOUSELEAVE
DetachMessage Me, m_hWnd, WM_LBUTTONUP
DetachMessage Me, m_hWnd, WM_MBUTTONUP
DetachMessage Me, m_hWnd, WM_RBUTTONUP
DetachMessage Me, m_hWnd, WM_LBUTTONDBLCLK
DetachMessage Me, m_hWnd, WM_MBUTTONDBLCLK
DetachMessage Me, m_hWnd, WM_RBUTTONDBLCLK
End If
If (m_hFnt <> 0) Then
DeleteObject m_hFnt
m_bFontNotCreated = True
End If
pDestroyStatic
' Remove control font if we have one:
If (m_hUFnt <> 0) Then
DeleteObject m_hUFnt
End If
If (m_hBackBrush <> 0) Then
DeleteObject m_hBackBrush
End If
End Sub
Private Function plKeyEvent(ByVal lhWNd As Long, ByVal iMsg As Integer, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim iKeyCode As Integer
Dim iKeyAscii As Integer
Dim iOrigKeyAscii As Integer
Dim iShift As Integer
iKeyCode = (wParam And &HFF)
' Alt key pressed = Bit 29
If ((lParam And &H20000000) = &H20000000) Then
iShift = 1
End If
Select Case iMsg
Case WM_KEYDOWN
iShift = giGetShiftState()
RaiseEvent KeyDown(iKeyCode, iShift)
Case WM_KEYUP
iShift = giGetShiftState()
RaiseEvent KeyUp(iKeyCode, iShift)
Case WM_CHAR
iKeyAscii = (wParam And &HFF)
iOrigKeyAscii = iKeyAscii
RaiseEvent KeyPress(iKeyAscii)
If (iKeyAscii = 0) Then
plKeyEvent = 1
ElseIf (iKeyAscii <> iOrigKeyAscii) Then
SendMessageByLong lhWNd, WM_CHAR, iKeyAscii, 0
plKeyEvent = 1
End If
End Select
End Function
Private Function plDrawControl(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tDis As DRAWITEMSTRUCT
Dim bEnabled As Boolean
Dim tLF As LOGFONT
CopyMemory tDis, ByVal lParam, Len(tDis)
bEnabled = Not ((tDis.ItemState And ODS_DISABLED) = ODS_DISABLED)
If m_EnabledType = eblOther Then bEnabled = Enabled
' Ensure we have the correct font and colors selected:
If (m_bFontNotCreated) Then
pOLEFontToLogFont UserControl.Font, UserControl.hDC, m_tlF
m_hFnt = CreateFontIndirect(m_tlF)
m_bFontNotCreated = False
End If
m_hFntOld = SelectObject(tDis.hDC, m_hFnt)
If m_drawStyle = styControlDrawn Then
' Draw by default mechanism:
pDefaultDrawControl tDis.hDC, bEnabled, _
tDis.rcItem.Left, tDis.rcItem.Top, tDis.rcItem.Right, tDis.rcItem.Bottom
ElseIf m_drawStyle = styOwnerDrawn Then
' Notify the client its time to draw:
RaiseEvent DrawControl(tDis.hDC, bEnabled, _
tDis.rcItem.Left, tDis.rcItem.Top, tDis.rcItem.Right, tDis.rcItem.Bottom, _
m_hFntOld)
End If
SelectObject tDis.hDC, m_hFntOld
plDrawControl = 1
End Function
Private Sub pDefaultDrawControl( _
hDC As Long, _
bEnabled As Boolean, _
ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long _
)
Dim DrawTextStyle As Long
Dim DrawRect As RECT
Dim DrawRect2 As RECT
Dim TextExtent As SIZEAPI
GetClientRect m_hWnd, DrawRect
If m_BorderStyle = bdrFlat Then
FillRect hDC, DrawRect, GetSysColorBrush(COLOR_WINDOWFRAME)
DrawRect.Left = 1
DrawRect.Top = 1
DrawRect.Right = DrawRect.Right - 1
DrawRect.Bottom = DrawRect.Bottom - 1
FillRect hDC, DrawRect, m_hBackBrush
GetClientRect m_hWnd, DrawRect
Else
FillRect hDC, DrawRect, m_hBackBrush
End If
If m_Caption = "" Then Exit Sub
If m_EllipsisStyle = elpNone Then
DrawTextStyle = 0
ElseIf m_EllipsisStyle = elpEnd Then
DrawTextStyle = DT_END_ELLIPSIS
ElseIf m_EllipsisStyle = elpPath Then
DrawTextStyle = DT_PATH_ELLIPSIS
ElseIf m_EllipsisStyle = elpWord Then
DrawTextStyle = DT_WORD_ELLIPSIS
End If
If m_Align = aLeft Then
DrawTextStyle = DrawTextStyle Or DT_LEFT
ElseIf m_Align = aCenter Then
DrawTextStyle = DrawTextStyle Or DT_CENTER
ElseIf m_Align = aRight Then
DrawTextStyle = DrawTextStyle Or DT_RIGHT
End If
If m_SingleLine = True Then DrawTextStyle = DrawTextStyle Or DT_SINGLELINE
If m_VAlign = vaTop Then
DrawTextStyle = DrawTextStyle Or DT_TOP
ElseIf m_VAlign = vaCenter Then
DrawTextStyle = DrawTextStyle Or DT_VCENTER
ElseIf m_VAlign = vaBottom Then
DrawTextStyle = DrawTextStyle Or DT_BOTTOM
End If
If m_WordBreak = True Then DrawTextStyle = DrawTextStyle Or DT_WORDBREAK
SetBkMode hDC, TRANSPARENT
If ((m_ClickStyle = clkDefault And (gbKeyIsPressed(KEY_MOUSE1) = True Or (gbKeyIsPressed(KEY_MOUSE2) = True And IsMouseSwapped() = True))) Or _
(m_ClickStyle = clkBoth And (gbKeyIsPressed(KEY_MOUSE1) = True Or gbKeyIsPressed(KEY_MOUSE2) = True))) And m_bIsHovering = True Then
SetTextColor hDC, m_ClickColor
ElseIf m_bIsHovering = True And m_HasHoverEffect = True Then
SetTextColor hDC, m_HoverColor
Else
SetTextColor hDC, m_ForeColor
End If
DrawRect.Left = 2
DrawRect.Top = 2
DrawRect.Right = DrawRect.Right - 2
DrawRect.Bottom = DrawRect.Bottom - 2
If bEnabled = True Then DrawText hDC, m_Caption, Len(m_Caption), DrawRect, DrawTextStyle
If m_WordBreak = True Then
DrawText hDC, m_Caption, Len(m_Caption), DrawRect, DrawTextStyle Or DT_CALCRECT
Else
GetTextExtentPoint32 hDC, m_Caption, Len(m_Caption), TextExtent
DrawRect.Right = TextExtent.cx + 4
DrawRect.Bottom = TextExtent.cy + 2
End If
If m_Align = aLeft Then
DrawRect.Left = 1
ElseIf m_Align = aCenter Then
DrawRect.Left = ((UserControl.ScaleWidth \ Screen.TwipsPerPixelX + 1) - DrawRect.Right) / 2
DrawRect.Right = DrawRect.Right + DrawRect.Left
ElseIf m_Align = aRight Then
DrawRect.Left = (UserControl.ScaleWidth \ Screen.TwipsPerPixelX - 1) - DrawRect.Right
DrawRect.Right = DrawRect.Right + DrawRect.Left
End If
If m_SingleLine = True Then
If m_VAlign = vaTop Then
DrawRect.Top = 1
ElseIf m_VAlign = vaCenter Then
DrawRect.Top = ((UserControl.ScaleHeight \ Screen.TwipsPerPixelY + 1) - DrawRect.Bottom) / 2
DrawRect.Bottom = DrawRect.Bottom + DrawRect.Top
ElseIf m_VAlign = vaBottom Then
DrawRect.Top = (UserControl.ScaleHeight \ Screen.TwipsPerPixelY - 1) - DrawRect.Bottom
DrawRect.Bottom = DrawRect.Bottom + DrawRect.Top
End If
End If
If bEnabled = False Then
DrawRect.Right = DrawRect.Right + 1
DrawRect.Bottom = DrawRect.Bottom + 1
DrawState hDC, 0, 0, m_Caption, Len(m_Caption), DrawRect.Left, DrawRect.Top, DrawRect.Right - DrawRect.Left, DrawRect.Bottom - DrawRect.Top, DST_TEXT Or DSS_DISABLED
End If
If m_bControlHasFocus = True And m_ShowFocus = True Then
GetClientRect m_hWnd, DrawRect2
If DrawRect.Right > DrawRect2.Right - 1 Then DrawRect.Right = DrawRect2.Right - 1
If DrawRect.Bottom > DrawRect2.Bottom - 1 Then DrawRect.Bottom = DrawRect2.Bottom - 1
SetTextColor hDC, m_ForeColor
DrawFocusRect hDC, DrawRect
End If
End Sub
Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Gets/sets whether the control is enabled."
Enabled = UserControl.Enabled
End Property
Property Get EllipsisStyle() As HLCTLEllipsis
Attribute EllipsisStyle.VB_Description = "Gets/sets the style for which an ellipsis is drawn."
EllipsisStyle = m_EllipsisStyle
End Property
Property Let Enabled(bEnabled As Boolean)
Dim lEnable As Long
If (UserControl.Enabled <> bEnabled) Then
UserControl.Enabled = bEnabled
lEnable = Abs(bEnabled)
EnableWindow UserControl.hWnd, lEnable
EnableWindow m_hWnd, lEnable
pRefreshControl
PropertyChanged "Enabled"
End If
End Property
Property Get Font() As StdFont
Attribute Font.VB_Description = "Gets/sets the default font for the control."
Set Font = UserControl.Font
End Property
Property Get hWnd() As Long
Attribute hWnd.VB_Description = "Gets the hWnd of the static control. If you want the hWnd of the control itself, use hWndControl."
hWnd = m_hWnd
End Property
Property Get hWndControl() As Long
Attribute hWndControl.VB_Description = "Returns the window handle of the control itself (which is the parent of the static control)."
hWndControl = UserControl.hWnd
End Property
Property Set Font(fntThis As StdFont)
Dim hUFnt As Long
Dim iMsg As Long
Set UserControl.Font = fntThis
pOLEFontToLogFont fntThis, UserControl.hDC, m_tULF
hUFnt = m_hUFnt
m_hUFnt = CreateFontIndirect(m_tULF)
If (m_hWnd <> 0) Then
SendMessageByLong m_hWnd, WM_SETFONT, m_hUFnt, 1
End If
If (hUFnt <> 0) Then
DeleteObject hUFnt
End If
DeleteObject m_hFnt
m_bFontNotCreated = True
pRefreshControl
PropertyChanged "Font"
End Property
Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Gets/sets the back color of the control."
BackColor = UserControl.BackColor
End Property
Property Get BorderStyle() As HLCTLBorderStyle
Attribute BorderStyle.VB_Description = "Gets/sets the border style of the control."
BorderStyle = m_BorderStyle
End Property
Property Get ClickStyle() As HLCTLClickStyle
Attribute ClickStyle.VB_Description = "Gets/sets the style for which the click color is displayed."
ClickStyle = m_ClickStyle
End Property
Property Get EnabledType() As HLCTLEnabledType
Attribute EnabledType.VB_Description = "Set this to eblOther for it to work with Windows XP themes."
EnabledType = m_EnabledType
End Property
Property Get Caption() As String
Attribute Caption.VB_Description = "Gets/sets the caption that is displayed on the control."
Caption = m_Caption
End Property
Property Get DrawStyle() As HLCTLStyle
Attribute DrawStyle.VB_Description = "Gets/sets the way that the control is drawn."
DrawStyle = m_drawStyle
End Property
Property Get SingleLine() As Boolean
Attribute SingleLine.VB_Description = "Gets/sets whether the caption is displayed in a single line."
SingleLine = m_SingleLine
End Property
Property Get ShowFocus() As Boolean
Attribute ShowFocus.VB_Description = "Gets/sets whether a focus rectangle is drawn around the caption."
ShowFocus = m_ShowFocus
End Property
Property Get VAlign() As HLCTLVerticalAlign
Attribute VAlign.VB_Description = "Gets/sets the vertical alignment of the caption. Styles vaCenter and vaBottom require that SingleLine be true."
VAlign = m_VAlign
End Property
Property Get Align() As HLCTLAlign
Attribute Align.VB_Description = "Gets/sets the alignment of the caption."
Align = m_Align
End Property
Property Get CursorType() As HLCTLCursorType
Attribute CursorType.VB_Description = "Gets/sets the cursor type that is displayed when the user moves the mouse over the control."
CursorType = m_CursorType
End Property
Property Get WordBreak() As Boolean
Attribute WordBreak.VB_Description = "Gets/sets whether the caption is broken into lines to display the full caption. Opposite of SingleLine."
WordBreak = m_WordBreak
End Property
Property Get HasHoverEffect() As Boolean
Attribute HasHoverEffect.VB_Description = "Gets/sets whether the HoverColor is displayed when the mouse is over the control."
HasHoverEffect = m_HasHoverEffect
End Property
Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Gets/sets the default fore color of the control."
ForeColor = UserControl.ForeColor
End Property
Property Get HoverColor() As OLE_COLOR
Attribute HoverColor.VB_Description = "Gets/sets the color that is displayed when the mouse is over the control."
HoverColor = m_oHoverColor
End Property
Property Get ClickColor() As OLE_COLOR
Attribute ClickColor.VB_Description = "Gets/sets the color that is displayed when the user clicks on the control."
ClickColor = m_oClickColor
End Property
Property Let BackColor(ByVal oBackColor As OLE_COLOR)
Dim tR As RECT
If (UserControl.BackColor <> oBackColor) Then
UserControl.BackColor = oBackColor
m_BackColor = gTranslateColor(oBackColor)
If (m_hBackBrush <> 0) Then
DeleteObject m_hBackBrush
End If
m_hBackBrush = CreateSolidBrush(gTranslateColor(oBackColor))
GetClientRect UserControl.hWnd, tR
FillRect UserControl.hDC, tR, m_hBackBrush
pRefreshControl
PropertyChanged "BackColor"
End If
End Property
Property Let Caption(ByVal sCaption As String)
If (m_Caption <> sCaption) Then
m_Caption = sCaption
SendMessageByString m_hWnd, WM_SETTEXT, 0&, sCaption
DummyLabel.Caption = sCaption
pRefreshControl
PropertyChanged "Caption"
End If
End Property
Property Let ForeColor(ByVal oForeColor As OLE_COLOR)
If (UserControl.ForeColor <> oForeColor) Then
UserControl.ForeColor = oForeColor
m_ForeColor = gTranslateColor(oForeColor)
PropertyChanged "ForeColor"
End If
End Property
Private Sub pInitialize()
Dim hInst As Long
Dim sStyle As String
Dim wStyle As Long
Dim lW As Long, lH As Long
pDestroyStatic
hInst = App.hInstance
sStyle = "STATIC"
wStyle = WS_VISIBLE Or WS_CHILD
If UserControl.Ambient.UserMode = True Then wStyle = wStyle Or SS_OWNERDRAW Or SS_NOTIFY
If m_BorderStyle = bdrSunken Then wStyle = wStyle Or SS_SUNKEN
lW = UserControl.Width \ Screen.TwipsPerPixelX
lH = UserControl.Height \ Screen.TwipsPerPixelY
m_hWnd = CreateWindowEx( _
0, _
sStyle, _
m_Caption, _
wStyle, _
0, 0, lW, lH, _
m_hWndparent, _
0, _
hInst, _
ByVal 0 _
)
If (m_hWnd <> 0) Then
Set Font = UserControl.Font
ShowWindow m_hWnd, SW_SHOW
End If
End Sub
Private Function plNotificationEvent(ByVal iMsg As Integer, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lHiWord As Long, lLoWord As Long
gGetHiWordLoWord wParam, lHiWord, lLoWord
Select Case lHiWord
Case STN_CLICKED
RaiseEvent BeforeClick
Case STN_DBLCLK
RaiseEvent DblClick
End Select
End Function
Private Sub pDestroyStatic()
If (m_hWnd <> 0) Then
ShowWindow m_hWnd, SW_HIDE
SetParent m_hWnd, 0
DestroyWindow m_hWnd
End If
End Sub
Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT)
Dim sFont As String
Dim iChar As Integer
With tLF
sFont = fntThis.Name
For iChar = 1 To Len(sFont)
.lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1)))
Next iChar
.lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
.lfItalic = fntThis.Italic
If (fntThis.Bold) Then
.lfWeight = FW_BOLD
Else
.lfWeight = FW_NORMAL
End If
.lfUnderline = fntThis.Underline
.lfStrikeOut = fntThis.Strikethrough
.lfCharSet = fntThis.Charset
End With
End Sub
Private Sub pRefreshControl()
Dim tR As RECT
' Invalidate the control so it gets redrawn:
If (m_hWnd <> 0) Then
tR.Right = UserControl.ScaleWidth \ Screen.TwipsPerPixelX
tR.Bottom = UserControl.ScaleHeight \ Screen.TwipsPerPixelY
InvalidateRect m_hWnd, tR, 1
End If
End Sub
Property Let HoverColor(ByVal oHoverColor As OLE_COLOR)
If (m_oHoverColor <> oHoverColor) Then
m_oHoverColor = oHoverColor
m_HoverColor = gTranslateColor(oHoverColor)
pRefreshControl
PropertyChanged "HoverColor"
End If
End Property
Property Let ClickColor(ByVal oClickColor As OLE_COLOR)
If (m_oClickColor <> oClickColor) Then
m_oClickColor = oClickColor
m_ClickColor = gTranslateColor(m_oClickColor)
pRefreshControl
PropertyChanged "ClickColor"
End If
End Property
Property Let SingleLine(ByVal bSingleLine As Boolean)
m_SingleLine = bSingleLine
pRefreshControl
PropertyChanged "SingleLine"
End Property
Property Let ShowFocus(ByVal bShowFocus As Boolean)
m_ShowFocus = bShowFocus
pRefreshControl
PropertyChanged "ShowFocus"
End Property
Property Let VAlign(ByVal iVAlign As HLCTLVerticalAlign)
m_VAlign = iVAlign
pRefreshControl
PropertyChanged "VAlign"
End Property
Property Let EllipsisStyle(ByVal iStyle As HLCTLEllipsis)
m_EllipsisStyle = iStyle
pRefreshControl
PropertyChanged "EllipsisStyle"
End Property
Property Let WordBreak(ByVal bWordBreak As Boolean)
m_WordBreak = bWordBreak
pRefreshControl
PropertyChanged "WordBreak"
End Property
Property Let Align(ByVal iAlign As HLCTLAlign)
SetWindowLong m_hWnd, GWL_STYLE, GetWindowLong(m_hWnd, GWL_STYLE) And Not m_Align
m_Align = iAlign
SetWindowLong m_hWnd, GWL_STYLE, GetWindowLong(m_hWnd, GWL_STYLE) Or m_Align
pRefreshControl
PropertyChanged "Align"
End Property
Property Let CursorType(ByVal iType As HLCTLCursorType)
m_CursorType = iType
PropertyChanged "CursorType"
End Property
Property Let BorderStyle(ByVal iStyle As HLCTLBorderStyle)
m_BorderStyle = iStyle
pRefreshControl
PropertyChanged "BorderStyle"
End Property
Property Let ClickStyle(ByVal iStyle As HLCTLClickStyle)
m_ClickStyle = iStyle
PropertyChanged "ClickStyle"
End Property
Property Let EnabledType(ByVal iType As HLCTLEnabledType)
m_EnabledType = iType
pRefreshControl
PropertyChanged "EnabledType"
End Property
Property Let HasHoverEffect(ByVal bTrue As Boolean)
m_HasHoverEffect = bTrue
PropertyChanged "HasHoverEffect"
End Property
Property Let DrawStyle(ByVal iDrawStyle As HLCTLStyle)
m_drawStyle = iDrawStyle
pRefreshControl
PropertyChanged "DrawStyle"
End Property
Private Property Let ISubclass_MsgResponse(ByVal RHS As SubcAsst.EMsgResponse)
'
End Property
Private Property Get ISubclass_MsgResponse() As SubcAsst.EMsgResponse
Select Case CurrentMessage
Case WM_CHAR, WM_KEYDOWN, WM_MOUSEACTIVATE
ISubclass_MsgResponse = emrConsume
Case Else
ISubclass_MsgResponse = emrPreprocess
End Select
End Property
Private Function ISubclass_WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tR As RECT
Dim lW As Long, lH As Long
Dim iKeyCode As Integer, iShift As Integer, lhWNd As Long, bShift As Boolean
Dim iButton As Integer, x As Single, y As Single
Select Case iMsg
Case WM_CTLCOLORSTATIC
If (m_hBackBrush <> 0) Then
ISubclass_WindowProc = m_hBackBrush
Else
ISubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
End If
Case WM_DRAWITEM
ISubclass_WindowProc = plDrawControl(wParam, lParam)
Case WM_COMMAND
If (plNotificationEvent(iMsg, wParam, lParam) <> 0) Then
ISubclass_WindowProc = 1
End If
Case WM_GETFONT
ISubclass_WindowProc = m_hUFnt
Case WM_SIZE
UserControl_Paint
lW = (lParam And &HFFFF&)
lH = ((lParam \ &H10000) And &HFFFF&)
pResize lW, lH
Case WM_KEYDOWN
iKeyCode = (wParam And &HFF)
If iKeyCode <> 0 Then
RaiseEvent KeyDown(iKeyCode, giGetShiftState())
End If
If (iKeyCode = 0) Then
' consume
Else
wParam = wParam And Not &HFF&
wParam = wParam Or (iKeyCode And &HFF&)
ISubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
End If
Case WM_KEYUP
iKeyCode = (wParam And &HFF)
If iKeyCode <> 0 Then
RaiseEvent KeyUp(iKeyCode, giGetShiftState())
End If
If (iKeyCode = 0) Then
' consume
Else
wParam = wParam And Not &HFF&
wParam = wParam Or (iKeyCode And &HFF&)
ISubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
End If
Case WM_CHAR
iKeyCode = (wParam And &HFF)
RaiseEvent KeyPress(iKeyCode)
If (iKeyCode = 0) Then
' consume:
Else
wParam = wParam And Not &HFF&
wParam = wParam Or (iKeyCode And &HFF&)
If (iKeyCode <> 0) Then
ISubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
End If
End If
Case WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN
iButton = (Abs(iMsg = WM_LBUTTONDOWN)) * vbLeftButton + (Abs(iMsg = WM_RBUTTONDOWN)) * vbRightButton + (Abs(iMsg = WM_MBUTTONDOWN)) * vbMiddleButton
iShift = wParam
If (lParam And &H8000&) = &H8000& Then
x = -(&H8000& - (lParam And &H7FFF&))
Else
x = (lParam And &HFFFF&)
End If
If (lParam And &H80000000) = &H80000000 Then
y = -(&H8000& - (lParam And &H7FFF0000) \ &H10000)
Else
y = (lParam \ &H10000)
End If
If m_CursorType = curHand And m_bIsWin98OrLater = True Then SetCursorIcon IDC_HAND, True
pRefreshControl
RaiseEvent MouseDown(iButton, iShift, x, y)
Case WM_MOUSEMOVE
iButton = Abs(GetAsyncKeyState(vbKeyLButton) <> 0) * vbLeftButton + Abs(GetAsyncKeyState(vbKeyRButton) <> 0) * vbRightButton + Abs(GetAsyncKeyState(vbKeyMButton) <> 0) * vbMiddleButton
iShift = wParam
If (lParam And &H8000&) = &H8000& Then
x = -(&H8000& - (lParam And &H7FFF&))
Else
x = (lParam And &HFFFF&)
End If
If (lParam And &H80000000) = &H80000000 Then
y = -(&H8000& - (lParam And &H7FFF0000) \ &H10000)
Else
y = (lParam \ &H10000)
End If
If m_CursorType = curHand And m_bIsWin98OrLater = True Then SetCursorIcon IDC_HAND, True
If m_bIsHovering = False Then
BeginTrackMouseEvent m_hWnd
m_bIsHovering = True
pRefreshControl
RaiseEvent MouseEnter
End If
RaiseEvent MouseMove(iButton, iShift, x, y)
Case WM_MOUSELEAVE
m_bIsHovering = False
If m_CursorType = curHand And m_bIsWin98OrLater = True Then SetCursorIcon IDC_ARROW, True
pRefreshControl
RaiseEvent MouseLeave
Case WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
iButton = (Abs(iMsg = WM_LBUTTONUP)) * vbLeftButton + (Abs(iMsg = WM_RBUTTONUP)) * vbRightButton + (Abs(iMsg = WM_MBUTTONUP)) * vbMiddleButton
iShift = wParam
If (lParam And &H8000&) = &H8000& Then
x = -(&H8000& - (lParam And &H7FFF&))
Else
x = (lParam And &HFFFF&)
End If
If (lParam And &H80000000) = &H80000000 Then
y = -(&H8000& - (lParam And &H7FFF0000) \ &H10000)
Else
y = (lParam \ &H10000)
End If
If m_CursorType = curHand And m_bIsWin98OrLater = True Then SetCursorIcon IDC_HAND, True
pRefreshControl
If iButton = vbLeftButton Or (iButton = vbRightButton And IsMouseSwapped() = True) Then RaiseEvent Click
RaiseEvent MouseUp(iButton, iShift, x, y)
Case WM_LBUTTONDBLCLK, WM_MBUTTONDBLCLK, WM_RBUTTONDBLCLK
If m_CursorType = curHand And m_bIsWin98OrLater = True Then SetCursorIcon IDC_HAND, True
ISubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
Case WM_SETFOCUS
If (m_hWnd = hWnd) Then
Dim pOleObject As IOleObject
Dim pOleInPlaceSite As IOleInPlaceSite
Dim pOleInPlaceFrame As IOleInPlaceFrame
Dim pOleInPlaceUIWindow As IOleInPlaceUIWindow
Dim pOleInPlaceActiveObject As IOleInPlaceActiveObject
Dim PosRect As RECT
Dim ClipRect As RECT
Dim FrameInfo As OLEINPLACEFRAMEINFO
Dim grfModifiers As Long
Dim AcceleratorMsg As MSG
'Get in-place frame and make sure it is set to our in-between
'implementation of IOleInPlaceActiveObject in order to catch
'TranslateAccelerator calls
Set pOleObject = Me
Set pOleInPlaceSite = pOleObject.GetClientSite
pOleInPlaceSite.GetWindowContext pOleInPlaceFrame, pOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
CopyMemory pOleInPlaceActiveObject, m_IPAOHookStruct.ThisPointer, 4
pOleInPlaceFrame.SetActiveObject pOleInPlaceActiveObject, vbNullString
If Not pOleInPlaceUIWindow Is Nothing Then
pOleInPlaceUIWindow.SetActiveObject pOleInPlaceActiveObject, vbNullString
End If
CopyMemory pOleInPlaceActiveObject, 0&, 4
Else
' The user control:
SetFocusAPI m_hWnd
End If
Case WM_MOUSEACTIVATE
If GetFocus() <> m_hWnd Then
SetFocusAPI UserControl.hWnd
ISubclass_WindowProc = MA_NOACTIVATE
Exit Function
Else
ISubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
End If
End Select
End Function
Private Sub UserControl_GotFocus()
m_bControlHasFocus = True
pRefreshControl
End Sub
Private Sub UserControl_Initialize()
Dim IPAO As IOleInPlaceActiveObject
With m_IPAOHookStruct
Set IPAO = Me
CopyMemory .IPAOReal, IPAO, 4
CopyMemory .TBEx, Me, 4
.lpVTable = IPAOVTable
.ThisPointer = VarPtr(m_IPAOHookStruct)
End With
End Sub
Private Sub UserControl_InitProperties()
pAmbient
m_Align = aLeft
BackColor = &H8000000F
m_BorderStyle = bdrNone
Caption = ""
ClickColor = &H80000012
m_ClickStyle = clkDefault
m_CursorType = curDefault
m_drawStyle = styControlDrawn
m_EllipsisStyle = elpNone
Enabled = True
m_EnabledType = eblDefault
ForeColor = &H80000012
HasHoverEffect = False
HoverColor = &H8000000D
m_ShowFocus = True
m_SingleLine = False
m_VAlign = vaTop
m_WordBreak = False
pInitialize
End Sub
Private Sub UserControl_LostFocus()
m_bControlHasFocus = False
pRefreshControl
End Sub
Private Sub UserControl_Paint()
Dim hBr As Long
Dim tR As RECT
hBr = CreateSolidBrush(gTranslateColor(UserControl.BackColor))
GetClientRect UserControl.hWnd, tR
FillRect UserControl.hDC, tR, hBr
DeleteObject hBr
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_bFontNotCreated = True
Dim sFnt As New StdFont
sFnt.Name = "MS Sans Serif"
sFnt.Size = 8
Set Font = PropBag.ReadProperty("Font", sFnt)
' If we are in runmode, then start subclassing the user control:
m_hWndparent = UserControl.hWnd
If (UserControl.Ambient.UserMode) Then
pSubClass False
End If
m_BorderStyle = PropBag.ReadProperty("BorderStyle", bdrNone)
pInitialize
m_bIsWin98OrLater = IsWin98OrLater()
m_Align = PropBag.ReadProperty("Align", aLeft)
BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
Caption = PropBag.ReadProperty("Caption", "")
ClickColor = PropBag.ReadProperty("ClickColor", &H80000012)
m_ClickStyle = PropBag.ReadProperty("ClickStyle", clkDefault)
m_CursorType = PropBag.ReadProperty("CursorType", curDefault)
m_drawStyle = PropBag.ReadProperty("DrawStyle", styControlDrawn)
m_EllipsisStyle = PropBag.ReadProperty("EllipsisStyle", elpNone)
Enabled = PropBag.ReadProperty("Enabled", True)
m_EnabledType = PropBag.ReadProperty("EnabledType", eblDefault)
ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
HasHoverEffect = PropBag.ReadProperty("HasHoverEffect", False)
HoverColor = PropBag.ReadProperty("HoverColor", &H8000000D)
m_ShowFocus = PropBag.ReadProperty("ShowFocus", True)
m_SingleLine = PropBag.ReadProperty("SingleLine", False)
m_VAlign = PropBag.ReadProperty("VAlign", vaTop)
m_WordBreak = PropBag.ReadProperty("WordBreak", False)
' If we are in run time, then start subclassing:
If (UserControl.Ambient.UserMode) Then
pSubClass True
End If
End Sub
Private Sub pAmbient()
' set relevant ambient properties:
Set Font = UserControl.Ambient.Font
End Sub
Private Sub UserControl_Resize()
Dim lWidth As Long, lHeight As Long
lWidth = UserControl.ScaleWidth \ Screen.TwipsPerPixelX
lHeight = UserControl.ScaleHeight \ Screen.TwipsPerPixelY
pResize lWidth, lHeight
End Sub
Private Sub UserControl_Terminate()
With m_IPAOHookStruct
CopyMemory .IPAOReal, 0&, 4
CopyMemory .TBEx, 0&, 4
End With
pTerminate
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
.WriteProperty "Align", m_Align, aLeft
.WriteProperty "BackColor", BackColor, &H8000000F
.WriteProperty "BorderStyle", m_BorderStyle, bdrNone
.WriteProperty "Caption", Caption, ""
.WriteProperty "ClickColor", ClickColor, &H80000012
.WriteProperty "ClickStyle", m_ClickStyle, clkDefault
.WriteProperty "CursorType", m_CursorType, curDefault
.WriteProperty "DrawStyle", m_drawStyle, styControlDrawn
.WriteProperty "EllipsisStyle", m_EllipsisStyle, elpNone
.WriteProperty "Enabled", Enabled, True
.WriteProperty "EnabledType", m_EnabledType, eblDefault
Dim sFnt As New StdFont
sFnt.Name = "MS Sans Serif"
sFnt.Size = 8
.WriteProperty "Font", Font, sFnt
.WriteProperty "ForeColor", ForeColor, &H80000012
.WriteProperty "HasHoverEffect", m_HasHoverEffect, False
.WriteProperty "HoverColor", HoverColor, &H8000000D
.WriteProperty "ShowFocus", m_ShowFocus, True
.WriteProperty "SingleLine", m_SingleLine, False
.WriteProperty "VAlign", m_VAlign, vaTop
.WriteProperty "WordBreak", m_WordBreak, False
End With
End Sub