www.pudn.com > ocr.rar > MyButton.ctl
VERSION 5.00
Begin VB.UserControl MyButton
AutoRedraw = -1 'True
ClientHeight = 1770
ClientLeft = 0
ClientTop = 0
ClientWidth = 1860
ClipBehavior = 0 '无
FillStyle = 0 'Solid
PropertyPages = "MyButton.ctx":0000
ScaleHeight = 118
ScaleMode = 3 'Pixel
ScaleWidth = 124
ToolboxBitmap = "MyButton.ctx":0035
End
Attribute VB_Name = "MyButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2008/01/21
'描 述：OCR手写字体识别软件
'网 站：http://www.Mndsoft.com/ (VB6源码博客)
'网 站：http://www.VbDnet.com/ (VB.NET源码博客,主要基于.NET2005)
'e-mail ：Mndsoft@163.com
'e-mail ：Mndsoft@126.com
'OICQ ：88382850
' 如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
'developed by edin omeragic
'from: Bosnia and Hercegovina, Srebrenik
'my email: edoo_ba@hotmail.com
'datum: (20.11 - 3.12) 2002 godine
'type: small project
'==================================================================
'this code is totaly free,
'if you dont like this you may copy it on flopy and throw it away ;},
'If you Like it Then please vote on planetsourcecode
'and also search for:
' - iMenu (old project but good) or
' - iList (cool list)
'==================================================================
'DrawButton(State) - draws button (main function)
'DrawText(...) - draws text (called from drawbutton)
'DrawPicture(...) - draws picture
'DrawPictureDisabled - draws picture grayed
'TilePicture() - tiles picture
'SetRect (left, top, right, bottom) as RECT 'makes rectangle on flay
'ModyfyRect(RECT,left,top,right,bottom) as RECT
'i.e.
'R = SetRect (0,0,1,1)
'R = ModifyRect(R,1,1,1,1)
'R is (1,1,2,2)
'==================================================================
'-for default skin, name the picture box "MyButtonDefSkin"
'-for changing skin in design time set property
' "SkinPictureName" same as picture box name
'==================================================================
Option Explicit
'Default Property Values:
Const m_def_TextAlign = vbCenter
Const m_def_PictureTColor = &HFF00FF
Const m_def_PicturePos = 0
Const m_def_TextColorDisabled2 = 0
Const m_def_DrawFocus = 0
Const m_def_DisplaceText = 0
Const m_def_TextLine = 1
'Const m_def_DownTextDX = 0
'Const m_def_DownTextDY = 0
Const m_def_DisableHover = False
Const m_def_TextColorEnabled = 0
Const m_def_TextColorDisabled = 0
Const m_def_FillWithColor = False
Const m_def_SizeCW = 12
Const m_def_SizeCH = 11
Const m_def_Text = ""
'Property Variables:
Dim m_TextAlign As AlignmentConstants
Dim m_PictureTColor As Ole_Color
Dim m_TextLine As Integer
Dim m_PicturePos As Integer
Dim m_Picture As StdPicture
Dim m_TextColorDisabled2 As Ole_Color
Dim m_DrawFocus As Integer
Dim m_DisplaceText As Integer
Dim m_DisableHover As Boolean
Dim m_TextColorEnabled As Ole_Color
Dim m_TextColorDisabled As Ole_Color
Dim m_FillWithColor As Boolean
Dim m_SizeCW As Long
Dim m_SizeCH As Long
Dim m_SkinPicture As PictureBox
Dim m_Text As String
Dim m_State As Integer
Dim m_HasFocus As Boolean
Dim m_BtnDown As Boolean
Dim m_SpcDown As Boolean
Dim m_SkinPictureName As String
Public Enum EnumPicturePos
ppLeft
ppTop
ppBottom
ppRight
ppCenter
End Enum
Private Const DI_NORMAL As Long = &H3
Const BTN_NORMAL = 1
Const BTN_FOCUS = 2
Const BTN_HOVER = 3
Const BTN_DOWN = 4
Const BTN_DISABLED = 5
'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event MouseHover()
Event MouseOut()
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)
Event KeyPress(KeyAscii As Integer)
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Enum EnumDrawTextFormat
DT_BOTTOM = &H8
DT_CALCRECT = &H400
DT_CENTER = &H1
DT_CHARSTREAM = 4
DT_DISPFILE = 6
DT_EXPANDTABS = &H40
DT_EXTERNALLEADING = &H200
DT_INTERNAL = &H1000
DT_LEFT = &H0
DT_METAFILE = 5
DT_NOCLIP = &H100
DT_NOPREFIX = &H800
DT_PLOTTER = 0
DT_RASCAMERA = 3
DT_RASDISPLAY = 1
DT_RASPRINTER = 2
DT_RIGHT = &H2
DT_SINGLELINE = &H20
DT_TABSTOP = &H80
DT_TOP = &H0
DT_VCENTER = &H4
DT_WORDBREAK = &H10
DT_WORD_ELLIPSIS = &H40000
DT_END_ELLIPSIS = 32768
DT_PATH_ELLIPSIS = &H4000
DT_EDITCONTROL = &H2000
'===================
DT_INCENTER = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
End Enum
Private Const SRCCOPY = &HCC0020
Private Const RGN_AND = 1
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 SelectClipPath Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function apiDrawText 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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function apiTranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As Ole_Color, ByVal palet As Long, Col As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
'MY NOTE: TransparentBlt on Win98 leavs some garbage in memory...
'
'Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GdiTransparentBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'for picture
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
'Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
'Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
'never enough
Private Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
'windows version
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
'#############################################
'//GDI + SOMETHING ELSE#######################
Private Sub TransBlt(ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal clrMask As Ole_Color)
'one check to see if GdiTransparentblt is supported
'better way to check if function is suported is using LoadLibrary and GetProcAdress
'than using GetVersion or GetVersionEx
'=====================================================
Dim Lib As Long
Dim ProcAdress As Long
Dim lMaskColor As Long
lMaskColor = TranslateColor(clrMask)
Lib = LoadLibrary("gdi32.dll")
'-------------------------------->make sure to specify corect name for function
ProcAdress = GetProcAddress(Lib, "GdiTransparentBlt")
FreeLibrary Lib
If ProcAdress <> 0 Then
'works on XP
GdiTransparentBlt hdcDest, xDest, yDest, nWidth, nHeight, hdcSrc, xSrc, ySrc, nWidth, nHeight, lMaskColor
'Debug.Print "Gdi transparent blt"
Exit Sub 'make it short
End If
'=====================================================
Const DSna As Long = &H220326
Dim hdcMask As Long
Dim hdcColor As Long
Dim hbmMask As Long
Dim hbmColor As Long
Dim hbmColorOld As Long
Dim hbmMaskOld As Long
Dim hdcScreen As Long
Dim hdcScnBuffer As Long
Dim hbmScnBuffer As Long
Dim hbmScnBufferOld As Long
hdcScreen = UserControl.hdc
lMaskColor = TranslateColor(clrMask)
hbmScnBuffer = CreateCompatibleBitmap(hdcScreen, nWidth, nHeight)
hdcScnBuffer = CreateCompatibleDC(hdcScreen)
hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
BitBlt hdcScnBuffer, 0, 0, nWidth, nHeight, hdcDest, xDest, yDest, vbSrcCopy
hbmColor = CreateCompatibleBitmap(hdcScreen, nWidth, nHeight)
hbmMask = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)
hdcColor = CreateCompatibleDC(hdcScreen)
hbmColorOld = SelectObject(hdcColor, hbmColor)
Call SetBkColor(hdcColor, GetBkColor(hdcSrc))
Call SetTextColor(hdcColor, GetTextColor(hdcSrc))
Call BitBlt(hdcColor, 0, 0, nWidth, nHeight, hdcSrc, xSrc, ySrc, vbSrcCopy)
hdcMask = CreateCompatibleDC(hdcScreen)
hbmMaskOld = SelectObject(hdcMask, hbmMask)
SetBkColor hdcColor, lMaskColor
SetTextColor hdcColor, vbWhite
BitBlt hdcMask, 0, 0, nWidth, nHeight, hdcColor, 0, 0, vbSrcCopy
SetTextColor hdcColor, vbBlack
SetBkColor hdcColor, vbWhite
BitBlt hdcColor, 0, 0, nWidth, nHeight, hdcMask, 0, 0, DSna
BitBlt hdcScnBuffer, 0, 0, nWidth, nHeight, hdcMask, 0, 0, vbSrcAnd
BitBlt hdcScnBuffer, 0, 0, nWidth, nHeight, hdcColor, 0, 0, vbSrcPaint
BitBlt hdcDest, xDest, yDest, nWidth, nHeight, hdcScnBuffer, 0, 0, vbSrcCopy
'clear
DeleteObject SelectObject(hdcColor, hbmColorOld)
DeleteDC hdcColor
DeleteObject SelectObject(hdcScnBuffer, hbmScnBufferOld)
DeleteDC hdcScnBuffer
DeleteObject SelectObject(hdcMask, hbmMaskOld)
DeleteDC hdcMask
'ReleaseDC 0, hdcScreen
End Sub
Private Function GetRgbQuad(ByVal R As Byte, ByVal G As Byte, ByVal B As Byte) As RGBQUAD
With GetRgbQuad
.rgbBlue = B
.rgbGreen = G
.rgbRed = R
End With
End Function
Private Function DrawPictureDisabled(ByVal P As StdPicture, x As Long, y As Long, _
w As Long, h As Long, _
Optional ColHighlight As Long = vb3DHighlight, _
Optional ColShadow As Long = vb3DShadow)
Dim MemDC As Long
Dim MyBmp As Long
Dim cShadow As Long
Dim cHiglight As Long
Dim ColPal(0 To 1) As RGBQUAD
Dim rgbBlack As RGBQUAD
Dim rgbWhite As RGBQUAD
Dim BI As BITMAPINFO
Dim hdc As Long
Dim hPicDc As Long
Dim hPicBmp As Long
hdc = UserControl.hdc
cHiglight = TranslateColor(vb3DHighlight)
cShadow = TranslateColor(vb3DShadow)
'rgbBlack = GetRgbQuad(0, 0, 0)
rgbWhite = GetRgbQuad(255, 255, 255)
With BI.bmiHeader
.biSize = 40 'size of bmiHeader structure
.biHeight = -h
.biWidth = w
.biPlanes = 1
.biCompression = 0 'BI_RGB
.biClrImportant = 0
.biBitCount = 1 'monohrome bitmap
End With
'color palete
With BI
.bmiColors(0) = rgbBlack
.bmiColors(1) = rgbWhite
End With
Dim hMonoSec As Long
Dim pBits As Long
Dim hdcMono As Long
hMonoSec = CreateDIBSection(hdc, BI, 0, pBits, 0&, 0&)
'Debug.Print "MonoSec:"; hMonoSec
hdcMono = CreateCompatibleDC(hdc)
SelectObject hdcMono, hMonoSec
'create dc for picture
hPicDc = CreateCompatibleDC(hdc)
If P.Type = vbPicTypeIcon Then
hPicBmp = CreateCompatibleBitmap(hdc, w, h)
SelectObject hPicDc, hPicBmp
DeleteObject hPicBmp
ClearRect hPicDc, SetRect(0, 0, w, h), TranslateColor(m_PictureTColor)
DrawIconEx hPicDc, 0, 0, P.handle, w, h, 0, 0, DI_NORMAL
'Debug.Print "DRAW ICON"
ElseIf P.Type = vbPicTypeBitmap Then
SelectObject hPicDc, P.handle
End If
'copy hPicDc to hdcMono
BitBlt hdcMono, 0, 0, w, h, hPicDc, 0, 0, SRCCOPY
DeleteDC hPicDc
Dim R As Integer, G As Integer, B As Integer
GetRgb cHiglight, R, G, B
'change black color in palete to highlight(r,g,b) color
ColPal(0) = GetRgbQuad(R, G, B)
ColPal(1) = rgbBlack 'change white color in palete to black color
SetDIBColorTable hdcMono, 0, 2, ColPal(0) 'set new palete
RealizePalette hdcMono 'update it
'BitBlt Me.hdc, 1, 1, W, H, hdcMono, 0, 0, SRCCOPY
'transparent blit to dest hDC using black as transparent colour
'x+1 and y+1 - moves down and left for 1 pixel
TransBlt hdc, x + 1, y + 1, w, h, hdcMono, 0, 0, 0
'get rgb components of shadow color
GetRgb cShadow, R, G, B
'change black color to shadow color in palete
ColPal(0) = GetRgbQuad(R, G, B)
ColPal(1) = rgbWhite 'change back to white
'set new palete
SetDIBColorTable hdcMono, 0, 2, ColPal(0)
RealizePalette hdcMono ' then update
'transparent blit do dest hdc using white color as transparent
TransBlt hdc, x, y, w, h, hdcMono, 0, 0, RGB(255, 255, 255)
'BitBlt Me.hDC, 0, 0, W, H, hdcMono, 0, 0, SRCCOPY
'Debug.Print DeleteObject(hMonoSec)
'Debug.Print DeleteObject(hdcMono)
End Function
Sub GetRgb(Color As Long, R As Integer, G As Integer, B As Integer)
R = Color And 255 'clear bites from 9 to 32
G = (Color \ 256) And 255 'shift right 8 bits and clear
B = (Color \ 65536) And 255 'shift 16 bits and clear for any case
End Sub
Private Function GetBmpSize(Bmp As StdPicture, w As Long, h As Long) As Long
' Dim B As BITMAP
' GetBmpSize = GetObject(Bmp, Len(B), B)
w = ScaleX(Bmp.Width, vbHimetric, vbPixels)
h = ScaleY(Bmp.Height, vbHimetric, vbPixels)
' Debug.Print W, H
' W = B.bmWidth
' H = B.bmHeight
' Debug.Print B.bmType
' Debug.Print W, H
End Function
Private Sub DrawPicture(hdc As Long, P As StdPicture, x As Long, y As Long, w As Long, h As Long, TOleCol As Long)
'check picture format
If P.Type = vbPicTypeIcon Then
DrawIconEx hdc, x, y, P.handle, w, h, 0, 0, DI_NORMAL
Exit Sub
End If
'creting dc with the same format as screen dc
Dim MemDC As Long
MemDC = CreateCompatibleDC(0)
'select a picture into memdc
SelectObject MemDC, P.handle '
'tranparent blit memdc on usercontrol
TransBlt UserControl.hdc, x, y, w, h, MemDC, 0, 0, TranslateColor(TOleCol)
DeleteDC MemDC 'its clear, heh
End Sub
Private Function ModifyRect(lpRect As RECT, ByVal Left As Long, ByVal Top As Long, _
ByVal Right As Long, ByVal Bottom As Long) As RECT
With ModifyRect
.Left = lpRect.Left + Left
.Top = lpRect.Top + Top
.Right = lpRect.Right + Right
.Bottom = lpRect.Bottom + Bottom
End With
End Function
Private Function TranslateColor(ByVal Ole_Color As Long) As Long
apiTranslateColor Ole_Color, 0, TranslateColor
End Function
Private Function SetRect(ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) As RECT
With SetRect
.Left = Left
.Top = Top
.Right = Right
.Bottom = Bottom
End With
End Function
Private Sub NormalizeRect(R As RECT)
Dim c As Long
If R.Left > R.Right Then
c = R.Right
R.Right = R.Left
R.Left = c
End If
If R.Top > R.Bottom Then
c = R.Top
R.Top = R.Bottom
R.Bottom = c
End If
End Sub
Private Function RoundUp(ByVal num As Single) As Long
If Int(num) < num Then
RoundUp = Int(num) + 1
Else
RoundUp = num
End If
End Function
Private Function RectHeight(R As RECT) As Long
RectHeight = R.Bottom - R.Top
End Function
Private Function RectWidth(R As RECT) As Long
RectWidth = R.Right - R.Left
End Function
Function TxtFix(StrText As String, MaxWidth As Long) As String
Dim i As Long, j As Long
Dim StrLeft As String, TxtTemp As String
TxtTemp = StrText
TxtFix = ""
For i = Len(TxtTemp) To 1 Step -1
For j = Len(TxtTemp) To 1 Step -1
If UserControl.TextWidth(Left(TxtTemp, j)) <= MaxWidth Then
StrLeft = Left(TxtTemp, j)
TxtTemp = Right(TxtTemp, Len(TxtTemp) - j)
If TxtFix = "" Then
TxtFix = StrLeft
Else
TxtFix = TxtFix & vbCrLf & StrLeft
End If
Exit For
End If
Next j
Next i
End Function
Private Sub DrawText(ByVal hdc As Long, ByVal StrText As String, R As RECT, ByVal Format As Long)
Dim TempText As String, TempHeight As Long, TempTop As Long, Rc As RECT
TempText = TxtFix(StrText, R.Right - R.Left)
TempHeight = UserControl.TextHeight(TempText)
TempTop = R.Top - (R.Top - R.Bottom) / 2 - TempHeight / 2
Rc = SetRect(R.Left, TempTop, R.Right, TempTop + TempHeight)
With UserControl
apiDrawText .hdc, StrText, lstrlen(StrText), Rc, Format
End With
End Sub
Private Sub TilePicture(DestRect As RECT, SrcRect As RECT, ByVal SrcDc As Long, Optional UseCliper As Boolean = True, Optional ROp As Long = SRCCOPY)
Dim i As Integer
Dim j As Integer
Dim rows As Integer
Dim ColS As Integer
Dim destW As Long
Dim destH As Long
Dim hdc As Long
hdc = UserControl.hdc
NormalizeRect DestRect
NormalizeRect SrcRect
'calculates row and cols
rows = RoundUp(RectHeight(DestRect) / RectHeight(SrcRect))
ColS = RoundUp(RectWidth(DestRect) / RectWidth(SrcRect))
destW = RectWidth(SrcRect)
destH = RectHeight(SrcRect)
'prevents drawing out of specified rectangle
If UseCliper Then
SelectClipRgn hdc, ByVal 0
BeginPath hdc
With DestRect
Rectangle hdc, .Left, .Top, .Right + 1, .Bottom + 1
End With
EndPath hdc
SelectClipPath hdc, RGN_AND
End If
For i = 0 To rows - 1
For j = 0 To ColS - 1
BitBlt hdc, j * destW + DestRect.Left, i * destH + DestRect.Top, destW, destH, SrcDc, _
SrcRect.Left, SrcRect.Top, ROp
Next
Next
If UseCliper Then
SelectClipRgn hdc, ByVal 0
End If
End Sub
Private Sub ClearRect(ByVal hdc As Long, lRect As RECT, ByVal Color As Long)
Dim Brush As Long
Dim PBrush As Long
Brush = CreateSolidBrush(Color)
PBrush = SelectObject(hdc, Brush)
FillRect hdc, lRect, Brush
DeleteObject SelectObject(hdc, PBrush)
End Sub
'//END GDI####################################
'#############################################
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,3
Public Property Get SizeCW() As Long
Attribute SizeCW.VB_Description = "Corner width."
Attribute SizeCW.VB_ProcData.VB_Invoke_Property = ";Position"
SizeCW = m_SizeCW
End Property
Public Property Let SizeCW(ByVal New_SizeCW As Long)
m_SizeCW = New_SizeCW
PropertyChanged "SizeCW"
Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,3
Public Property Get SizeCH() As Long
Attribute SizeCH.VB_Description = "Corner height."
Attribute SizeCH.VB_ProcData.VB_Invoke_Property = ";Position"
SizeCH = m_SizeCH
End Property
Public Property Let SizeCH(ByVal New_SizeCH As Long)
m_SizeCH = New_SizeCH
PropertyChanged "SizeCH"
Refresh
End Property
Public Property Get TextLine() As Integer
TextLine = m_TextLine
End Property
Public Property Let TextLine(ByVal New_TextLine As Integer)
m_TextLine = New_TextLine
PropertyChanged "TextLine"
Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=9,0,0,0
Public Property Get SkinPicture() As Object
Attribute SkinPicture.VB_Description = "Reference to picture box object."
Set SkinPicture = m_SkinPicture
End Property
Public Property Set SkinPicture(New_SkinPicture As Object)
If (TypeName(New_SkinPicture) <> "PictureBox") And _
(New_SkinPicture Is Nothing = False) Then
Err.Raise 5, "MyButton::SkinPicture", Err.Description
Exit Property
End If
Set m_SkinPicture = New_SkinPicture
If m_SkinPicture Is Nothing = False Then
m_SkinPictureName = m_SkinPicture.Name
Else
m_SkinPictureName = ""
End If
Refresh
PropertyChanged "SPN"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get Text() As String
Attribute Text.VB_Description = "Button text."
Attribute Text.VB_ProcData.VB_Invoke_Property = ";Text"
Text = m_Text
End Property
Public Property Let Text(ByVal New_Text As String)
m_Text = New_Text
Refresh
PropertyChanged "Text"
'setting access key (allows alt + accesskey)
Dim i As Long
Dim c As String
For i = 1 To Len(New_Text) - 1
If Mid(New_Text, i, 1) = "&" Then
c = Mid(New_Text, i + 1, 1)
If c <> "&" Or c <> " " Then
UserControl.AccessKeys = c
PropertyChanged "AccessKey"
End If
End If
Next
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get SkinPictureName() As String
Attribute SkinPictureName.VB_Description = "Allows you to set reference at design time."
Attribute SkinPictureName.VB_ProcData.VB_Invoke_Property = ";Appearance"
'If m_SkinPicture Is Nothing = False Then
'SkinPictureName = m_SkinPicture.Name
SkinPictureName = m_SkinPictureName
'End If
End Property
Public Property Let SkinPictureName(ByVal New_SkinPictureName As String)
On Error GoTo NotLegalName
Dim P As Object
'Debug.Print New_SkinPictureName
If New_SkinPictureName <> "" Then
Set P = UserControl.Parent.Controls(New_SkinPictureName)
If P Is Nothing = False Then
Set SkinPicture = P
'Debug.Print "Setting p"; P.Name
End If
Else
Set m_SkinPicture = Nothing
'Debug.Print "P is nothing"
Refresh
End If
' m_SkinPictureName = New_SkinPictureName
PropertyChanged "SPN"
NotLegalName:
End Property
Private Sub UserControl_DblClick()
DrawButton BTN_DOWN
End Sub
Private Sub UserControl_GotFocus()
m_HasFocus = True
If m_BtnDown = False Then DrawButton BTN_FOCUS
End Sub
Private Sub UserControl_Initialize()
' SkinPictureName = m_SkinPictureName
' MsgBox "Initialize..." + m_SkinPictureName
End Sub
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
m_SizeCW = m_def_SizeCW
m_SizeCH = m_def_SizeCH
m_Text = Extender.Name
m_FillWithColor = m_def_FillWithColor
m_TextColorEnabled = m_def_TextColorEnabled
m_TextColorDisabled = m_def_TextColorDisabled
Set UserControl.Font = Ambient.Font
m_DisableHover = m_def_DisableHover
m_DisplaceText = m_def_DisplaceText
m_TextLine = m_def_TextLine
m_DrawFocus = m_def_DrawFocus
m_TextColorDisabled2 = m_def_TextColorDisabled2
Set m_Picture = LoadPicture("")
m_PicturePos = m_def_PicturePos
m_PictureTColor = m_def_PictureTColor
m_SkinPictureName = "MyButtonDefSkin"
m_TextAlign = m_def_TextAlign
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
If KeyCode = vbKeySpace Then
m_SpcDown = True
DrawButton BTN_DOWN
Else
m_SpcDown = False
DrawButton BTN_FOCUS
End If
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
If KeyAscii = vbKeyReturn Then
RaiseEvent Click
End If
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
If KeyCode = 32 And m_SpcDown And m_State = BTN_DOWN Then
m_SpcDown = False
DrawButton BTN_NORMAL
RaiseEvent Click
DrawButton BTN_FOCUS
End If
End Sub
Private Sub UserControl_LostFocus()
m_HasFocus = False
DrawButton BTN_NORMAL
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseDown(Button, Shift, x, y)
If Button = 1 Then m_BtnDown = True
UserControl_MouseMove Button, Shift, x, y
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If m_SpcDown Then Exit Sub
RaiseEvent MouseMove(Button, Shift, x, y)
SetCapture hwnd
If PointInControl(x, y) Then
'if pointer is on control
If m_BtnDown Then
If m_State <> BTN_DOWN Then
DrawButton BTN_DOWN
End If
Else
If m_State <> BTN_HOVER Then
RaiseEvent MouseHover
DrawButton BTN_HOVER
End If
End If
Else
'if pointer is out of control
If m_BtnDown Then
RaiseEvent MouseHover
DrawButton BTN_HOVER
Else
RaiseEvent MouseOut
If m_HasFocus Then
DrawButton BTN_FOCUS
Else
DrawButton BTN_NORMAL
End If
ReleaseCapture
End If
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
m_BtnDown = False
' If m_State <> BTN_NORMAL Then
DrawButton BTN_NORMAL
' End If
RaiseEvent MouseUp(Button, Shift, x, y)
If Button = vbLeftButton Then
If PointInControl(x, y) Then RaiseEvent Click
' If m_State <> BTN_FOCUS Then
DrawButton BTN_FOCUS
' End If
End If
End Sub
Private Sub UserControl_Paint()
Me.Refresh
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_SizeCW = PropBag.ReadProperty("SizeCW", m_def_SizeCW)
m_SizeCH = PropBag.ReadProperty("SizeCH", m_def_SizeCH)
m_SkinPictureName = PropBag.ReadProperty("SPN", "")
'Debug.Print "ReadProp SPN:"; m_SkinPictureName
m_TextLine = PropBag.ReadProperty("TextLine", m_def_TextLine)
m_Text = PropBag.ReadProperty("Text", m_def_Text)
m_FillWithColor = PropBag.ReadProperty("FillWithColor", m_def_FillWithColor)
UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
UserControl.AccessKeys = PropBag.ReadProperty("AccessKey", "")
m_TextColorEnabled = PropBag.ReadProperty("TextColorEnabled", m_def_TextColorEnabled)
m_TextColorDisabled = PropBag.ReadProperty("TextColorDisabled", m_def_TextColorDisabled)
Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
m_DisableHover = PropBag.ReadProperty("DisableHover", m_def_DisableHover)
' m_DownTextDX = PropBag.ReadProperty("DownTextDX", m_def_DownTextDX)
' m_DownTextDY = PropBag.ReadProperty("DownTextDY", m_def_DownTextDY)
m_DisplaceText = PropBag.ReadProperty("DisplaceText", m_def_DisplaceText)
m_DrawFocus = PropBag.ReadProperty("DrawFocus", m_def_DrawFocus)
m_TextColorDisabled2 = PropBag.ReadProperty("TextColorDisabled2", m_def_TextColorDisabled2)
Set m_Picture = PropBag.ReadProperty("Picture", Nothing)
m_PicturePos = PropBag.ReadProperty("PicturePos", m_def_PicturePos)
m_PictureTColor = PropBag.ReadProperty("PictureTColor", m_def_PictureTColor)
m_TextAlign = PropBag.ReadProperty("TextAlign", m_def_TextAlign)
UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
End Sub
Private Sub UserControl_Resize()
Refresh
End Sub
Private Sub UserControl_Show()
SkinPictureName = m_SkinPictureName
' Refresh
End Sub
Private Sub UserControl_Terminate()
Set m_SkinPicture = Nothing
Set m_Picture = Nothing
'Set UserControl = Nothing
'Set Me = Nothing
'Debug.Print "TERMINATE"
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("SizeCW", m_SizeCW, m_def_SizeCW)
Call PropBag.WriteProperty("SizeCH", m_SizeCH, m_def_SizeCH)
'If m_SkinPicture Is Nothing = False Then
Call PropBag.WriteProperty("SPN", m_SkinPictureName, "")
'End If
'Debug.Print "Write :"; m_SkinPictureName
Call PropBag.WriteProperty("TextLine", m_def_TextLine)
Call PropBag.WriteProperty("Text", m_Text, m_def_Text)
Call PropBag.WriteProperty("FillWithColor", m_FillWithColor, m_def_FillWithColor)
Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
Call PropBag.WriteProperty("AccessKey", UserControl.AccessKeys, "")
Call PropBag.WriteProperty("TextColorEnabled", m_TextColorEnabled, m_def_TextColorEnabled)
Call PropBag.WriteProperty("TextColorDisabled", m_TextColorDisabled, m_def_TextColorDisabled)
Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
Call PropBag.WriteProperty("DisableHover", m_DisableHover, m_def_DisableHover)
Call PropBag.WriteProperty("DisplaceText", m_DisplaceText, m_def_DisplaceText)
Call PropBag.WriteProperty("DrawFocus", m_DrawFocus, m_def_DrawFocus)
Call PropBag.WriteProperty("TextColorDisabled2", m_TextColorDisabled2, m_def_TextColorDisabled2)
Call PropBag.WriteProperty("Picture", m_Picture, Nothing)
Call PropBag.WriteProperty("PicturePos", m_PicturePos, m_def_PicturePos)
Call PropBag.WriteProperty("PictureTColor", m_PictureTColor, m_def_PictureTColor)
Call PropBag.WriteProperty("TextAlign", m_TextAlign, m_def_TextAlign)
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
End Sub
Private Sub DrawButton(ByVal State As Integer)
If m_DisableHover Then
If State = BTN_HOVER Then Exit Sub
'dont draw hover state if m_DisableHover is true
End If
' Debug.Print "State1 "; State
On Error GoTo UnknownError
Dim PicW As Long
Dim PicH As Long 'width and height of picture
Dim PicX As Long
Dim PicY As Long 'picture pos
Dim DH As Long 'button height
Dim dw As Long 'button width
Dim Align As Long 'text aligment
Dim bDrawText As Boolean ' if picture is in center text is not drawn
bDrawText = True
Align = DT_VCENTER Or DT_END_ELLIPSIS Or DT_WORDBREAK
Select Case m_TextAlign
Case Is = vbLeftJustify: Align = Align Or DT_LEFT
Case Is = vbRightJustify: Align = Align Or DT_RIGHT
Case Is = vbCenter: Align = Align Or DT_CENTER
End Select
dw = UserControl.ScaleWidth
DH = UserControl.ScaleHeight
m_State = State
'if skin picture is not set then just draw text on control
If m_SkinPicture Is Nothing Then
ClearRect hdc, SetRect(0, 0, dw, DH), TranslateColor(UserControl.BackColor)
DrawText hdc, m_Text, SetRect(0, 0, dw, DH), Align
If UserControl.AutoRedraw = True Then
UserControl.Refresh
End If
Exit Sub
End If
m_SkinPicture.ScaleMode = vbPixels
Dim SrcLeft As Long 'left cordinate of skin in skinpicture
Dim SrcRight As Long 'right -II-
Dim FillColor As Long 'color to fill middle area of button
'used if m_FillWithColor is true
Dim h As Long 'height of skinpicture
Dim w As Long 'width of button skin
h = m_SkinPicture.ScaleHeight
w = m_SkinPicture.ScaleWidth / 5
'Debug.Print H, W
'
SrcLeft = (State - 1) * w
SrcRight = State * w
If m_FillWithColor Then
'get color to fill with from (SrcLeft+m_SizeCW +1 , m_SizeCH+1) on
'skin picture
FillColor = m_SkinPicture.Point(SrcLeft + m_SizeCW + 1, m_SizeCH + 1)
End If
'Exit Sub
ClearRect hdc, SetRect(0, 0, dw, DH), TranslateColor(UserControl.BackColor)
If m_FillWithColor Then
'paint button with fillcolor
'NOTE: it would be nice if there is gradient file
ClearRect hdc, SetRect(m_SizeCW, m_SizeCH, dw - m_SizeCW, DH - m_SizeCH), FillColor
'ABOUT ADDING GRADIENT FILL
'read second color from skin at
'point (srcleft+cw+1, H -m_sizeCH-1)
'may be implemented in MyButton2
Else
'tile skin
TilePicture SetRect(m_SizeCW, m_SizeCH, dw - m_SizeCW, DH - m_SizeCH), _
SetRect(SrcLeft + m_SizeCW, m_SizeCH, SrcRight - m_SizeCW, h - m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
End If
'draws borders
If (m_SizeCH > 0 And m_SizeCW > 0) Then
TilePicture SetRect(m_SizeCW, 0, dw, m_SizeCH), _
SetRect(SrcLeft + m_SizeCW, 0, SrcRight - m_SizeCW, m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
TilePicture SetRect(m_SizeCW, DH - m_SizeCH, dw, DH), _
SetRect(SrcLeft + m_SizeCW, h - m_SizeCH, SrcRight - m_SizeCW, h), _
m_SkinPicture.hdc, False, SRCCOPY
TilePicture SetRect(0, 0, m_SizeCW, DH), _
SetRect(SrcLeft, m_SizeCH, SrcLeft + m_SizeCW, h - m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
TilePicture SetRect(dw - m_SizeCW, m_SizeCH, dw, DH - m_SizeCH), _
SetRect(SrcRight - m_SizeCW, m_SizeCH, SrcRight, h - m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
'draws corners
'NOTE: must chage to transparent blit (done)
TransBlt hdc, 0, 0, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcLeft, 0, &HFF00FF
TransBlt hdc, 0, DH - m_SizeCH, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcLeft, h - m_SizeCH, &HFF00FF
TransBlt hdc, dw - m_SizeCW, 0, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcRight - m_SizeCW, 0, &HFF00FF
TransBlt hdc, dw - m_SizeCW, DH - m_SizeCH, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcRight - m_SizeCW, h - m_SizeCH, &HFF00FF
End If
Dim Pcolor As Long 'previous color
Pcolor = UserControl.ForeColor
Dim TextRect As RECT
If State = BTN_DOWN Then
TextRect = SetRect(3 + m_DisplaceText, 3 + m_DisplaceText, dw - 3 + m_DisplaceText - 3, DH - 3 + m_DisplaceText)
Else
TextRect = SetRect(3, 3, dw - 3 - 3, DH - 3)
End If
If m_Picture Is Nothing Then
If m_State = BTN_DISABLED Then
'draw text only
'dont draw text2 if colors are the same
If m_TextColorDisabled <> m_TextColorDisabled2 Then
UserControl.ForeColor = m_TextColorDisabled2
TextRect = ModifyRect(TextRect, 1, 1, 1, 1)
DrawText hdc, m_Text, TextRect, Align
TextRect = ModifyRect(TextRect, -1, -1, -1, -1)
End If
UserControl.ForeColor = m_TextColorDisabled
DrawText hdc, m_Text, TextRect, Align
Else
'draw text only
UserControl.ForeColor = m_TextColorEnabled
DrawText hdc, m_Text, TextRect, Align
End If
Else
GetBmpSize m_Picture, PicW, PicH
PicY = (DH - PicH) / 2
If m_State = BTN_DOWN Then
PicY = PicY + m_DisplaceText
End If
Select Case m_PicturePos
Case Is = ppLeft
PicX = TextRect.Left + 3
TextRect.Left = PicX + PicW + TextRect.Left
Case Is = ppRight
PicX = TextRect.Right - PicW - 3 + TextRect.Left - 3
TextRect.Right = PicX - 3
Case Is = ppTop
PicX = (dw - PicW) / 2 + TextRect.Left - SizeCW
PicY = (DH - PicH - 3 - UserControl.TextHeight("I")) / 2 + TextRect.Top - SizeCH
TextRect.Top = PicY + PicW + 3
TextRect.Bottom = TextRect.Top + UserControl.TextHeight("I") * 1.2
Case Is = ppBottom
TextRect.Top = (DH - PicH - 3 - UserControl.TextHeight("I")) / 2 + TextRect.Top - SizeCH
PicX = (dw - PicW) / 2 + TextRect.Left - SizeCW
TextRect.Bottom = TextRect.Top + UserControl.TextHeight("I") * 1.2
PicY = TextRect.Bottom + 3
Case Is = ppCenter
PicX = (dw - PicW) / 2
If BTN_DOWN Then PicX = PicX + m_DisplaceText
bDrawText = False
End Select
' Debug.Print "State2 "; State
If m_State = BTN_DISABLED Then
'draw text and picture disabled
DrawPictureDisabled m_Picture, PicX, PicY, PicW, PicH
If m_TextColorDisabled <> m_TextColorDisabled2 Then
If bDrawText Then
UserControl.ForeColor = m_TextColorDisabled2
TextRect = ModifyRect(TextRect, 1, 1, 1, 1)
DrawText hdc, m_Text, TextRect, Align
TextRect = ModifyRect(TextRect, -1, -1, -1, -1)
End If
End If
UserControl.ForeColor = m_TextColorDisabled
If bDrawText Then
DrawText hdc, m_Text, TextRect, Align
End If
Else
'draw text and picture enabled
UserControl.ForeColor = m_TextColorEnabled
If bDrawText Then
DrawText hdc, m_Text, TextRect, Align
End If
DrawPicture hdc, m_Picture, PicX, PicY, PicW, PicH, m_PictureTColor
End If
End If
Dim f As Long
If m_DrawFocus > 0 Then
If State = BTN_DOWN Or State = BTN_FOCUS Then
f = CLng(m_DrawFocus)
DrawFocusRect hdc, SetRect(f, f, dw - f, DH - f)
End If
End If
UserControl.ForeColor = Pcolor
If UserControl.AutoRedraw = True Then
UserControl.Refresh
End If
Exit Sub
UnknownError:
'most important line in this function
'i about 2 hours to find out
Set m_SkinPicture = Nothing
'removing this line form will not unload properly
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,True
Public Property Get FillWithColor() As Boolean
Attribute FillWithColor.VB_Description = "Middle area of button is filled with color if true or tiled with skin."
Attribute FillWithColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
FillWithColor = m_FillWithColor
End Property
Public Property Let FillWithColor(ByVal New_FillWithColor As Boolean)
m_FillWithColor = New_FillWithColor
Refresh
PropertyChanged "FillWithColor"
End Property
Public Sub Refresh()
If m_State < 1 Or m_State > 5 Then m_State = 1
If Enabled Then
DrawButton m_State
Else
DrawButton BTN_DISABLED
End If
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,hWnd
Public Property Get hwnd() As Long
Attribute hwnd.VB_Description = "Returns a handle (from Microsoft Windows) to an object's window."
hwnd = UserControl.hwnd
End Property
Private Function PointInControl(x As Single, y As Single) As Boolean
If x >= 0 And x <= UserControl.ScaleWidth And _
y >= 0 And y <= UserControl.ScaleHeight Then
PointInControl = True
End If
End Function
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
UserControl.Enabled() = New_Enabled
If New_Enabled Then
DrawButton BTN_NORMAL
Else
DrawButton BTN_DISABLED
End If
PropertyChanged "Enabled"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get TextColorEnabled() As Ole_Color
Attribute TextColorEnabled.VB_Description = "Color of text when its enabled."
Attribute TextColorEnabled.VB_ProcData.VB_Invoke_Property = ";Appearance"
TextColorEnabled = m_TextColorEnabled
End Property
Public Property Let TextColorEnabled(ByVal New_TextColorEnabled As Ole_Color)
m_TextColorEnabled = New_TextColorEnabled
Refresh
PropertyChanged "TextColorEnabled"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get TextColorDisabled() As Ole_Color
Attribute TextColorDisabled.VB_Description = "Color of text when button is disabled"
Attribute TextColorDisabled.VB_ProcData.VB_Invoke_Property = ";Appearance"
TextColorDisabled = m_TextColorDisabled
End Property
Public Property Let TextColorDisabled(ByVal New_TextColorDisabled As Ole_Color)
m_TextColorDisabled = New_TextColorDisabled
Refresh
PropertyChanged "TextColorDisabled"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_ProcData.VB_Invoke_Property = ";Font"
Attribute Font.VB_UserMemId = -512
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set UserControl.Font = New_Font
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontUnderline
Public Property Get FontUnderline() As Boolean
Attribute FontUnderline.VB_Description = "Returns/sets underline font styles."
Attribute FontUnderline.VB_ProcData.VB_Invoke_Property = ";Font"
FontUnderline = UserControl.FontUnderline
End Property
Public Property Let FontUnderline(ByVal New_FontUnderline As Boolean)
UserControl.FontUnderline() = New_FontUnderline
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontStrikethru
Public Property Get FontStrikethru() As Boolean
Attribute FontStrikethru.VB_Description = "Returns/sets strikethrough font styles."
Attribute FontStrikethru.VB_ProcData.VB_Invoke_Property = ";Font"
FontStrikethru = UserControl.FontStrikethru
End Property
Public Property Let FontStrikethru(ByVal New_FontStrikethru As Boolean)
UserControl.FontStrikethru() = New_FontStrikethru
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontSize
Public Property Get FontSize() As Single
Attribute FontSize.VB_Description = "Specifies the size (in points) of the font that appears in each row for the given level."
Attribute FontSize.VB_ProcData.VB_Invoke_Property = ";Font"
FontSize = UserControl.FontSize
End Property
Public Property Let FontSize(ByVal New_FontSize As Single)
UserControl.FontSize() = New_FontSize
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontName
Public Property Get FontName() As String
Attribute FontName.VB_Description = "Specifies the name of the font that appears in each row for the given level."
Attribute FontName.VB_ProcData.VB_Invoke_Property = ";Font"
FontName = UserControl.FontName
End Property
Public Property Let FontName(ByVal New_FontName As String)
UserControl.FontName() = New_FontName
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontItalic
Public Property Get FontItalic() As Boolean
Attribute FontItalic.VB_Description = "Returns/sets italic font styles."
Attribute FontItalic.VB_ProcData.VB_Invoke_Property = ";Font"
FontItalic = UserControl.FontItalic
End Property
Public Property Let FontItalic(ByVal New_FontItalic As Boolean)
UserControl.FontItalic() = New_FontItalic
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontBold
Public Property Get FontBold() As Boolean
Attribute FontBold.VB_Description = "Returns/sets bold font styles."
Attribute FontBold.VB_ProcData.VB_Invoke_Property = ";Font"
FontBold = UserControl.FontBold
End Property
Public Property Let FontBold(ByVal New_FontBold As Boolean)
UserControl.FontBold() = New_FontBold
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MousePointer
Public Property Get MousePointer() As MousePointerConstants
Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
MousePointer = UserControl.MousePointer
End Property
Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
UserControl.MousePointer() = New_MousePointer
PropertyChanged "MousePointer"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MouseIcon
Public Property Get MouseIcon() As Picture
Attribute MouseIcon.VB_Description = "Sets a custom mouse icon."
Set MouseIcon = UserControl.MouseIcon
End Property
Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
Set UserControl.MouseIcon = New_MouseIcon
PropertyChanged "MouseIcon"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,False
Public Property Get DisableHover() As Boolean
Attribute DisableHover.VB_ProcData.VB_Invoke_Property = ";Behavior"
DisableHover = m_DisableHover
End Property
Public Property Let DisableHover(ByVal New_DisableHover As Boolean)
m_DisableHover = New_DisableHover
PropertyChanged "DisableHover"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get DisplaceText() As Integer
Attribute DisplaceText.VB_Description = "Displaces text when button is down."
Attribute DisplaceText.VB_ProcData.VB_Invoke_Property = ";Behavior"
DisplaceText = m_DisplaceText
End Property
Public Property Let DisplaceText(ByVal New_DisplaceText As Integer)
m_DisplaceText = New_DisplaceText
PropertyChanged "DisplaceText"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get DrawFocus() As Integer
Attribute DrawFocus.VB_Description = "Draws focus."
Attribute DrawFocus.VB_ProcData.VB_Invoke_Property = ";Appearance"
DrawFocus = m_DrawFocus
End Property
Public Property Let DrawFocus(ByVal New_DrawFocus As Integer)
m_DrawFocus = New_DrawFocus
PropertyChanged "DrawFocus"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get TextColorDisabled2() As Ole_Color
Attribute TextColorDisabled2.VB_Description = "Color of text when button is disabled that make it looks grayed."
Attribute TextColorDisabled2.VB_ProcData.VB_Invoke_Property = ";Appearance"
TextColorDisabled2 = m_TextColorDisabled2
End Property
Public Property Let TextColorDisabled2(ByVal New_TextColorDisabled2 As Ole_Color)
m_TextColorDisabled2 = New_TextColorDisabled2
Refresh
PropertyChanged "TextColorDisabled2"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=11,0,0,0
Public Property Get Picture() As StdPicture
Attribute Picture.VB_ProcData.VB_Invoke_Property = ";Appearance"
Set Picture = m_Picture
End Property
Public Property Set Picture(ByVal New_Picture As StdPicture)
Set m_Picture = New_Picture
Refresh
PropertyChanged "Picture"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get PicturePos() As EnumPicturePos
Attribute PicturePos.VB_ProcData.VB_Invoke_Property = ";Appearance"
PicturePos = m_PicturePos
End Property
Public Property Let PicturePos(ByVal New_PicturePos As EnumPicturePos)
m_PicturePos = New_PicturePos
Refresh
PropertyChanged "PicturePos"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get PictureTColor() As Ole_Color
Attribute PictureTColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
PictureTColor = m_PictureTColor
End Property
Public Property Let PictureTColor(ByVal New_PictureTColor As Ole_Color)
m_PictureTColor = New_PictureTColor
Refresh
PropertyChanged "PictureTColor"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get TextAlign() As AlignmentConstants
Attribute TextAlign.VB_ProcData.VB_Invoke_Property = ";Appearance"
TextAlign = m_TextAlign
End Property
Public Property Let TextAlign(ByVal New_TextAlign As AlignmentConstants)
m_TextAlign = New_TextAlign
Refresh
PropertyChanged "TextAlign"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As Ole_Color
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
Attribute BackColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As Ole_Color)
UserControl.BackColor() = New_BackColor
Refresh
PropertyChanged "BackColor"
End Property