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

211 - Dibujar texto con formato

Módulo de clase y ejemplo para dibujar texto con formato en vb6

Ejemplo para visual basic 6.0 que usa un módulo para poder dibujar en objetos picturebox, formularios, y en el objeto printer , texto con la posibilidad de aplicar formato mediante una serie de métodos, y algunas otras opciones como por ejemplo imágenes

Para usar el módulo previamente se debe crear una instancia del mismo y luego indicar si se quiere, las propiedades para el texto general, por ejemplo el tamaño de fuente, el margen en pixeles, el espaciado vertical también en pixeles para cada linea

Set cText = New clstextformat With cText ' fuente .Font.Size = "Arial" .Font.Size = 12 .Margin = 50 ' 50 pixeles End With

Luego para poder añadir texto se debe añadir con el método AddText.

Este método tiene como parámetro obligatorio el texto que se va a agregar, y como argumentos opcionales las propiedades de la fuente, el backcolor del texto, etc.

Nota: El formato indicado en este parámetro solo afecta al texto actual , y si no se indican los atributos, se utilizarán las propiedades indicadas anteriormente

por ejemplo :

.AddText "Un texto", "Verdana", 8, vbRed

También tiene una función para añadir párrafos. En este método se puede indicar la alineación del texto para todas las lineas siguientes, hasta que se vuelva a añadir otro párrafo

' Añadir párrafo centrado .AddParagraph ecenter ' añadir texto .AddText "Un texto", "Verdana", 8, vbRed ' Otro párrafo a la izquierda .AddParagraph eleft ' añadir otro texto .AddText "Un texto"

Para poder añadir un salto de linea, se puede indicar en el momento de añadir texto, con la constante de visual basic vbNewLine o vbCrLF. O también mediante el método AddNewLine

Para agregar imágenes y gráficos, se debe indicar en la función AddPicture, la ruta del gráfico. (Debe ser un gráfico válido soportado por vb)

' Párrafo centrado .AddParagraph ecenter ' la imagen quedará centrada .AddPicture App.Path & "\imagen.jpg"

Para poder dibujar una linea con el método DrawLine

.DrawLine "Color de la linea", "estilo de la linea","Grosor de la linea"

Luego para mandar todo el dibujo a un objeto Printer, Formulario o Picture, se debe pasar al método Draw el objeto :

' form Call .Draw(Me) 'picBox Call .Draw(Picture1) ' impresora Call .Draw(Printer)

Nota: para eliminar todo los elementos , Lineas, párrafos , imágenes , texto etc.. , ejecutar el método Clear antes de volver a dibujar para que no lo agregue al final.

Ejemplos

En el siguiente Zip hay un proyecto con tres formularios de ejemplo :

El primer formulario dibuja un texto en un objeto form y tiene 3 combos para indicar el margen, el espaciado vertical y la alineación de los párrafos

vista previa del ejemplo 1

El segundo formulario muestra como añadir imagenes y también hacer una vista previa ( simple ) mediante un PictureBox con scrollBar.

Y el tercer formulario es para poder imprimir los datos desde una base de datos, también incluyendo imágenes , y puede ser útil para realizar catálogos, listados , informes y reportes simples

Eventos.

La clase tiene 4 eventos

Progress.

Este evento sirve para obtener el progreso mientras se dibuja en el objeto . Es útil para cuando se va a dibujar mucho contenido y puede tardar un poco , y de este modo poder mostrar en una barra de progreso o en un control label el valor actual

StartDraw : Este método se dispara antes de comenzar a dibujar todo el texto en un picturebox o formulario , no se dispara cuando se usa con el objeto Printer.

Con el parámetro lHeight del evento, se puede obtener el alto que se necesita para el área de dibujo, es útil si se va a utilizar con barras de scroll y poder asignar el nuevo alto al control para poder visualizar el contenido. El valor está medido en Pixeles

StartPrint : Este evento se dispara cuando se pasa al método Draw un objeto Printer. Tiene dos parámetros: La cantidad de hojas necesesarias para la impresión, y un valor de tipo Boolean para poder Cancelar con KillDoc la impresión. Si no se cancela, se manda a imprimir con el método endDoc

