Sección de código fuente Visual basic

Código fuente de un Ocx para crear texto vertical

En esta página se lista el código fuente de este simple ocx para poder usar texto vertical

Como se ve en el gráfico, además del texto en forma vertical, dibuja un degradado para el fondo

El control tiene dos propiedades, además de las habituales, como el caprion, forecolor etc..., y se llaman ColorInicial y ColorFinal, que definen los colores para los degradados

Nota: El control compilado está en el siguiente enlace : ocx Text Vertical

Vista del control

vista previa del control ocx para crear el texto vertical con degradado

Pasos para crear el control

Iniciar un nuevo proyecto exe estandar
Desde el menú Archivo , seleccionar la opción " Agregar proyecto " y seleccionar control Activex , para de esta forma crear un grupo de proyectos
Ir al proyecto del control ocx, y en la propiedad autoredraw colocarle el valor True al Usercontrol
También en la propiedad FontName establecerle la fuente " Arial "

Importante : En el paso 3, si no se coloca la propiedad AutoRedraw, el control no visualizará nada al ejecutar el proyecto.

También importante, en el paso 4, la fuente en este caso se seleccionó la Arial ya que con lagunas no funciona, y el texto se ve en forma horizontal , por ejemplo utilizando la fuente Ms Sans Serif ocurre esto

Pegar el siguiente código fuente en la ventana de código del UserControl

