Código:
Option Explicit
Private Const DT_END_ELLIPSIS As Long = &H8000
Private Const DT_MODIFYSTRING As Long = &H10000
Private Const DT_NOCLIP As Long = &H100
Private Const DT_CALCRECT As Long = &H400
Private Const LOGPIXELSY As Long = 90
Private Const FW_NORMAL As Long = 400
Private Const FW_BOLD As Long = 700
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" ( _
ByVal hDC As Long, _
ByVal lpString As String, _
ByVal nCount As Long, _
ByRef lpRect As RECT, _
ByVal uFormat As Long) As Long
Private Declare Function SetRect Lib "user32" ( _
ByRef lprc As RECT, _
ByVal xLeft As Long, _
ByVal yTop As Long, _
ByVal xRight As Long, _
ByVal yBottom As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( _
ByVal nHeight As Long, _
ByVal nWidth As Long, _
ByVal nEscapement As Long, _
ByVal nOrientation As Long, _
ByVal fnWeight As Long, _
ByVal fdwItalic As Boolean, _
ByVal fdwUnderline As Boolean, _
ByVal fdwStrikeOut As Boolean, _
ByVal fdwCharSet As Long, _
ByVal fdwOutputPrecision As Long, _
ByVal fdwClipPrecision As Long, _
ByVal fdwQuality As Long, _
ByVal fdwPitchAndFamily As Long, _
ByVal lpszFace As String) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal hgdiobj As Long) As Long
Private Declare Function MulDiv Lib "kernel32" ( _
ByVal nNumber As Long, _
ByVal nNumerator As Long, _
ByVal nDenominator As Long) As Long
Private Sub Check1_Click(Index As Integer)
updateLabels
End Sub
Private Sub Combo1_Click(Index As Integer)
updateLabels
End Sub
Private Sub updateLabels()
'Modificamos las fuentes de los controles label
If Check1.UBound > 0 Then
Label1(0).Font = Combo1(0).List(Combo1(0).ListIndex)
Label1(1).Font = Combo1(0).List(Combo1(0).ListIndex)
Label1(0).FontSize = CInt(Combo1(1).List(Combo1(1).ListIndex))
Label1(1).FontSize = CInt(Combo1(1).List(Combo1(1).ListIndex))
Label1(0).FontBold = (Check1(0).Value = vbChecked)
Label1(1).FontBold = (Check1(0).Value = vbChecked)
Label1(0).FontItalic = (Check1(1).Value = vbChecked)
Label1(1).FontItalic = (Check1(1).Value = vbChecked)
Label1(0).Caption = Text1.Text
Label1(1).Caption = Text1.Text
End If
SetElipsisString Label1(0)
SetFontSizeToFit Label1(1)
End Sub
Private Sub Form_Load()
Dim lWinOffsetW As Long
Dim lWinOffsetH As Long
Dim i As Long
'Posicionamos e inicializamos los controles
lWinOffsetW = Me.Width - Me.ScaleWidth
lWinOffsetH = Me.Height - Me.ScaleHeight
Me.ScaleMode = vbPixels
With Label1(0)
.BackColor = vbWhite
.Move 10, 10, 200, 32
End With
Load Label1(1)
With Label1(1)
.Move 10, (Label1(0).Height + Label1(0).Top + 6)
.Visible = True
End With
With Text1
.Move 10, (Label1(1).Height + Label1(1).Top + 6), 300, 21
.Text = "En un lugar de la Mancha de cuyo nombre no quisiera acordarme"
End With
With Combo1(0)
.Move 10, (Text1.Top + Text1.Height + 6), 150
For i = 0 To Screen.FontCount - 1
.AddItem Screen.Fonts(i)
Next i
For i = 0 To .ListCount - 1
If .List(i) = "MS Sans Serif" Then
.ListIndex = i
Exit For
End If
Next i
End With
Load Combo1(1)
With Combo1(1)
.Move (Combo1(0).Left + Combo1(0).Width + 6), Combo1(0).Top, 50
For i = 0 To 15
.AddItem CStr(((i + 1) * 2)), i
Next i
.ListIndex = 3
.Visible = True
End With
With Check1(0)
.Caption = "N"
.FontBold = True
.Move (Combo1(1).Left + Combo1(1).Width + 6), Combo1(1).Top, 40, 16
End With
Load Check1(1)
With Check1(1)
.Caption = "C"
.FontBold = False
.FontItalic = True
.Move (Check1(0).Left + Check1(0).Width + 6), Combo1(1).Top, 40, 16
.Visible = True
End With
Me.Move Me.Left, Me.Top, (320 * Screen.TwipsPerPixelX) + lWinOffsetW, _
((Combo1(1).Top + Combo1(1).Height + 10) * Screen.TwipsPerPixelY) + lWinOffsetH
updateLabels
End Sub
Private Sub SetElipsisString(ByRef lblToFit As Label)
Dim rctR As RECT
Dim tmpHDC As Long
Dim hFont As Long
Dim lNullIndex As Long
Dim lblCaption As String
'La función DrawText cuando es usada con el modificador DT_MODIFYSTRING
'puede llegar a agregar hasta cuatro caracteres al String pasado como
'parámetro (según la documentación de Platform SDK), así que, como mera
'precaución agregamos 4 caracteres al final del texto; por si acaso...
lblCaption = lblToFit.Caption & String(4, vbNullChar)
'Mostramos un tooltip con el texto completo
lblToFit.ToolTipText = lblToFit.Caption
'El tamaño de el label
SetRect rctR, 0, 0, lblToFit.Width, lblToFit.Height
'Device Context donde haremos la operación...
tmpHDC = CreateCompatibleDC(Me.hDC)
'Creamos una fuente = a la fuente del Label. Esta será seleccionada en el
'Device Context temporal, y con ella la función DrawText(), modificará el
'texto del label para incluir elipsis (tres puntos) en caso de que no quepa en el Label
hFont = CreateFont(-MulDiv(CLng(lblToFit.FontSize), GetDeviceCaps(tmpHDC, LOGPIXELSY), 72), _
0&, 0&, 0&, CLng(IIf(lblToFit.FontBold, FW_BOLD, FW_NORMAL)), _
lblToFit.FontItalic, False, False, 1&, _
0&, 0&, 2&, 0&, lblToFit.FontName)
DeleteObject SelectObject(tmpHDC, hFont)
'En caso de que no se use una fuente distinta a la fuente por defecto
'en los labels, en lugar de CreateFont(), podemos usar la fuente de sistema
'que se asigna a dichos controles. Esta se obtiene mediante la llamada a
'la función GetStockObject(ANSI_VAR_FONT)
'hFont = GetStockObject(ANSI_VAR_FONT)
'Dibujamos en el DC en memoria el texto
DrawText tmpHDC, lblCaption, -1, rctR, DT_END_ELLIPSIS Or DT_MODIFYSTRING Or DT_NOCLIP
'Cortamos el string hasta el null
lNullIndex = InStr(1, lblCaption, vbNullChar)
If (lNullIndex > 0) Then
lblToFit.Caption = Left$(lblCaption, lNullIndex - 1)
Else
lblToFit.Caption = lblCaption
End If
'Ya no necesitamos el DC ni la fuente
DeleteObject hFont
DeleteObject tmpHDC
End Sub
''Esta función utiliza solamente métodos de VB para averiguar
''el tamaño de la fuente para que quepa todo el texto en el label.
''Sin embargo, como carga y descarga dinámicamente un control, no puede
''ser llamada desde los manejadores Click de los controles. Hacerlo
''ocasiona un error. Para solucionar esto, hay dos opciones:
''1) Con un timer llamar a esta función algunos milisegundos
''despues del evento de los controles; o bien
''2) No utilizar controles dinámicos y poner un label de más,
''que básicamente será un pasmarote con la misma utilidad
''que tmpLabel de la siguiente función
'Private Sub SetFontSizeToFit(ByVal lblToFit As Label)
'Dim tmpLabel As Label
'Dim lFSize As Single
'
' Set tmpLabel = Me.Controls.Add("VB.Label", "tmpLbl", Me)
' tmpLabel.AutoSize = True
' tmpLabel.Font = lblToFit.Font
' lFSize = lblToFit.FontSize
' tmpLabel = lFSize
' tmpLabel.Caption = lblToFit.Caption
' lblToFit.ToolTipText = lblToFit.Caption
' Debug.Print "tmpLabel.Width: " & tmpLabel.Width
' Debug.Print "lblToFit.Width: " & lblToFit.Width
'
' Do While (tmpLabel.Width > lblToFit.Width) And (lFSize > 0)
' tmpLabel.FontSize = lFSize
' lFSize = lFSize - 0.25
' Debug.Print tmpLabel.FontSize
' Loop
'
' lblToFit.FontSize = tmpLabel.FontSize
'
' Set tmpLabel = Nothing
' Me.Controls.Remove ("tmpLbl")
'End Sub
Private Sub SetFontSizeToFit(ByVal lblToFit As Label)
Dim rctR As RECT
Dim tmpHDC As Long
Dim hFont As Long
Dim lMdRes As Long
Dim lFSize As Single
Dim lblCaption As String
'En esta función tenemos casi el mismo código que en SetElipsisString(),
'pero en este caso no hemos establecido el rectangulo rctR al tamaño del label.
'Esto es porque llamaremos a la función DrawText() con el modificador
'DT_CALCRECT. Esto hará que la función calcule el area que ocuparía la cadena
'de texto, devolviendo los valores calculados en en rctR. Llamando
'continuamente a la función hasta que el ancho devuelto sea menor que el
'ancho del Label, obtendremos el tamaño de la fuente para que todo el texto quepa
lblCaption = lblToFit.Caption & String(4, vbNullChar)
lblToFit.ToolTipText = lblToFit.Caption
lFSize = lblToFit.FontSize
tmpHDC = CreateCompatibleDC(Me.hDC)
Do
lMdRes = MulDiv(CLng(lFSize * 4), GetDeviceCaps(tmpHDC, LOGPIXELSY), 72) \ 4
hFont = CreateFont(-lMdRes, 0&, 0&, 0&, IIf(lblToFit.FontBold, FW_BOLD, FW_NORMAL), _
lblToFit.FontItalic, False, False, 1&, _
0&, 0&, 2&, 0&, lblToFit.FontName)
DeleteObject SelectObject(tmpHDC, hFont)
DrawText tmpHDC, lblCaption, -1, rctR, DT_CALCRECT Or DT_NOCLIP
DeleteObject hFont
lFSize = lFSize - 0.25
lblToFit.FontSize = lFSize
'Algunas fuentes tienen un límite de tamaño mínimo. Por lo tanto,
'verificamos que la variable lFSize nunca sea menor que 1. De no hacerlo,
'el bucle sería infinito, ya que rctR.Right, siempre retornaría el mismo
'valor es esos casos.
Loop Until (lFSize <= 1) Or (rctR.Right <= lblToFit.Width)
DeleteObject tmpHDC
End Sub
Private Sub Text1_Change()
updateLabels
End Sub
He puesto varios comentarios para aclarar que ocurre. Déjame saber si te ha sido útil.
Hasta luego.
****************  Acabo de darme cuenta, que el código tenía dos fallos fundamentales:  Una excepción de error funciona bien en el IDE en mi equipo, por la configuración que tengo, pero en otras máquinas, sólo hubiera funcionado compilado.  El otro fallo –aún peor– era que había olvidado eliminar las fuentes una vez que terminaba de usarlas. Después de un rato de operación el sistema se hubiera quedado sin memoria.
Problemas corregidos.  Espero que no haya afectado a alguien (aunque creo que aún no han usado el código).
Última edición por Beakdan; 16/10/2004 a las 10:22 |