Importante : Este tema de la impresión no está muy testeado, y seguramente el código fuente puede tener errores y fallos

Descargar

Código fuente del módulo de clase

Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Descripción: Módulo para dibujar texto con formato ' Autor : Leandro Ascierto , Luciano Lodola ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Declaraciones, tipos, funciones Api, constantes ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Const DT_LEFT As Long = &H0 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI x As Long Y As Long End Type Enum eAlign [eleft] = 0 [ecenter] = 1 [eRight] = 2 End Enum Enum eObject [eNewLine] = 0 [ePicture] = 1 [eText] = 2 [eLine] = 3 End Enum Private Type tDataDrawText lMaxHeightFont As Long lMaxAscentFont As Long lWidthText As Long lDesent As Long End Type Private Type tLineStyle lDrawWidth As Long lDrawStyle As DrawStyleConstants End Type Private Type tObjects oFont As New StdFont lForeColor As Variant sText As String bSaltoDeLinea As Boolean lBackColor As Variant bLine As tLineStyle Picture As StdPicture Align As eAlign TypeObject As eObject End Type Private Type tLineas lMaxHeightFont As Long lMaxAscentFont As Long lWidhtLine As Long End Type Private Type TEXTMETRIC tmHeight As Long tmAscent As Long tmDescent As Long tmInternalLeading As Long tmExternalLeading As Long tmAveCharWidth As Long tmMaxCharWidth As Long tmWeight As Long tmOverhang As Long tmDigitizedAspectX As Long tmDigitizedAspectY As Long tmFirstChar As Byte tmLastChar As Byte tmDefaultChar As Byte tmBreakChar As Byte tmItalic As Byte tmUnderlined As Byte tmStruckOut As Byte tmPitchAndFamily As Byte tmCharSet As Byte End Type Private Declare Function GetTextExtentPoint32 _ Lib "gdi32" _ Alias "GetTextExtentPoint32A" ( _ ByVal hdc As Long, _ ByVal lpsz As String, _ ByVal cbString As Long, _ lpSize As POINTAPI) 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 GetTextMetrics _ Lib "gdi32" _ Alias "GetTextMetricsA" ( _ ByVal hdc As Long, _ lpMetrics As TEXTMETRIC) As Long Private Declare Function SetRect _ Lib "user32" ( _ lpRect As RECT, _ ByVal x1 As Long, _ ByVal y1 As Long, _ ByVal x2 As Long, _ ByVal y2 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 ' Variables '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private arrLineas() As tLineas Private arrTexts() As tObjects Private arrObjects() As tObjects Private DataDrawText As tDataDrawText Private mAlignText As eAlign Private mLine As tLineStyle Private mFont As New StdFont Private mMargin As Long Private mSpacingLine As Long Private mForeColor As Long Private mBackColor As Variant Private mObj As Object Private mTop As Long ' valores por default Private mDefFontSize As Integer Private mDefFontName As String ' Eventos '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Event Progress(ByVal PercentValue As Long) Event StartPrint(ByVal totalPages As Integer, ByRef Cancel As Boolean) Event Error(sErrorMessage As String, ByVal lNumError As Long) Event EndDraw(ByVal lHeight As Long) Event StartDraw(ByVal lHeight As Long) ' Función para dibujar el texto '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub Draw(Objeto As Object) On Local Error GoTo error_Sub Set mObj = Objeto Dim lNumPages As Long Dim oldScale As Integer With mObj ' guardar y cambiar el modo de escala a pixeles oldScale = .ScaleMode .ScaleMode = vbPixels ' si no es el objeto printer, establecer el AutoRedraw If (TypeOf mObj Is PictureBox) Or _ (TypeOf mObj Is Form) Or _ (TypeOf mObj Is UserControl) Then .AutoRedraw = True ElseIf (TypeOf mObj Is Printer) Then lNumPages = 1 ' Inicializar la cantidad de páginas mObj.Print "" End If End With ' Preparar las lineas ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim lWidthLine As Long Dim j As Long Dim i As Long Dim lTotalHeight As Long ReDim arrLineas(0) ' Inicializar el array que contendrá las lineas Screen.MousePointer = vbHourglass For i = 1 To UBound(arrObjects) ' Calculas valores y datos de la fuente para la palabra actual Call calcFont(arrObjects(i)) With DataDrawText ' Comprobar que la linea no se pase en ancho If ((lWidthLine + .lWidthText + mMargin) >= (mObj.ScaleWidth)) Or _ (arrObjects(i).bSaltoDeLinea = True) Then ' Crear nueva linea j = UBound(arrLineas) + 1 ReDim Preserve arrLineas(j) ' Guardar los valores máximos ( alto de fuente y el Ascent ) arrLineas(j).lMaxHeightFont = .lMaxHeightFont arrLineas(j).lMaxAscentFont = .lMaxAscentFont ' flag para el salto de linea para el otro bucle arrObjects(i).bSaltoDeLinea = True ' Guardar el ancho de la linea actual lWidthLine = .lWidthText Else ' Comprobar si hay nuevos valores máximos para el Ascent y el alto de la fuente If arrLineas(j).lMaxAscentFont < .lMaxAscentFont Then arrLineas(j).lMaxAscentFont = .lMaxAscentFont End If If arrLineas(j).lMaxHeightFont < .lMaxHeightFont Then arrLineas(j).lMaxHeightFont = .lMaxHeightFont End If lWidthLine = lWidthLine + .lWidthText End If ' ancho de linea arrLineas(j).lWidhtLine = lWidthLine End With Next For i = LBound(arrLineas) To UBound(arrLineas) lTotalHeight = lTotalHeight + arrLineas(i).lMaxHeightFont + mSpacingLine Next ' Alto total del dibujo RaiseEvent StartDraw(lTotalHeight + mTop) ' Dibujar en el HDC ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim x1 As Long Dim x2 As Long Dim y1 As Long Dim y2 As Long Dim lposy As Long Dim lInicio As Long Dim mAlign As eAlign Dim lFin As Long Dim r As RECT lFin = UBound(arrObjects) lInicio = 1 lposy = mTop ' valor inicial de la posición top donde comenzar a dibujar ' recorrer todas las lineas For j = 0 To UBound(arrLineas) ' recorrer todos los objetos a dibujar For i = lInicio To lFin ' Si es una nueva linea, resetear la cordenada x If arrObjects(i).bSaltoDeLinea And i <> lInicio Then lInicio = i x1 = 0 Exit For End If ' Recuperar datos de la fuente Call calcFont(arrObjects(i)) ' Obtener alineación del texto o de la imagen mAlign = arrObjects(i).Align ' Calcular la posición x1 y x2 ( Left y ancho ) de acuerdo a la alineación Select Case mAlign Case ecenter If x1 = 0 Then x1 = ((mObj.ScaleWidth - arrLineas(j).lWidhtLine) / 2) x2 = x1 + DataDrawText.lWidthText + x1 Case eRight If x1 = 0 Then x1 = ((mObj.ScaleWidth) - (arrLineas(j).lWidhtLine)) - (mMargin / 2) x2 = x1 + DataDrawText.lWidthText Case eleft If x1 = 0 Then x1 = mMargin / 2 x2 = x1 + DataDrawText.lWidthText End Select ' calcular la posición del y1 y el y2 para el rectángulo del dibujo y1 = (arrLineas(j).lMaxAscentFont - DataDrawText.lMaxAscentFont) + lposy y2 = (arrLineas(j).lMaxHeightFont) + lposy ' .. Si es la impresora If TypeOf mObj Is Printer Then ' ... comprobar el Current Y If (lposy + (arrLineas(j).lMaxHeightFont) + 10) >= (mObj.ScaleHeight) Then ' resetear los valores lposy = 0 y1 = (arrLineas(j).lMaxAscentFont - DataDrawText.lMaxAscentFont) y2 = (arrLineas(j).lMaxHeightFont) ' incrementar número de página lNumPages = lNumPages + 1 mObj.NewPage ' Agregar una nueva página mObj.Print "" End If End If ' Establecer en r, el rectángulo para usar con Drawtext Call SetRect(r, x1, y1, x2, y2) ' Para el Resalte del texto If Not IsEmpty(arrObjects(i).lBackColor) Then Dim RecBrush As RECT, hBrush As Long ' valores del rectángulo With RecBrush .Bottom = r.Bottom .Left = r.Left .Top = lposy .Right = x1 + DataDrawText.lWidthText ' ancho de la palabra End With ' Crear el rectángulo de color hBrush = CreateSolidBrush(arrObjects(i).lBackColor) ' aplicarlo Call FillRect(mObj.hdc, RecBrush, hBrush) Call DeleteObject(hBrush) End If Select Case arrObjects(i).TypeObject ' linea Case eLine With mObj .ForeColor = arrObjects(i).lForeColor .DrawStyle = arrObjects(i).bLine.lDrawStyle .DrawWidth = arrObjects(i).bLine.lDrawWidth End With mObj.Line (x1, y1)-(mObj.ScaleWidth - x1, y1), arrObjects(i).lForeColor ' imagen Case ePicture mObj.PaintPicture arrObjects(i).Picture, r.Left, r.Top ' texto o nueva linea Case Else mObj.ForeColor = arrObjects(i).lForeColor Call DrawText(mObj.hdc, arrObjects(i).sText, Len(arrObjects(i).sText), r, DT_LEFT) End Select ' si es una linea, resetear la posición x If (arrObjects(i).sText = "") Or _ (arrObjects(i).TypeObject = eLine) Then x1 = 0 Else x1 = x1 + DataDrawText.lWidthText End If Next ' Obtener la cordenada Y ( Pos y, Alto de la fuente, El espaciado vertical ) lposy = lposy + arrLineas(j).lMaxHeightFont + mSpacingLine x1 = 0 ' Enviar eevento con el progreso DoEvents If UBound(arrLineas) <> 0 Then RaiseEvent Progress(CInt((j / UBound(arrLineas)) * 100)) End If Next ' .. si es la impresora If (TypeOf mObj Is Printer) And UBound(arrLineas) <> 0 Then Dim Cancel As Boolean ' antes de imprimir, enviar la cantidad de páginas y un flag para cancelar la impresión RaiseEvent StartPrint(lNumPages, Cancel) If Cancel Then mObj.KillDoc ' cancelar el trabajo Else mObj.EndDoc ' Enviar documento la la impresora End If ' refrescar la ventana ( Si es un Picture, Formulario o control de usuario ) ElseIf (TypeOf mObj Is PictureBox) Or _ (TypeOf mObj Is Form) Or _ (TypeOf mObj Is UserControl) Then mObj.Refresh End If RaiseEvent EndDraw(lposy) ' restaurar la escala del objeto mObj.ScaleMode = oldScale Set mObj = Nothing Screen.MousePointer = 0 Exit Sub error_Sub: MsgBox Err.Description, vbCritical, "Número de error: " & CStr(Err.Number) RaiseEvent Error(Err.Description, Err.Number) Screen.MousePointer = 0 End Sub ' borrar todo el texto y elementos agregados _ y establecer valores por defecto para la fuente y las lineas '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub Clear() ReDim arrObjects(0) mBackColor = Empty mForeColor = 0 mAlignText = eleft mSpacingLine = 4 mMargin = 10 With mFont .Name = mDefFontName .Size = mDefFontSize End With With mLine .lDrawStyle = vbSolid .lDrawWidth = 1 End With Call AddText(" ") End Sub ' Agregar un nuevo salto de linea '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub AddNewLine() Call setObject("", eNewLine) End Sub ' Agregar una nueva imagen '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub AddPicture(sPathPicture As String) On Error Resume Next Dim img As StdPicture Set img = LoadPicture(sPathPicture) ' comprobar que se puede leer la imagen y que el gráfico es válido If Err.Number = 0 Then Set img = Nothing Call setObject(sPathPicture, ePicture) 'psarle el path y el tipo Else MsgBox "No se pudo cargar la imagen: " & sPathPicture, vbCritical, "Error" End If End Sub ' Agregar una nueva Linea para dibujar Sub DrawLine( _ ByVal ColorLine As Long, _ Optional ByVal StyleLine As DrawStyleConstants, _ Optional ByVal DrawWidth As Long) If UBound(arrObjects) <> 0 Then AddNewLine ' salto de linea ' propiedades With mLine .lDrawStyle = StyleLine If DrawWidth <= 0 Then .lDrawWidth = 1 Else .lDrawWidth = DrawWidth End If End With ' añadir Call setObject(ColorLine, eLine) ' otro salto de linea AddNewLine End If End Sub ' Agregar dos lineas Sub AddParagraph(AlignmentText As eAlign) If UBound(arrObjects) <> 0 Then Call setObject("", eNewLine) Call setObject("", eNewLine) End If ' guardar la alineación hasta que no se vuslva a agregar otro parrafo mAlignText = AlignmentText End Sub ' Agregar nuevo texto Sub AddText( _ sText As String, _ Optional ByVal FontName As Variant, _ Optional ByVal FontSize As Variant, _ Optional ByVal ForeColor As Variant, _ Optional ByVal BackColor As Variant, _ Optional ByVal Italic As Variant, _ Optional ByVal Bold As Variant, _ Optional ByVal UnderLine As Variant, _ Optional ByVal Strikethru As Variant) On Error GoTo error_Sub ' Almacenar en un temporal los valores de la fuente Dim tForeColor As Long Dim tBackColor As Variant tForeColor = mForeColor tBackColor = mBackColor Dim tempFont As StdFont Set tempFont = New StdFont With tempFont .Name = mFont.Name .Bold = mFont.Bold .UnderLine = mFont.UnderLine .Strikethrough = mFont.Strikethrough .Italic = mFont.Italic .Size = mFont.Size End With ' Cambiar la fuente With mFont If Not IsMissing(FontName) Then .Name = FontName If Not IsMissing(FontSize) Then .Size = FontSize If Not IsMissing(ForeColor) Then mForeColor = ForeColor If Not IsMissing(BackColor) Then mBackColor = BackColor If Not IsMissing(Bold) Then .Bold = Bold If Not IsMissing(Strikethru) Then .Strikethrough = Strikethru If Not IsMissing(UnderLine) Then .UnderLine = UnderLine If Not IsMissing(Italic) Then .Italic = Italic End With ' Agregar el texto Call mAddText(sText) ' Restaurar los valores mForeColor = tForeColor mBackColor = tBackColor Set mFont = tempFont Set tempFont = Nothing Exit Sub error_Sub: RaiseEvent Error(Err.Description, Err.Number) End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' // Funciones privadas ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Sub que calcula los valores de la fuente ( El alto y otros valores ) Private Sub calcFont(ByRef pArrObject As tObjects) On Error GoTo error_Sub Dim ImgWidth As Long Dim ImgHeight As Long Dim tm As TEXTMETRIC Dim TextSize As POINTAPI ' Establecer la fuente Set mObj.Font = pArrObject.oFont ' Recuperar los datos de la fuente Call GetTextMetrics(mObj.hdc, tm) Call GetTextExtentPoint32(mObj.hdc, pArrObject.sText, Len(pArrObject.sText), TextSize) With DataDrawText .lMaxAscentFont = tm.tmAscent .lMaxHeightFont = TextSize.Y .lWidthText = TextSize.x .lDesent = tm.tmDescent End With If DataDrawText.lDesent < tm.tmDescent Then DataDrawText.lDesent = tm.tmDescent End If If pArrObject.TypeObject = ePicture Then If Not pArrObject.Picture Is Nothing Then ImgWidth = mObj.ScaleX(pArrObject.Picture.Width, vbHimetric, vbPixels) ImgHeight = mObj.ScaleY(pArrObject.Picture.Height, vbHimetric, vbPixels) DataDrawText.lWidthText = ImgWidth If DataDrawText.lMaxAscentFont < ImgHeight Then DataDrawText.lMaxAscentFont = ImgHeight End If If DataDrawText.lMaxHeightFont < ImgHeight Then DataDrawText.lMaxHeightFont = ImgHeight + DataDrawText.lDesent End If End If End If Exit Sub error_Sub: RaiseEvent Error(Err.Description, Err.Number) End Sub ' Sub que corta las palabras del texto que se _ va a agregar y las agrega en el array arrObjects '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub mAddText(sText As String) On Local Error GoTo error_Sub Dim i As Long Dim j As Long Dim k As Long Dim arrSplitText() As String sText = Replace(sText, vbTab, " ") ' recuperar en un array las líneas arrSplitText = Split(sText, vbNewLine) ' recorrer el vector arrSplitText For j = LBound(arrSplitText) To UBound(arrSplitText) ' obtener las palabras Dim arrSplitWords() As String arrSplitWords = Split(arrSplitText(j), " ") ' recorrer las palabras For k = LBound(arrSplitWords) To UBound(arrSplitWords) If k < UBound(arrSplitWords) Then Call setObject(arrSplitWords(k) & " ", eText) ' si no es la última agregarle un espacio Else Call setObject(arrSplitWords(k), eText) End If Next If j < UBound(arrSplitText) Then Call setObject("", eNewLine) End If Next Exit Sub error_Sub: MsgBox Err.Description, vbCritical RaiseEvent Error(Err.Description, Err.Number) End Sub ' Sub que agrega al array los elementos _ ( el texto, las imagenes, las lineas ) y las propieades ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub setObject(sValue As Variant, op As eObject) On Local Error GoTo error_Sub If (sValue = "") And op = eText Then Exit Sub Screen.MousePointer = vbHourglass ' redimensionar el array para el nuevo elemento Dim k As Long k = UBound(arrObjects) + 1 ReDim Preserve arrObjects(k) With arrObjects(k) ' valores por defecto para que no de error al asignar las propiedades de la fuente If mFont.Size = 0 Then .oFont.Size = mDefFontSize End If If mFont.Name = "" Then .oFont.Name = mDefFontName End If Select Case op Case eNewLine ' Agregar nuevo salto de linea .sText = "" .bSaltoDeLinea = True .oFont.Size = mDefFontSize .oFont.Name = mDefFontName .TypeObject = eText Case eLine ' Agregar los datos para luego dibujar una linea con el método Line .oFont.Size = mDefFontSize .oFont.Name = mDefFontName .lForeColor = sValue .TypeObject = eLine .bSaltoDeLinea = True .bLine.lDrawStyle = mLine.lDrawStyle .bLine.lDrawWidth = mLine.lDrawWidth Case ePicture ' Agregar los datos para esta imagen .sText = " " .TypeObject = ePicture .oFont.Size = mDefFontSize .oFont.Name = mDefFontName Set .Picture = LoadPicture(sValue) .Align = mAlignText Case eText ' Agregar los datos para este texto Set .oFont = mFont .lBackColor = mBackColor .lForeColor = mForeColor .sText = sValue .Align = mAlignText .TypeObject = eText End Select End With Screen.MousePointer = 0 Exit Sub error_Sub: RaiseEvent Error(Err.Description, Err.Number) Screen.MousePointer = 0 End Sub ' Inicio del módulo de clase '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Class_Initialize() mDefFontSize = 8 mDefFontName = "Verdana" Call Clear End Sub ' // Declaración de Propiedades ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Property Get ForeColor() As Long ForeColor = mForeColor End Property Property Let ForeColor(value As Long) mForeColor = value End Property Property Get BackColor() As Variant BackColor = mBackColor End Property Property Let BackColor(value As Variant) mBackColor = value End Property Property Get Margin() As Long Margin = mMargin End Property Property Let Margin(value As Long) If value <= 0 Then value = 2 End If mMargin = value End Property Property Get SpacingLine() As Long SpacingLine = mSpacingLine End Property Property Let SpacingLine(value As Long) If value <= 0 Then value = 4 End If mSpacingLine = value End Property Property Get Font() As Font Set Font = mFont End Property Property Set Font(pFont As StdFont) Set mFont = pFont End Property Property Get Top() As Long Top = mTop End Property Property Let Top(value As Long) mTop = value End Property

Buscar en Recursos vb con Google