Modificar macro para autojustificar más de un textbox

Es una pregunta para Sveinbjorn El Rojo

Tengo un código del maestro Lebans que permite autojustificar un textbox según la longitúd de lo que hayas escrito... El problema es que está hecho para un solo textbox y no sé adaptarlo para que autojustifique varios textbox.

El código es el siguiente:

En un módulo se declaran las apis (no las meto para no enrollarme) y la siguiente función:
Option Compare Database
Option Explicit

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Function fAutoSizeTextBoxM(ctl As Control) As RECT

If IsNull(ctl.fontsize) Then Exit Function
If Len(ctl & "") = 0 Then Exit Function
Dim sRect As RECT
Dim hWnd As Long

Dim hdc As Long
Dim lngYdpi As Long
Dim newfont As Long
Dim oldfont As Long
Dim lngRet As Long
Dim fheight As Long
hWnd = ctl.Parent.hWnd
If hWnd = 0 Then Exit Function
hdc = apiGetDC(hWnd)
lngRet = 0
Dim lngIC As Long
lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
If lngIC <> 0 Then
lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
apiDeleteDC (lngIC)
Else
lngYdpi = 120 'Default average value
End If

fheight = apiMulDiv(ctl.fontsize, lngYdpi, 72)
With ctl
newfont = apiCreateFont(-fheight, 0, _
0, 0, .FontWeight, _
.FontItalic, .FontUnderline, _
0, 0, 0, _
0, 0, 0, .FontName)
End With
oldfont = apiSelectObject(hdc, newfont)
With sRect
.Left = 0
.Top = 0
.Bottom = 0 'ctl.Height / (TWIPSPERINCH / lngYdpi)
.Right = 0 'ctl.Width / (TWIPSPERINCH / lngYdpi)
lngRet = apiDrawText(hdc, ctl.Value, -1, sRect, DT_CALCRECT + DT_TOP + DT_LEFT)
' Cleanup
lngRet = apiSelectObject(hdc, oldfont)
' Delete the Font we created
apiDeleteObject (newfont)
lngRet = apiReleaseDC(hWnd, hdc)
' Convert RECT values to TWIPS
.Bottom = .Bottom * (TWIPSPERINCH / lngYdpi)
.Right = .Right * (TWIPSPERINCH / lngYdpi)
End With
fAutoSizeTextBoxM = sRect
End Function

---------------------------------------------------------------------------------------------------------------------------

Ahora en el formulario se crean varios eventos:

' Written By Stephen Lebans
Option Compare Database
Option Explicit
Private Type sRectInteger
        Left As Integer
        Top As Integer
        Right As Integer
        Bottom As Integer
End Type
Private Sub Form_Current()
Dim sRect As RECT
Dim sRectInt As sRectInteger
sRect = fAutoSizeTextBoxM(Me.txtLibros)
' SRect's members are all LONG values.
' Let's copy to a dup structure but with
' all members as Integers
With sRectInt
.Bottom = CInt(sRect.Bottom)
.Right = CInt(sRect.Right)
If .Bottom > 0 Then
        Me.txtLibros.Height = .Bottom + (.Bottom * 0.05)
End If
If .Right > 0 Then
    If .Right < Me.Width Then
        Me.txtLibros.Width = .Right + IIf((.Right * 0.01) < 50, 50, .Right * 0.01)
    Else: Me.txtLibros.Width = Me.Width
    End If
End If
End With
End Sub
---------------------------------------------------------------------------------------------------------------------------
Private Sub Form_Load()
DoCmd.MoveSize 10, 10, 9000, 5000
End Sub
---------------------------------------------------------------------------------------------------------------------------
Private Sub Form_Activate()
DoCmd.MoveSize 10, 10, 9000, 5000
End Sub

---------------------------------------------------------------------------------------------------------------------------

Necesitaría añadir en el código que el autojustificado del textbox que ahora solo afecta al "txtLibros" afectara también a "txtColeccion", "txtGenero" y "txtEditorial", etc. He puesto en negrita las líneas donde creo que hay que realizar las modificaciones pero no sé hacerlas ni tampoco si hay más líneas que tocar. Si me pudieras indicar qué cambiar te lo agradecería.

