the module function that I'm using is fAutoSizeTextBoxMulti on Access
2003 service SP2.
I'm applying your last hint, the one that call the Current event
procedure from the text box's Change event with this line of code:
Call Form_Current().
At moment I'm adjusting both text box's Height and Width, but if it
can more easy to do , I can decide to change just the Width of the
textbox, I realy don't mind that! My font size and kind will always
stay the same.
Which function I have to use? Where I can find TextHeightWidth module
that you are using?
Well, I didn't expect this to take half the afternoon, but I
think I got what you want out of the code you had. I did
have to change the code in several places though.
Be careful fixing up all the line wrapping that one or both
if our news reader programs introduce into the code.
--
Marsh
MVP [MS Access]
------------------------------------------------------------------------------
Here's what I ended up with in the form's module:
Private Sub txtExtraInfo_Change()
FudgeIt fAutoSizeTextBoxM(Me.txtExtraInfo, True)
End Sub
Private Sub Form_Current()
FudgeIt fAutoSizeTextBoxM(Me.txtExtraInfo, False)
End Sub
Private Sub FudgeIt(Srect As RECT)
With Srect
' ***************NOTE***************
' Be aware of the Fudge values you
' see here if you are using these routines
' to align multiple controls to simulate
' one larger Control.
' ***************NOTE***************
' Becasue of the internal fomatting(Margins) Access
' uses we have to fudge the Control's Height a bit.
If .Bottom > 0 Then
If .Bottom < Me.Detail.Height Then
Me.txtExtraInfo.Height = .Bottom * 1.1
Else
Me.txtExtraInfo.Height = Me.Detail.Height
End If
End If
' Fudge Problem
' on a relative narrow box, <1440 twips, the Text is not
rendered
' correctly with my .02 Fudge factor. Access must be using
' an inset margin and the .02 Fudge is not sufficient at
narrower widths.
' I stuck this IIF statement in for now until I figure out
' the method Access is using.
If .right > 0 Then
If .right < Me.Width Then
Me.txtExtraInfo.Width = .right + IIf((.right * 0.1)
< 50, 50, .right * 0.1)
Else
Me.txtExtraInfo.Width = Me.Width
End If
End If
End With
End Sub
------------------------------------------------------------------------------
And here's the modified version of the fAutoSizeTextBoxM
function:
Public Type RECT
Left As Long
top As Long
right As Long
Bottom As Long
End Type
' Declare API functions
Private Declare Function apiCreateFont Lib "gdi32" _
Alias "CreateFontA" (ByVal H As Long, _
ByVal W As Long, ByVal E As Long, _
ByVal O As Long, ByVal W As Long, _
ByVal i As Long, ByVal u As Long, _
ByVal S As Long, ByVal c As Long, _
ByVal OP As Long, ByVal CP As Long, _
ByVal Q As Long, ByVal PAF As Long, _
ByVal F As String) As Long
Private Declare Function apiSelectObject Lib "gdi32" _
Alias "SelectObject" (ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject As Long _
) As Long
Private Declare Function apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Declare Function apiMulDiv Lib "kernel32" _
Alias "MulDiv" (ByVal nNumber As Long, _
ByVal nNumerator As Long, _
ByVal nDenominator As Long) As Long
Private Declare Function apiCreateIC Lib "gdi32" _
Alias "CreateICA" (ByVal lpDriverName As String, _
ByVal lpDeviceName As String, _
ByVal lpOutput As String, _
lpInitData As Any) As Long
Private Declare Function apiGetDC Lib "user32" _
Alias "GetDC" (ByVal hwnd As Long) As Long
Private Declare Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" (ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function apiDeleteDC Lib "gdi32" _
Alias "DeleteDC" (ByVal hDC As Long) As Long
Private Declare Function apiDrawText Lib "user32" _
Alias "DrawTextA" (ByVal hDC As Long, _
ByVal lpStr As String, ByVal nCount As Long, _
lprect As RECT, ByVal wFormat As Long) As Long
' CONSTANTS
Private Const TWIPSPERINCH = 1440
' Used to ask System for the Logical pixels/inch in Y axis
Private Const LOGPIXELSY = 90
' DrawText() Format Flags
Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
Private Const DT_SINGLELINE = &H20
Private Const DT_CALCRECT = &H400
Public Function fAutoSizeTextBoxM(ctl As Control, _
UseText As Boolean) As RECT
'Name fAutoSizeTextBoxM
'
'Purpose: Returns Control Width & Height needed to
' display the contents of the Control passed
' to this function. This function
' uses the Control's font attributes to Build
' a Font for the required Calculations into the
' Control passed to this Function
'Version: 2.0 RAW
'Calls: Text API stuff. DrawText performs the actual
' calculation to determine Control Width/Height
'Returns: Standard Rectangle Structure
'Created by: Stephen Lebans
'Credits: Dimitri Furman for debugging the Function
'Date: Jan. 14, 2000
'Time: 12:19:23pm
'Feedback: (e-mail address removed)
'My Web Page:
www.lebans.com
'Copyright: Lebans Holdings Ltd.
' May not be resold in whole or part
' but may be used without restriction
' in any application you develop.
'
'Bugs:
'Not tested enough to tell. Let me know
'NEEDS ERROR CHECKING!!!!!
'
'Enjoy
'Stephen Lebans
'***************Code Start***************
' Did we get a valid control passed to us?
If IsNull(ctl.FontSize) Then Exit Function
' Did we get a valid control passed to us?
If Len(ctl & "") = 0 Then Exit Function
' Structure for DrawText calc
Dim Srect As RECT
' Handle to Report's window
Dim hwnd As Long
' Reports Device Context
Dim hDC As Long
' Holds the current screen resolution
Dim lngYdpi As Long
Dim newfont As Long
' Handle to our Font Object we created.
' We must destroy it before exiting main function
Dim oldfont As Long
' Device COntext's Font we must Select back into the DC
' before we exit this function.
' Temporary holder for returns from API calls
Dim lngRet As Long
' Calculate screen Font height
Dim fheight As Long
' Get Controls Parents Window handle
hwnd = ctl.Parent.hwnd
If hwnd = 0 Then Exit Function
' retrieve a handle to a display device context (DC)
' for the client area of the specified window
hDC = apiGetDC(hwnd)
' Because Access control's do not have a permanent
' Device Context, we cannot depend on what we find
' selected into the DC unless the Control has the focus.
' In this case we are simply using the Control's Font
' attributes to build our own font in whatever
' DC is handy. We must Save this DC's Font so we can
' restore the Font when we exit this function.
' Clear our return value
lngRet = 0
' Temporary Information Context for Screen info.
Dim lngIC As Long
' Modified to allow for different screen resolutions
' and printer output. Needed to Calculate Font size
lngIC = apiCreateIC("DISPLAY", vbNullString, _
vbNullString, vbNullString)
If lngIC <> 0 Then
lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
apiDeleteDC (lngIC)
Else
lngYdpi = 120 'Default average value
End If
' Calculate/Convert requested Font Height
' into Font's Device Coordinate space
fheight = apiMulDiv(ctl.FontSize, lngYdpi, 72)
' We use a negative value to signify
' to the CreateFont function that we want a Glyph
' outline of this size not a bounding box.
With ctl
newfont = apiCreateFont(-fheight, 0, _
0, 0, .FontWeight, _
.FontItalic, .FontUnderline, _
0, 0, 0, _
0, 0, 0, .FontName)
End With
' Select the new font into our DC.
oldfont = apiSelectObject(hDC, newfont)
' Use DrawText to Calculate height of Rectangle
' required to hold the current contents of the
' Control passed to this function
With Srect
.Left = 0
.top = 0
.Bottom = 0 'ctl.Height / (TWIPSPERINCH / lngYdpi)
.right = 0 'ctl.Width / (TWIPSPERINCH / lngYdpi)
If UseText Then
lngRet = apiDrawText(hDC, ctl.Text, -1, Srect,
DT_CALCRECT _
Or DT_TOP Or DT_LEFT Or DT_NOPREFIX)
Else
lngRet = apiDrawText(hDC, ctl.Value, -1, Srect,
DT_CALCRECT _
Or DT_TOP Or DT_LEFT Or DT_NOPREFIX)
End If
' 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
