Sección de controles Ocx para Visual basic , Dll , Activex

69 - Ocx - Command Button para establecer el color de la fuente

Contenido:

Ejemplo 1
Ejemplo 2
Relacionados

Ejemplo 1

Este ocx es un CommandButton común y corriente pero que permite cambiar el color de la fuente.

Nota: al cambiar el color en tiempo de diseño al botón , esta no se visualiza, solo cuando está en tiempo de ejecución. Le tuve que eliminar esa opción por que la barra de título del IDE del vb parpadeaba un poco al hacer un MouseMove y redimensionar el botón en tiempo de diseño

Descargar

Ejemplo 2

Control Open Source

Código fuente de un Simple Activex Open Source para usar CommandButton al cual se le puede establecer y cambiar el color de la fuente :

El control ya compilado :

Descargar

El Código fuente del control :

Colocar el Código fuente dentro de un control de usuario :

'    This library is free software; you can redistribute it and/or modify it under the terms _
     of the GNU Lesser General Public License as published by the Free Software Foundation; _
     either version 2.1 of the License, or (at your option) any later version.
'    This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; _
     without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. _
     See the GNU Lesser General Public License for more details.
'    You should have received a copy of the GNU Lesser General Public License along with this _
     library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth _
     Floor, Boston, MA  02110-1301  USA.

Option Explicit

' ** API **

' used by: DrawEdge
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8

Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)

Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_SOFT = &H1000

' used by: DrawState
Private Const DST_PREFIXTEXT = &H2

Private Const DSS_NORMAL = &H0
Private Const DSS_DISABLED = &H20

' used by: DrawEdge
Private Type TRectangle
    lngLeft As Long
    lngTop As Long
    lngRight As Long
    lngBottom As Long
End Type

' used by: GetTextExtentPoint32
Private Type TPoint
    lngX As Long
    lngY As Long
End Type

Private Declare Function DrawEdge Lib "user32" ( _
    ByVal hDC As Long, _
    qrc As TRectangle, _
    ByVal Edge As Long, _
    ByVal grfFlags As Long) As Boolean
Private Declare Function DrawState Lib "user32" Alias "DrawStateA" ( _
    ByVal hDC As Long, _
    ByVal hBrush As Long, _
    ByVal lpDrawStateProc As Long, _
    ByVal lParam As String, _
    ByVal wParam As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal n3 As Long, _
    ByVal n4 As Long, _
    ByVal un As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
    ByVal hDC As Long, _
    ByVal lpsz As String, _
    ByVal cbString As Long, _
    lpSize As TPoint) As Long

' ** USERCONTROL **

Private Enum EBorderStyle
    btnBorderUp = 0
    btnBorderDown = 1
End Enum

Private mstrCaption As String
Private mintBorderStyle As Integer

Event Click()
Event MouseDown(intButton As Integer, intShift As Integer, sngX As Single, sngY As Single)
Event MouseMove(intButton As Integer, intShift As Integer, sngX As Single, sngY As Single)
Event MouseUp(intButton As Integer, intShift As Integer, sngX As Single, sngY As Single)

' ** PROPERTIES **

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

Public Property Let BackColor(ByVal lngBackColor As OLE_COLOR)
    UserControl.BackColor = lngBackColor
    PropertyChanged "BackColor"
    Refresh
End Property

Public Property Get Caption() As String
    Caption = mstrCaption
End Property

Public Property Let Caption(ByVal strCaption As String)
    mstrCaption = strCaption
    PropertyChanged "Caption"
    Refresh
End Property

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

Public Property Let Enabled(ByVal blnEnabled As Boolean)
    UserControl.Enabled = blnEnabled
    PropertyChanged "Enabled"
    Refresh
End Property

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

Public Property Set Font(ByVal objFont As Font)
    Set UserControl.Font = objFont
    PropertyChanged "Font"
    Refresh
End Property

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

Public Property Let ForeColor(ByVal lngForeColor As OLE_COLOR)
    UserControl.ForeColor = lngForeColor
    PropertyChanged "ForeColor"
    Refresh
End Property

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

' ** EVENTS **

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    mintBorderStyle = EBorderStyle.btnBorderDown
    Refresh
    RaiseEvent Click
End Sub

Private Sub UserControl_Initialize()
    mintBorderStyle = EBorderStyle.btnBorderUp
End Sub

