Adaptar una cadena a un label

[Beakdan]

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).