Option Explicit ' Declaraciones api, estructuras y constantes '''''''''''''''''''''''''''''''''''''''''''''''''' Private Type RECT left As Long tOp As Long Right As Long Bottom As Long End Type Private Declare Function FillRect 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 TextOut Lib "gdi32" Alias "TextOutA" ( _ ByVal hDC As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal lpString As String, _ ByVal nCount As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal nIndex As Long) As Long Private Const LOGPIXELSX = 88 Private Const LOGPIXELSY = 90 Private Declare Function MulDiv Lib "kernel32" ( _ ByVal nNumber As Long, _ ByVal nNumerator As Long, _ ByVal nDenominator As Long) As Long Private Const LF_FACESIZE = 32 Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(LF_FACESIZE) As Byte End Type Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" ( _ lpLogFont As LOGFONT) As Long 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 Const FW_NORMAL = 400 Private Const FW_BOLD = 700 Private Const FF_DONTCARE = 0 Private Const DEFAULT_QUALITY = 0 Private Const DEFAULT_PITCH = 0 Private Const DEFAULT_CHARSET = 1 Private Const CLR_INVALID = -1 Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" ( _ ByVal OLE_COLOR As Long, _ ByVal HPALETTE As Long, _ pccolorref As Long) As Long ' variables locales '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private m_Caption As String Private m_bRGBStart(1 To 3) As Integer Private m_ColorInicial As OLE_COLOR Private m_bRGBEnd(1 To 3) As Integer Private m_ColorFinal As OLE_COLOR 'Propiedades por default '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Const m_def_Caption = "" Const m_def_ColorInicial = &H800000 Const m_def_ColorFinal = &HFFC0C0 'Property Variables ' Declaraciones de eventos del UserControl '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Event Click() Event DblClick() 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) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'subrutina que dibuja en el control ocx el texto vertical y el degradado '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub Dibujar() Dim lHeight As Long, lWidth As Long Dim lYStep As Long Dim lY As Long Dim bRGB(1 To 3) As Integer Dim tLF As LOGFONT Dim hFnt As Long Dim hFntOld As Long Dim lR As Long Dim rct As RECT Dim hBr As Long Dim hDC As Long Dim dR(1 To 3) As Double On Error GoTo ErrSub hDC = UserControl.hDC lHeight = UserControl.Height \ Screen.TwipsPerPixelY rct.Right = UserControl.Width \ Screen.TwipsPerPixelY lYStep = lHeight \ 255 If (lYStep = 0) Then lYStep = 1 End If rct.Bottom = lHeight bRGB(1) = m_bRGBStart(1) bRGB(2) = m_bRGBStart(2) bRGB(3) = m_bRGBStart(3) dR(1) = m_bRGBEnd(1) - m_bRGBStart(1) dR(2) = m_bRGBEnd(2) - m_bRGBStart(2) dR(3) = m_bRGBEnd(3) - m_bRGBStart(3) ' Esto dibuja el degradado en el usercontrol For lY = lHeight To 0 Step -lYStep rct.tOp = rct.Bottom - lYStep hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1))) FillRect hDC, rct, hBr DeleteObject hBr rct.Bottom = rct.tOp bRGB(1) = m_bRGBStart(1) + dR(1) * (lHeight - lY) / lHeight bRGB(2) = m_bRGBStart(2) + dR(2) * (lHeight - lY) / lHeight bRGB(3) = m_bRGBStart(3) + dR(3) * (lHeight - lY) / lHeight Next lY ' Esto es para la fuente pOLEFontToLogFont UserControl.Font, hDC, tLF tLF.lfEscapement = 900 hFnt = CreateFontIndirect(tLF) If (hFnt <> 0) Then hFntOld = SelectObject(hDC, hFnt) lR = TextOut(hDC, 0, lHeight - 16, m_Caption, Len(m_Caption)) SelectObject hDC, hFntOld DeleteObject hFnt End If UserControl.Refresh Exit Sub ErrSub: End Sub ' Propiedades de la fuente '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT) Dim sFont As String Dim iChar As Integer ' Convert an OLE StdFont to a LOGFONT structure: With tLF sFont = fntThis.Name ' There is a quicker way involving StrConv and CopyMemory, but ' this is simpler!: For iChar = 1 To Len(sFont) .lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1))) Next iChar ' Based on the Win32SDK documentation: .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 End With End Sub ' Eventos privados del usercontrol '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub UserControl_InitProperties() m_Caption = UserControl.Extender.Name ColorInicial = m_def_ColorInicial ColorFinal = m_def_ColorFinal m_ColorInicial = m_def_ColorInicial m_ColorFinal = m_def_ColorFinal UserControl.FontBold = True UserControl.FontSize = 12 UserControl.ForeColor = &H80FFFF Dibujar End Sub 'cada ves que se redimensiona se vuelve a _ dibujar el texto vertical y el degradado Private Sub UserControl_Resize() Dibujar End Sub ' Cuando se muestra el control se asignan los colores _ y se dibuja Private Sub UserControl_Show() ColorInicial = m_ColorInicial ColorFinal = m_ColorFinal Dibujar End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) With UserControl .ForeColor = PropBag.ReadProperty("ForeColor", &HC0FFFF) .FontUnderline = PropBag.ReadProperty("FontUnderline", False) .FontSize = PropBag.ReadProperty("FontSize", 12) .FontItalic = PropBag.ReadProperty("FontItalic", False) .FontBold = PropBag.ReadProperty("FontBold", True) .FontStrikethru = PropBag.ReadProperty("FontStrikethru", 0) Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing) .MousePointer = PropBag.ReadProperty("MousePointer", 0) m_Caption = PropBag.ReadProperty("Caption", m_def_Caption) m_ColorInicial = PropBag.ReadProperty("ColorInicial", m_def_ColorInicial) m_ColorFinal = PropBag.ReadProperty("ColorFinal", m_def_ColorFinal) End With End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &HC0FFFF) Call PropBag.WriteProperty("FontUnderline", UserControl.FontUnderline, False) Call PropBag.WriteProperty("FontSize", UserControl.FontSize, 12) Call PropBag.WriteProperty("FontItalic", UserControl.FontItalic, False) Call PropBag.WriteProperty("FontBold", UserControl.FontBold, True) Call PropBag.WriteProperty("FontStrikethru", UserControl.FontStrikethru, False) Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing) Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0) Call PropBag.WriteProperty("Caption", m_Caption, m_def_Caption) Call PropBag.WriteProperty("ColorInicial", m_ColorInicial, m_def_ColorInicial) Call PropBag.WriteProperty("ColorFinal", m_ColorFinal, m_def_ColorFinal) End Sub ' Propiedades del Usercontrol '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Property Get ForeColor() As OLE_COLOR ForeColor = UserControl.ForeColor End Property Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR) UserControl.ForeColor() = New_ForeColor PropertyChanged "ForeColor" Dibujar End Property Public Property Get FontUnderline() As Boolean FontUnderline = UserControl.FontUnderline End Property Public Property Let FontUnderline(ByVal New_FontUnderline As Boolean) UserControl.FontUnderline() = New_FontUnderline PropertyChanged "FontUnderline" Dibujar End Property Public Property Get FontSize() As Single FontSize = UserControl.FontSize End Property Public Property Let FontSize(ByVal New_FontSize As Single) UserControl.FontSize() = New_FontSize PropertyChanged "FontSize" Dibujar End Property Public Property Get FontItalic() As Boolean FontItalic = UserControl.FontItalic End Property Public Property Let FontItalic(ByVal New_FontItalic As Boolean) UserControl.FontItalic() = New_FontItalic PropertyChanged "FontItalic" Dibujar End Property Public Property Get FontBold() As Boolean FontBold = UserControl.FontBold End Property Public Property Let FontBold(ByVal New_FontBold As Boolean) UserControl.FontBold() = New_FontBold PropertyChanged "FontBold" Dibujar End Property Public Property Get FontStrikethru() As Boolean FontStrikethru = UserControl.FontStrikethru End Property Public Property Let FontStrikethru(ByVal New_FontStrikethru As Boolean) UserControl.FontStrikethru() = New_FontStrikethru PropertyChanged "FontStrikethru" Dibujar End Property Public Property Get MouseIcon() As Picture Set MouseIcon = UserControl.MouseIcon End Property Public Property Set MouseIcon(ByVal New_MouseIcon As Picture) Set UserControl.MouseIcon = New_MouseIcon PropertyChanged "MouseIcon" End Property Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) RaiseEvent MouseMove(Button, Shift, X, Y) End Sub Public Property Get MousePointer() As Integer MousePointer = UserControl.MousePointer End Property Public Property Let MousePointer(ByVal New_MousePointer As Integer) UserControl.MousePointer() = New_MousePointer PropertyChanged "MousePointer" End Property Public Sub Refresh() Dibujar End Sub Public Property Get Caption() As String Caption = m_Caption End Property Public Property Let Caption(ByVal New_Caption As String) m_Caption = New_Caption PropertyChanged "Caption" Dibujar End Property ' Propiedades para los colores ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Property Get ColorInicial() As OLE_COLOR ColorInicial = m_ColorInicial PropertyChanged "ColorInicial" End Property Public Property Let ColorInicial(ByVal value_color As OLE_COLOR) Dim ret_color As Long m_ColorInicial = value_color Call OleTranslateColor(value_color, 0, ret_color) m_bRGBStart(1) = ret_color And &HFF& m_bRGBStart(2) = ((ret_color And &HFF00&) \ &H100) m_bRGBStart(3) = ((ret_color And &HFF0000) \ &H10000) ' Dibuja el texto y el degradado Call Dibujar End Property Public Property Get ColorFinal() As OLE_COLOR ColorFinal = m_ColorFinal PropertyChanged "ColorFinal" End Property Public Property Let ColorFinal(ByVal value_color As OLE_COLOR) Dim ret_color As Long Dim ret As Long m_ColorFinal = value_color ret = OleTranslateColor(value_color, 0, ret_color) m_bRGBEnd(1) = ret_color And &HFF& m_bRGBEnd(2) = ((ret_color And &HFF00&) \ &H100) m_bRGBEnd(3) = ((ret_color And &HFF0000) \ &H10000) ' Dibuja el texto y el degradado Call Dibujar End Property 'eventos del ocx ''''''''''''''''''''' Private Sub UserControl_Click() RaiseEvent Click End Sub Private Sub UserControl_DblClick() RaiseEvent DblClick 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_MouseUp(Button As Integer, _ Shift As Integer, X As Single, Y As Single) RaiseEvent MouseUp(Button, Shift, X, Y) End Sub

Buscar en Recursos vb