Private Sub UserControl_InitProperties()
    
    ' get custom properties
    mstrCaption = Ambient.DisplayName
    
    ' get default properties
    UserControl.Width = 1715
    UserControl.Height = 495
    UserControl.BackColor = Ambient.BackColor
    Set UserControl.Font = Ambient.Font
    UserControl.ForeColor = Ambient.ForeColor
    
End Sub

Private Sub UserControl_MouseDown(intButton As Integer, _
                                  intShift As Integer, _
                                  sngX As Single, _
                                  sngY As Single)
    mintBorderStyle = EBorderStyle.btnBorderDown
    Refresh
    RaiseEvent MouseDown(intButton, intShift, sngX, sngY)
End Sub

Private Sub UserControl_MouseMove(intButton As Integer, _
                                  intShift As Integer, _
                                  sngX As Single, _
                                  sngY As Single)
    RaiseEvent MouseMove(intButton, intShift, sngX, sngY)
End Sub

Private Sub UserControl_MouseUp(intButton As Integer, _
                                intShift As Integer, _
                                sngX As Single, _
                                sngY As Single)
    mintBorderStyle = EBorderStyle.btnBorderUp
    Refresh
    RaiseEvent MouseUp(intButton, intShift, sngX, sngY)
End Sub

Private Sub UserControl_Paint()
    Draw
End Sub

Private Sub UserControl_ReadProperties(objBag As PropertyBag)
    
    ' get custom properties
    mstrCaption = objBag.ReadProperty("Caption", Ambient.DisplayName)
    
    ' get default properties
    UserControl.BackColor = objBag.ReadProperty("BackColor", Ambient.BackColor)
    UserControl.Enabled = objBag.ReadProperty("Enabled", True)
    Set UserControl.Font = objBag.ReadProperty("Font", Ambient.Font)
    UserControl.ForeColor = objBag.ReadProperty("ForeColor", Ambient.ForeColor)
    
End Sub

Private Sub UserControl_Resize()
    Refresh
End Sub

Private Sub UserControl_WriteProperties(objBag As PropertyBag)
    
    ' set custom properties
    objBag.WriteProperty "Caption", mstrCaption, Ambient.DisplayName
    
    ' set default properties
    objBag.WriteProperty "BackColor", UserControl.BackColor, Ambient.BackColor
    objBag.WriteProperty "Enabled", UserControl.Enabled, True
    objBag.WriteProperty "Font", UserControl.Font, Ambient.Font
    objBag.WriteProperty "ForeColor", UserControl.ForeColor, Ambient.ForeColor
    
End Sub

' ** SUBROUTINES **

Private Sub Draw()
    Dim udtRectangle As TRectangle
    Dim udtPoint As TPoint
    Dim lngEdge As Long
    Dim lngState As Long
    
    UserControl.Cls
    udtRectangle.lngLeft = UserControl.ScaleLeft / Screen.TwipsPerPixelX
    udtRectangle.lngTop = UserControl.ScaleTop / Screen.TwipsPerPixelY
    udtRectangle.lngRight = UserControl.ScaleWidth / Screen.TwipsPerPixelX
    udtRectangle.lngBottom = UserControl.ScaleHeight / Screen.TwipsPerPixelY
    
    ' set caption size
    GetTextExtentPoint32 UserControl.hDC, mstrCaption, Len(mstrCaption), udtPoint
    
    ' set caption position
    ' set edge
    If mintBorderStyle = EBorderStyle.btnBorderUp Then
        lngEdge = EDGE_RAISED
        udtPoint.lngX = (udtRectangle.lngRight - udtPoint.lngX) / 2
        udtPoint.lngY = (udtRectangle.lngBottom - udtPoint.lngY) / 2
    Else
        lngEdge = EDGE_SUNKEN
        udtPoint.lngX = ((udtRectangle.lngRight - udtPoint.lngX) / 2) + 1
        udtPoint.lngY = ((udtRectangle.lngBottom - udtPoint.lngY) / 2) + 1
    End If
    
    ' draw edge
    DrawEdge UserControl.hDC, udtRectangle, lngEdge, BF_RECT Or BF_SOFT
    
    ' set state
    If UserControl.Enabled = True Then
        lngState = DSS_NORMAL
    Else
        lngState = DSS_DISABLED
    End If
    
    ' draw state
    DrawState UserControl.hDC, 0&, 0&, ByVal mstrCaption, _
              Len(mstrCaption), udtPoint.lngX, udtPoint.lngY, _
              0&, 0&, DST_PREFIXTEXT Or lngState
    
End Sub

Relacionados

Página con ejemplos relacionados a botones

Buscar en Recursos vb con Google