Adaptar una cadena a un label

oblacionx · #1 (**permalink**) 14/10/2004, 14:46

Hola, tengo el siguiente poroblema, tengo en un form un label con medidas fijas, y una cadena que es variable, necesito porner esta cadena dentro del label, sin que esta salga partida o cortada, como puedo hacer para que el tamaño de la fuente del label se adapte a la longitud de la cadena

Kaopectate · #2 (**permalink**) 14/10/2004, 15:20

Ajá, pero...que te parece si nos dices el lenguaje en el que estas trabajando?

Saludos.

RadicalEd · #3 (**permalink**) 14/10/2004, 16:02

A VER PUES SI ES EN VB LE PUEDES DECIR EN LAS PROPIEDADES AutoSize=True
Y NO SE MAS

Kaopectate · #4 (**permalink**) 14/10/2004, 16:08

Si fuese Delphi, es igual: autosize.

Saludos.

oblacionx · #5 (**permalink**) 15/10/2004, 10:24

Estoy Trabajando en VB, pero recuerden que el que es de tamaño fijo es el label, porque al utilizar el autosize, el label crece descontroladamente por eso quiero saber como puedo adaptarlo al tamaño de la fuente, es decir que si la cadena es mas grabnnde que el label disminuir el tamaño y si es menor aumnetar el tamaño del font

Rbkrr · #6 (**permalink**) 15/10/2004, 10:44

Si se puede hacer pero debes de tener un maximo de caracteres en el texto no ? la cantidad minima no importaria pero si la maxima, seria mas facil ponle una cantidad fija(de caracteres) al text y quedaria como quieres.

Saludos!

oblacionx · #7 (**permalink**) 15/10/2004, 12:26

Gueno el ponerle un maximo de caracteres esta , bien pero el tamaño de la letra se dadaptaria al tamaño de label si el texto es " Empresa Uno" o si Fuera solo "uno" o " La empresa numero uno del mundo es la mia", todos tiene menosd e 50 pero la cosa seria que se adapte el tamño del font al label

Rbkrr · #8 (**permalink**) 15/10/2004, 13:34

Tendrias que hacer unas maniobras ahi con los caracteres y todo en tiempo de ejecucion, medir la longitud del text y compararlo con la longitud del label, y cambiar el size del font tambien en tiempo de ejecucion.

Beakdan · #9 (**permalink**) 16/10/2004, 04:32

Oblacionx:
Rbkrr tiene razón. Pero toma en cuenta que hay muchas fuentes que tienen un tamaño mínimo, y sin importar que valor asignes, no bajarán de dicho tamaño. También está el asunto de la legibilidad. Si se llega a reducir mucho el tamaño, el texto simplemente no podría ser leído. Y algo más la estética. Si tuvieras varios controles label se vería discordante que el tamaño de los textos no fuera el mismo.
Algunas veces necesito limitar el texto a un rectángulo específico, y para ello uso la función DrawText de la API. La ventaja de usar esta función, es que recorta el texto que no cabe, y le agrega puntos suspensivos al final de la cadena. Esto hace saber al usuario, que el texto continúa, así con un tooltip puede obtener el resto de la información. Lo mejor de todo, al menos desde mi punto de vista, es que el diseño de mi formulario no queda arruinado como pasa con un label con autosize, o con wordwrap.
El siguiente código te muestra dicho código, pero además el mismo con ligeras modificaciones sirve para calcular el tamaño de fuente máximo en que cabe todo el texto en un label con determinadas dimensiones. Doy por sentado, que el label es de sólo una línea de texto, pero los que uso para esta demostración están sobredimensionados en lo alto, para que sea apreciable como es imposible redimensionar ciertos tipos de fuente.

En un nuevo form, agrega los siguientes controles y modifica las propiedades indicadas:

1 TexBox
Name: Text1
1 Label
Name: Label1
Index: 0
1 Checkbox
Name: CheckBox1
Index: 0
1 ComboBox
Name: Combo1
Index: 0
Sorted: True
Style: 2-DropDown List

Y agrega el siguiente código:

Beakdan · #10 (**permalink**) 16/10/2004, 04:33

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

adolfomauriola · #11 (**permalink**) 17/01/2009, 20:09

Me parece excelente respuesta aunque un poco tarde la he leido me sirve para un proyecto que actualmente me encuentro realizando en este lenguaje se trata de una impresion de un Picture con sus objetos que contiene Label's sobre todo y una imagen de fondo.
Mi problema que tengo es con los label's como veo en este programa los adapta pero siempre y cuando se redusca su tamaño tanto en ancho como su alto pero lo que yo deseo es solo reducir su ancho para que ingrese dentro de un objeto de dimensiones conocidas como tu ejemplo.

Muchas gracias por prestar atención a esta lectura si tenes informacion acerca de como modificar el ancho mas no el alto, de antemano se los agradesco