Steven Lebans AutoSizeTextbox

Tech-Archive recommends: Fix windows errors by optimizing your registry

I downloaded this code from Steven's website, intending to use it to resize a
textbox on a modal "<Doing some activity>, please wait..." form, passing the
specific message with OpenArgs.

I put the Public procedures with the following Type declaration in a new
global module, and inserted the form-specific code in my form module,
changing the control references as necessary.

On opening the form, it crashes on the form-specific code line:

Dim sRect As RECT

with a Compile Error: Ambiguous Name RECT

It seems as if it doesn't know about this type, defined in the global
module. Does anyone know what I'm missing?

Thank you.
Sprinks

' Global Module code
Option Compare Database
Option Explicit

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) 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.
currently selected into the Control passed to this Function
'Version: 2.0 RAW :-)
'Calls: Text API stuff. DrawText pewrforms 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: Stephen@xxxxxxxxxx
'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)
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

' Form-specific code

' Written By Stephen Lebans
' Stephen@xxxxxxxxxx
' www.lebans.com

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

' This example if formatted for a control
' in the Detail Section.
' Obviously changes will be required if your
' Control is placed in a different Section.

' This example resizes the Control Width and Height
' to fit all the current contents. I have sized the
' Form at 18 inches in width for this Demo to allow
' for testing of large Font sizes.

' You can easily modify these functions to
' fix the Height or Width of the Control if


' ***************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***************

Dim sRect As RECT
Dim sRectInt As sRectInteger

sRect = fAutoSizeTextBoxM(Me.txtMsg)

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

' 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.txtMsg.Height = .Bottom + (.Bottom * 0.05)
'Else: Me.txtMsg.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.txtMsg.Width = .Right + IIf((.Right * 0.01) < 50, 50, .Right *
0.01)

Else: Me.txtMsg.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

Private Sub Form_Open(Cancel As Integer)
Me![txtMsg] = Me.OpenArgs & " , please wait..."
End Sub


.

Quantcast