vbAccelerator - Contents of code file: cTextBoxBackground.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cTextBoxBackground"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Type RECT
left As Long
tOp As Long
Right As Long
Bottom As Long
End Type
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal
nBkMode As Long) As Long
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As
Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC
As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT) As Long
Private Declare Function GetUpdateRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT, ByVal bErase As Long) As Long
Private Const WM_DESTROY = &H2
Private Const WM_PAINT = &HF
Private Const WM_COMMAND = &H111
Private Const WM_CTLCOLOREDIT = &H133
Private Const WM_PRINT = &H317
Private Const WM_PRINTCLIENT = &H318
Private Const WM_ERASEBKGND = &H14
Private Const EN_CHANGE = &H300
Private Const EN_HSCROLL = &H601
Private Const EN_VSCROLL = &H602
Private Const PRF_CHECKVISIBLE = &H1&
Private Const PRF_NONCLIENT = &H2&
Private Const PRF_CLIENT = &H4&
Private Const PRF_ERASEBKGND = &H8&
Private Const PRF_CHILDREN = &H10&
Private Const PRF_OWNED = &H20&
Implements ISubclass
Private m_hWnd As Long
Private m_hWndParent As Long
Private m_bCE As Boolean
Private m_bMouseDown As Boolean
Private m_iScroll As Long
Private m_tR As RECT
Private m_bFixBackground As Boolean
Private m_xTileOffset As Long
Private m_yTileOffset As Long
Private m_cWorkDC As New cMemDC
Private m_cBackDC As New cMemDC
Public Sub SetBackdrop(pic As IPicture)
Dim cTempDC As New cMemDC
' Create DC and put bmp into it:
cTempDC.InjectBitmap pic.Handle
' Set up BackDC:
m_cBackDC.Width = cTempDC.Width
m_cBackDC.Height = cTempDC.Height
BitBlt m_cBackDC.hDC, 0, 0, m_cBackDC.Width, m_cBackDC.Height, cTempDC.hDC,
0, 0, vbSrcCopy
' Return bitmap
cTempDC.ExtractBitmap
End Sub
Public Property Get TileOffsetX() As Long
TileOffsetX = m_xTileOffset
End Property
Public Property Let TileOffsetX(ByVal xOffset As Long)
m_xTileOffset = xOffset
End Property
Public Property Get TileOffsetY() As Long
TileOffsetY = m_yTileOffset
End Property
Public Property Let TileOffsetY(ByVal yOffset As Long)
m_yTileOffset = yOffset
End Property
Public Sub TileArea( _
ByVal hdcTo As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal Width As Long, _
ByVal Height As Long _
)
Dim SrcWidth As Long
Dim SrcHeight As Long
Dim lSrcX As Long
Dim lSrcY As Long
Dim lSrcStartX As Long
Dim lSrcStartY As Long
Dim lSrcStartWidth As Long
Dim lSrcStartHeight As Long
Dim lDstX As Long
Dim lDstY As Long
Dim lDstWidth As Long
Dim lDstHeight As Long
SrcWidth = m_cBackDC.Width
SrcHeight = m_cBackDC.Height
lSrcStartX = ((x + m_xTileOffset) Mod SrcWidth)
lSrcStartY = ((y + m_yTileOffset) Mod SrcHeight)
lSrcStartWidth = (SrcWidth - lSrcStartX)
lSrcStartHeight = (SrcHeight - lSrcStartY)
lSrcX = lSrcStartX
lSrcY = lSrcStartY
lDstY = y
lDstHeight = lSrcStartHeight
Do While lDstY < (y + Height)
If (lDstY + lDstHeight) > (y + Height) Then
lDstHeight = y + Height - lDstY
End If
lDstWidth = lSrcStartWidth
lDstX = x
lSrcX = lSrcStartX
Do While lDstX < (x + Width)
If (lDstX + lDstWidth) > (x + Width) Then
lDstWidth = x + Width - lDstX
If (lDstWidth = 0) Then
lDstWidth = 4
End If
End If
'If (lDstWidth > Width) Then lDstWidth = Width
'If (lDstHeight > Height) Then lDstHeight = Height
BitBlt hdcTo, lDstX, lDstY, lDstWidth, lDstHeight, _
m_cBackDC.hDC, lSrcX, lSrcY, vbSrcCopy
lDstX = lDstX + lDstWidth
lSrcX = 0
lDstWidth = SrcWidth
Loop
lDstY = lDstY + lDstHeight
lSrcY = 0
lDstHeight = SrcHeight
Loop
End Sub
Private Sub PostPaint(Optional ByVal bUseArea As Boolean = False)
Dim lHDC As Long
Dim tR As RECT
'Debug.Print "PostPaint", Hex$(m_hWnd), bUseArea
If m_bFixBackground Then
bUseArea = False
End If
' Get size of textbox:
GetClientRect m_hWnd, tR
' Set work DC to right size:
m_cWorkDC.Width = tR.Right - tR.left + 1
m_cWorkDC.Height = tR.Bottom - tR.tOp + 1
' Copy background into workdc:
If Not m_bFixBackground Then
TileArea m_cWorkDC.hDC, _
m_tR.left, m_tR.tOp, _
m_tR.Right - m_tR.left + 1, m_tR.Bottom - m_tR.tOp + 1
Else
TileArea m_cWorkDC.hDC, _
0, 0, m_cWorkDC.Width, m_cWorkDC.Height
End If
' Ask text box to draw itself into the workdc:
If bUseArea Then
Else
SendMessageLong m_hWnd, WM_PRINT, m_cWorkDC.hDC, PRF_CLIENT Or
PRF_CHECKVISIBLE
End If
' Draw the results into the textbox:
lHDC = GetDC(m_hWnd)
If Not m_bFixBackground Then
BitBlt lHDC, m_tR.left, m_tR.tOp, m_tR.Right - m_tR.left + 1, m_tR.Bottom
- m_tR.tOp + 1, m_cWorkDC.hDC, m_tR.left, m_tR.tOp, vbSrcCopy
Else
BitBlt lHDC, 0, 0, tR.Right - tR.left + 1, tR.Bottom - tR.tOp + 1,
m_cWorkDC.hDC, 0, 0, vbSrcCopy
End If
ReleaseDC m_hWnd, lHDC
End Sub
Public Sub Attach(ByVal hWndA As Long)
Detach
m_hWnd = hWndA
AttachMessage Me, m_hWnd, WM_PAINT
m_hWndParent = GetParent(m_hWnd)
AttachMessage Me, m_hWndParent, WM_CTLCOLOREDIT
AttachMessage Me, m_hWndParent, WM_COMMAND
AttachMessage Me, m_hWnd, WM_ERASEBKGND
AttachMessage Me, m_hWnd, WM_DESTROY
End Sub
Public Sub Detach()
If Not (m_hWnd = 0) Then
DetachMessage Me, m_hWnd, WM_PAINT
If Not m_hWndParent = 0 Then
DetachMessage Me, m_hWndParent, WM_CTLCOLOREDIT
DetachMessage Me, m_hWndParent, WM_COMMAND
End If
m_hWndParent = 0
DetachMessage Me, m_hWnd, WM_ERASEBKGND
DetachMessage Me, m_hWnd, WM_DESTROY
m_hWnd = 0
End If
End Sub
Private Sub Class_Initialize()
m_bFixBackground = True
End Sub
Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
'
End Property
Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
Select Case CurrentMessage
Case WM_DESTROY
ISubclass_MsgResponse = emrPreprocess
Case Else
ISubclass_MsgResponse = emrConsume
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 wCode As Long
'
Select Case iMsg
Case WM_DESTROY
Detach
Case WM_PAINT
' Debug.Print "Paint", Hex$(hwnd)
GetUpdateRect hwnd, m_tR, 0
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
If m_iScroll = 0 Then
PostPaint
Else
Select Case m_iScroll
Case 1
m_iScroll = 1
Case 2
m_iScroll = 0
End Select
End If
Case WM_CTLCOLOREDIT
If m_hWnd = lParam Then
'Debug.Print "CtlColorEdit", Hex$(m_hWnd), wParam, dc
SetBkMode wParam, TRANSPARENT
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
If m_iScroll = 0 Then
If Not m_bCE Then
m_bCE = True
PostPaint
m_bCE = False
End If
Else
Select Case m_iScroll
Case 1
m_iScroll = 2
If Not m_bCE Then
m_bCE = True
' Debug.Print "Scroll", m_tR.left, m_tR.top, m_tR.right,
m_tR.bottom
PostPaint True
m_bCE = False
End If
Case 2
'Debug.Print "CtlColorEdit;Scroll=2"
m_iScroll = 0
End Select
End If
Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If
Case WM_COMMAND
If m_hWnd = lParam Then
wCode = wParam \ &H10000
If wCode = EN_HSCROLL Or wCode = EN_VSCROLL Then
'Debug.Print "SCROLL"
m_iScroll = 1
End If
End If
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
Case WM_ERASEBKGND
ISubclass_WindowProc = 1
End Select
End Function
|
|