Hi Marsh,
I'll post you back both the module and the form's code as I'm using
them, so you can take a look.
May be I make some mistakes fixing up the lines wrapping or something
like that, I don't known
****start Form's code****
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()
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 atnarrower
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
Private Sub txtExtraInfo_Change()
FudgeIt fAutoSizeTextBoxM(Me.txtExtraInfo, True)
End Sub
****end Form's code****
****start Module's 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, _
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)
Else
lngRet = apiDrawText(hDC, ctl.Value, -1, sRect, DT_CALCRECT _
Or DT_TOP Or DT_LEFT)
End If
' Cleanup
lngRet = apiSelectObject(hDC, oldfont)
' Delete the Font we created
apiDeleteObject (newfont)
lngRet = apiReleaseDC(hwnd,
...
leggi tutto