A la espera de que puedas ayudarme.

1 Respuesta

Respuesta
1

Repite todo desde la primera linea en negrita hasta el end with para cada texbox que quieras modificar. Es la forma más sencilla

Hola

Es que así como voy a tener 11 textbox se me va a hacer larguísimo el código. Si pudiéramos escribir menos líneas de alguna manera...

No se puede acortar, no sé poniendo algo parecido a esto:

Private Sub Form_Current()
Dim sRect As RECT
Dim sRectInt As sRectInteger
sRect = fAutoSizeTextBoxM(Me.txtLibros)

sRect = fAutoSizeTextBoxM(Me.txtColeccion)

sRect = fAutoSizeTextBoxM(Me.txtGenero)


' SRect's members are all LONG values.
' Let's copy to a dup structure but with
' all members as Integers
With sRectInt
.Bottom = CInt(sRect.Bottom)
.Right = CInt(sRect.Right)
If .Bottom > 0 Then
        Me.txtLibros.Height = .Bottom + (.Bottom * 0.05)

       Me.txtColeccion.Height = .Bottom + (.Bottom * 0.05)

       Me.txtGenero.Height = .Bottom + (.Bottom * 0.05)
End If
If .Right > 0 Then
    If .Right < Me.Width Then

Me.txtLibros.Width = .Right + IIf((.Right * 0.01) < 50, 50, .Right * 0.01)

Me.txtColeccion.Width = .Right + IIf((.Right * 0.01) < 50, 50, .Right * 0.01)

Me.txtGenero.Width = .Right + IIf((.Right * 0.01) < 50, 50, .Right * 0.01)


    Else: Me.txtLibros.Width = Me.Width and me.txtColeccion.Width = me.width and me.txtGenero.Width =me. Width
    End If
End If
End With
End Sub

Esto no me funciona pero por si algo se te ocurre para no tener que repetir un mismo código en cada textbox porque la macro se haría larguísima.

Había probado también ...

sRect = fAutoSizeTextBoxM(Me.txtLibros, me.txtColeccion, me.txtGenero) pero tampoco...

Si me pudieras indicar cómo agruparlos todos en menos líneas para que así no se me hiciera tan largo el código y ejecutar la macro te lo agradecería.

A la espera de tu respuesta ante todo gracias por la ayuda.

Así no te funciona porque con estas líneas:

sRect = fAutoSizeTextBoxM(Me.txtLibros)

sRect = fAutoSizeTextBoxM(Me.txtColeccion)

sRect = fAutoSizeTextBoxM(Me.txtGenero)

Sólo estas cargando un cuadro de texto (el de la última). Tendrías que declarar 11 variables (sRect1, SRect2...) para cargar cada cuadro de texto, pero no te evita tener que hacer 11 bucles With.. End With, con lo que al final sólo consigues más líneas de código (las 11 declaraciones)

Y digo yo ¿qué problema tienes con que el código sea más o menos largo? Lo único que has de hacer es un copia-pega y cambiar el nombre del cuadro de texto en tres o cuadro sitios

Hola

Es que a veces me ha pasado que cuando tengo rutinas muy muy largas me da error al procesarlas, como si el sistema no pudiera procesar macros muy largas o más bien con muchas claúsulas. Por ejemplo me pasaba cuando metí muchas "or" y "and" a un recordsource para hacer búsquedas de datos... con una SQL. Creo que hablamos de ello.

Pero si no se puede simplificar y no va a haber ningún problema por tener que repetir muchas veces el mismo código y "engordar" la macro, ni se va a ralentizar la BD pues entonces perfecto. Ya me comentas...

Y como siempre gracias por tu paciencia y ayuda.

 ... De todas maneras no creo que tenga mayor importancia repetir el código, como tú bien dices.

Mil gracias de nuevo

Si el código está correctamente escrito no tendrás problemas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas