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.