Thursday, July 30, 2009

Making activex control XP Theme maskedbox

First of all make new Activex Control project, up to you wish to give what name at your project. all important, ascertaining properties at your User Controls.

Assign value at Autoredraw True and for the Scalemode of Twip.

Then insert code following:

Option Explicit

Private WithEvents TxT As TextBox

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

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

Enum IRULStyleMaskedBoxConst
[Normal MaskedBox Style] = 0
[Windows XP MaskedBox Style] = 1
End Enum

Private Enum DrawTextFlags
DT_TOP = &H0
DT_LEFT = &H0
DT_CENTER = &H1
DT_RIGHT = &H2
DT_VCENTER = &H4
DT_BOTTOM = &H8
DT_WORDBREAK = &H10
DT_SINGLELINE = &H20
DT_EXPANDTABS = &H40
DT_TABSTOP = &H80
DT_NOCLIP = &H100
DT_EXTERNALLEADING = &H200
DT_CALCRECT = &H400
DT_NOPREFIX = &H800
DT_INTERNAL = &H1000
DT_EDITCONTROL = &H2000
DT_PATH_ELLIPSIS = &H4000
DT_END_ELLIPSIS = &H8000
DT_MODIFYSTRING = &H10000
DT_RTLREADING = &H20000
DT_WORD_ELLIPSIS = &H40000
DT_NOFULLWIDTHCHARBREAK = &H80000
DT_HIDEPREFIX = &H100000
DT_PREFIXONLY = &H200000
End Enum

Private RC As RECT
Private m_ForeColor As OLE_COLOR
Private m_Caption As String
Private m_Format As String
Private m_Border As IRULStyleMaskedBoxConst
Private m_HideSelection As Boolean
Private m_BorderColor As OLE_COLOR

Private Const COLOR_DISABLED = vbGrayText

Event Change()
Event Click()
Event DblClick()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Private Function TranslateColor(ByVal lcolor As Long) As Long
On Error GoTo TranslateColor_Error
If OleTranslateColor(lcolor, 0, TranslateColor) Then
TranslateColor = -1
End If
Exit Function
TranslateColor_Error:
End Function

Private Function DrawBorderColor()
Dim a As Long
UserControl.Cls
a = CreateSolidBrush(TranslateColor(m_BorderColor))
If m_Border = [Windows XP MaskedBox Style] Then
UserControl.BorderStyle = 0
FrameRect UserControl.hdc, RC, a
SelectObject UserControl.hdc, a
Else
UserControl.BorderStyle = 1
End If
DeleteObject a
End Function

Private Function DrawTextMasked()
Dim a As Long
Dim b As String
Dim c As Long
Dim tmpRC As RECT
UserControl.ScaleMode = vbPixels
If UserControl.Enabled = False Then
a = TranslateColor(COLOR_DISABLED)
Else
a = m_ForeColor
End If
With tmpRC
.Left = 1
.Top = 1
.Bottom = UserControl.ScaleHeight - 1
.Right = UserControl.ScaleWidth - 1
End With

If m_HideSelection = True Then
b = FormatTXT(m_Caption, m_Format)
c = Len(b)
Else
b = m_Caption
c = -1
End If

SetTextColor UserControl.hdc, TranslateColor(m_ForeColor)
DrawText UserControl.hdc, b, c, tmpRC, DT_VCENTER Or DT_LEFT Or DT_WORDBREAK
UserControl.ScaleMode = vbTwips
DeleteObject a
DeleteObject c
End Function

Private Sub TxT_Change()
m_Caption = TxT.Text
UserControl_Resize
RaiseEvent Change
End Sub

Private Sub TxT_Click()
RaiseEvent Click
End Sub

Private Sub TxT_DblClick()
RaiseEvent DblClick
End Sub

Private Sub TxT_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub TxT_KeyPress(KeyAscii As Integer)
If KeyAscii = 9 Then
SendKeys "{TAB}"
End If
RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub TxT_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub TxT_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub TxT_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub TxT_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Click()
RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub

Private Sub UserControl_EnterFocus()
If UserControl.Enabled = False Then
TxT.Enabled = False
TxT.Visible = False
Else
TxT.Enabled = True
TxT.Visible = True
TxT.Text = m_Caption
TxT.BorderStyle = UserControl.BorderStyle
TxT.SetFocus
TxT.BackColor = UserControl.BackColor
End If
End Sub

Private Sub UserControl_ExitFocus()
TxT.Enabled = False
TxT.Visible = False
End Sub

Private Sub UserControl_Initialize()
Set TxT = UserControl.Controls.Add("VB.TextBox", "TxT")
TxT.Visible = False
TxT.Enabled = False
End Sub

Private Sub UserControl_InitProperties()
m_Caption = 0
m_ForeColor = UserControl.ForeColor
m_Format = "Currency"
UserControl.BackColor = &HFFFFFF
m_Border = [Windows XP MaskedBox Style]
m_HideSelection = True
UserControl.Enabled = True
UserControl.MousePointer = TxT.MousePointer
Set UserControl.MouseIcon = TxT.MouseIcon
TxT.MaxLength = 64
TxT.DataField = ""
Set TxT.DataSource = Nothing
m_BorderColor = vbHighlight
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
If KeyAscii = 9 Then
SendKeys "{TAB}"
End If
RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Paint()
UserControl_Resize
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_ForeColor = PropBag.ReadProperty("ForeColor", UserControl.ForeColor)
m_Format = PropBag.ReadProperty("Format", "Currency")
UserControl.BackColor = PropBag.ReadProperty("BackColor", &HFFFFFF)
m_Caption = PropBag.ReadProperty("Text", 0)
UserControl.Width = PropBag.ReadProperty("Width", 700)
UserControl.Height = PropBag.ReadProperty("Height", 300)
m_Border = PropBag.ReadProperty("BorderStyle", 0)
m_HideSelection = PropBag.ReadProperty("HideSelection", True)
UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
TxT.MousePointer = PropBag.ReadProperty("MousePointer", 0)
Set TxT.MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
TxT.MaxLength = PropBag.ReadProperty("MaxLength", 64)
TxT.DataField = PropBag.ReadProperty("DataField", "")
Set TxT.DataSource = PropBag.ReadProperty("DataSource", Nothing)
m_BorderColor = PropBag.ReadProperty("BorderColor", vbHighlight)
Set UserControl.Font = PropBag.ReadProperty("Font", UserControl.Font)
With TxT
.SelLength = PropBag.ReadProperty("SelLength", 0)
.SelStart = PropBag.ReadProperty("SelStart", 0)
.SelText = PropBag.ReadProperty("SelText", "")
End With

UserControl_Resize
End Sub

Private Sub UserControl_Show()
UserControl_Resize
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("ForeColor", m_ForeColor, UserControl.ForeColor)
Call PropBag.WriteProperty("Format", m_Format, "Currenct")
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &HFFFFFF)
Call PropBag.WriteProperty("Text", m_Caption, 0)
Call PropBag.WriteProperty("BorderStyle", m_Border, 0)
Call PropBag.WriteProperty("Width", UserControl.Width, 700)
Call PropBag.WriteProperty("Height", UserControl.Height, 300)
Call PropBag.WriteProperty("HideSelection", m_HideSelection, True)
Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
Call PropBag.WriteProperty("MousePoinyer", TxT.MousePointer, 0)
Call PropBag.WriteProperty("MouseIcon", TxT.MouseIcon, Nothing)
Call PropBag.WriteProperty("MaxLength", TxT.MaxLength, 64)
Call PropBag.WriteProperty("DataField", TxT.DataField, "")
Call PropBag.WriteProperty("DataSource", TxT.DataSource, Nothing)
Call PropBag.WriteProperty("BorderColor", m_BorderColor, vbHighlight)
Call PropBag.WriteProperty("Font", UserControl.Font, UserControl.Font)
With TxT
Call PropBag.WriteProperty("SelLength", .SelLength, 0)
Call PropBag.WriteProperty("SelStart", .SelStart, 0)
Call PropBag.WriteProperty("SelText", .SelText, "")
End With
End Sub

Private Sub UserControl_Resize()
UserControl.ScaleMode = vbPixels
With RC
.Left = 0
.Top = 0
.Bottom = UserControl.ScaleHeight
.Right = UserControl.ScaleWidth
End With
With TxT
.Left = 1
.Top = 1
.Width = UserControl.ScaleWidth - 2
.Height = UserControl.ScaleHeight - 2
.BorderStyle = UserControl.BorderStyle
End With
UserControl.ScaleMode = vbTwips

Set TxT.Font = UserControl.Font

UserControl.MousePointer = TxT.MousePointer
Set UserControl.MouseIcon = TxT.MouseIcon

DrawBorderColor
DrawTextMasked
End Sub

Private Function StopAllObject()
On Error Resume Next
DeleteObject m_Caption
DeleteObject m_ForeColor
DeleteObject m_Format
DeleteObject m_BorderColor
End Function

Public Property Get Format() As String
Format = m_Format
End Property

Public Property Let Format(ByVal New_Format As String)
m_Format = New_Format
PropertyChanged "Format"
UserControl_Resize
End Property

Public Property Get ForeColor() As OLE_COLOR
ForeColor = m_ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
m_ForeColor = New_ForeColor
PropertyChanged "ForeColor"
UserControl_Resize
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
UserControl.BackColor = New_BackColor
PropertyChanged "BackColor"
UserControl_Resize
End Property

Public Property Get Text() As String
Text = m_Caption
End Property

Public Property Let Text(ByVal New_Text As String)
If MaxLength > 0 Then
If Len(New_Text) > MaxLength Then
m_Caption = Mid(New_Text, 0, MaxLength)
Else
m_Caption = New_Text
End If
Else
m_Caption = New_Text
End If
PropertyChanged "Text"
TxT.Text = New_Text
End Property

Private Sub UserControl_Terminate()
StopAllObject
End Sub

Public Property Get Width() As Long
Width = UserControl.Width
End Property

Public Property Let Width(ByVal New_Width As Long)
UserControl.Width = New_Width
PropertyChanged "Width"
End Property

Public Property Get Height() As Long
Height = UserControl.Height
End Property

Public Property Let Height(ByVal New_Height As Long)
UserControl.Height = New_Height
PropertyChanged "Height"
End Property

Public Property Get hWnd() As Long
hWnd = UserControl.hWnd
End Property

Public Property Get BorderStyle() As IRULStyleMaskedBoxConst
BorderStyle = m_Border
End Property

Public Property Let BorderStyle(ByVal new_Border As IRULStyleMaskedBoxConst)
m_Border = new_Border
PropertyChanged "BorderStyle"
UserControl_Resize
End Property

Public Sub Refresh()
UserControl_Resize
End Sub

Public Property Get SelText() As String
SelText = TxT.SelText
End Property

Public Property Let SelText(ByVal New_SelText As String)
TxT.SelText = New_SelText
Text = New_SelText & m_Caption
End Property

Public Property Get SelStart() As Long
SelStart = TxT.SelStart
End Property

Public Property Let SelStart(ByVal New_SelStart As Long)
TxT.SelStart = New_SelStart
End Property

Public Property Get SelLength() As Long
SelLength = TxT.SelLength
End Property

Public Property Let SelLength(ByVal New_SelLength As Long)
TxT.SelLength = New_SelLength
End Property

Public Property Get HideSelection() As Boolean
HideSelection = m_HideSelection
End Property

Public Property Let HideSelection(ByVal New_HideSelection As Boolean)
m_HideSelection = New_HideSelection
PropertyChanged "HideSelection"
UserControl_Resize
End Property

Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
UserControl.Enabled = New_Enabled
PropertyChanged "Enabled"
UserControl_Resize
End Property

Public Property Get MousePointer() As MousePointerConstants
MousePointer = TxT.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
TxT.MousePointer = New_MousePointer
PropertyChanged "MousePointer"
UserControl_Resize
End Property

Public Property Get MouseIcon() As StdPicture
Set MouseIcon = TxT.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As StdPicture)
Set TxT.MouseIcon = New_MouseIcon
PropertyChanged "MouseIcon"
UserControl_Resize
End Property

Public Property Get MaxLength() As Long
MaxLength = TxT.MaxLength
End Property

Public Property Let MaxLength(ByVal New_MaxLength As Long)
If New_MaxLength < 0 Or New_MaxLength > 64 Then
MsgBox "Invalid Property Value!", vbCritical, Ambient.DisplayName
Exit Property
End If

TxT.MaxLength = New_MaxLength
PropertyChanged "MaxLength"
UserControl_Resize
End Property

Public Property Get DataField() As String
DataField = TxT.DataField
End Property

Public Property Let DataField(ByVal New_DataField As String)
TxT.DataField = New_DataField
PropertyChanged "DataField"
End Property

Public Property Get DataSource() As DataSource
Set DataSource = TxT.DataSource
End Property

Public Property Set DataSource(ByVal New_DataSource As DataSource)
Set TxT.DataSource = New_DataSource
PropertyChanged "DataSource"
End Property

Public Sub Clear()
Text = ""
End Sub

Public Property Get BorderColor() As OLE_COLOR
BorderColor = m_BorderColor
End Property

Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
m_BorderColor = New_BorderColor
PropertyChanged "BorderColor"
UserControl_Resize
End Property

Public Property Get Font() As Font
Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
Set UserControl.Font = New_Font
PropertyChanged "Font"
UserControl_Resize
End Property

Public Property Get FormattedText() As String
FormattedText = FormatTXT(m_Caption, m_Format)
End Property

Private Function FormatTXT(Expression, FormatString) As String
FormatTXT = Format(Expression, FormatString)
End Function


No comments:

Post a Comment