This is reguarding the following code. I was given this at a seminar and it is supposed to adjust your screen for different size but for some reason the sizing cuts out when I set ExtraScalar below 1.5 Any help would be appriciated.
Option Compare Database
Option Explicit
Type Rect
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
Type TEXTMETRIC
tmHeight As Integer
tmAscent As Integer
tmDescent As Integer
tmInternalLeading As Integer
tmExternalLeading As Integer
tmAveCharWidth As Integer
tmMaxCharWidth As Integer
tmWeight As Integer
tmItalic As String * 1
tmUnderlined As String * 1
tmStruckOut As String * 1
tmFirstChar As String * 1
tmLastChar As String * 1
tmDefaultChar As String * 1
tmBreakChar As String * 1
tmPitchAndFamily As String * 1
tmCharSet As String * 1
tmOverhang As Integer
tmDigitizedAspectX As Integer
tmDigitizedAspectY As Integer
End Type
Declare Function IsZoomed Lib “user32” (ByVal hWnd As Long) As Long
Declare Function IsIconic Lib “user32” (ByVal hWnd As Long) As Long
Declare Function GetDesktopWindow Lib “user32” () As Long
Declare Function GetWindowRect Lib “user32” (ByVal hWnd As Long, rectangle As Rect) As Long
Declare Function GetTextMetrics Lib “gdi32” Alias “GetTextMetricsA” (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Declare Function GetWindowDC Lib “user32” (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib “user32” (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function SetMapMode Lib “gdi32” (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Global Const MM_TEXT = 1
Dim orgx1 As Long, orgx2 As Long, orgy1 As Long, orgy2 As Long
‘The following code will save a form after it has been resized
‘Disable all calls to form sizing in the form load, open, and resize events
‘Add the following to the form activate event changing the scale factor as desired
‘Private Sub Form_activate()
‘ SizeForm Me, 0.9
‘ DoCmd.RunCommand acCmdDesignView
‘ DoCmd.Save
‘End Sub
Public Sub SizeForm(xForm As Form, ScaleFactor As Single, Optional EchoOff As Boolean = True)
‘This subroutine will resize the form specified by parameter xForm by the factor of ScaleFactor
‘If scale factor is 0 or negative, automatic scaling will occur based on the following
‘ Value Forms originally designed for
‘ 0 640 x 480
‘ -1 800 x 600
‘ -2 1024 x 768
‘ -3 1280 x 1024
‘ -4 1600 x 1200
‘ -10 Fill Application Window
Dim ActiveForm As Object
Dim i As Integer
Dim D(200, 3) As Single
Dim RetVal As Long
Dim rectForm As Rect
Dim rectScreen As Rect
Dim SH As Single
Dim SW As Single
Dim Screenres As String
Dim Extrascalar As Integer
Extrascalar = 1.49999
‘Screenres = GetScreenRes
‘If Screenres = “640×480” Then GoTo Done
On Error GoTo ErrorHandler
If EchoOff Then DoCmd.Echo False
If ScaleFactor = 1 Then GoTo Done
If ScaleFactor = -10 Then ‘Fill Screen
DoCmd.MoveSize 0, 0
RetVal = GetWindowRect(xForm.hWnd, rectForm)
RetVal = GetWindowRect(GetDesktopWindow(), rectScreen)
SH = (rectScreen.y2 – rectScreen.y1) / (rectForm.y2 – rectForm.y1)
SW = (rectScreen.x2 – rectScreen.x1) / (rectForm.x2 – rectForm.x1)
If SH > SW Then
ScaleFactor = SW
Else
ScaleFactor = SH
End If
ElseIf ScaleFactor <= 0 Then
ScaleFactor = GetScaleFactor(ScaleFactor)
End If
Set ActiveForm = xForm
'If form in datasheet view then don't resize
If xForm.CurrentView 1 Then GoTo Done ‘rev 3/6/99
‘If the form is maximized then don’t resize
If IsZoomed(xForm.hWnd) 0 Then GoTo Done ‘rev 3/6/99, 7/13/99
With ActiveForm
If ScaleFactor > 1 Then ‘form is growing
‘deal with section heights and form width first
On Error Resume Next ‘handle error for non-existent sections
For i = 0 To 4
.Section(i).Height = .Section(i).Height * ScaleFactor
Next i
On Error GoTo ErrorHandler
.Width = .Width * ScaleFactor
End If
‘save old dimensions of subforms/groups/tabs
For i = 0 To .Count – 1
Select Case .Controls(i).ControlType
Case acOptionGroup, acSubform, acTabCtl
D(i, 0) = .Controls(i).Width
D(i, 1) = .Controls(i).Height
D(i, 2) = .Controls(i).Left
D(i, 3) = .Controls(i).Top
End Select
Next i
‘deal with controls
For i = 0 To .Count – 1
Select Case .Controls(i).ControlType
Case acOptionGroup, acPage
‘do nothing now
Case acTabCtl
.Controls(i).TabFixedWidth = .Controls(i).TabFixedWidth * ScaleFactor * 2
.Controls(i).TabFixedHeight = .Controls(i).TabFixedHeight * ScaleFactor * 2
If .Controls(i).Left < 0 Then .Controls(i).Left = 0
.Controls(i).Left = .Controls(i).Left * ScaleFactor * Extrascalar
.Controls(i).Top = .Controls(i).Top * ScaleFactor * Extrascalar
.Controls(i).Width = .Controls(i).Width * ScaleFactor * Extrascalar
.Controls(i).Height = .Controls(i).Height * ScaleFactor * Extrascalar
.Controls(i).fontsize = .Controls(i).fontsize * ScaleFactor * Extrascalar
Case acSubform
On Error Resume Next
SizeForm .Controls(i).Form, ScaleFactor
On Error GoTo ErrorHandler
Case Else
On Error Resume Next
If .Controls(i).Left 1 Then
On Error Resume Next
For i = 0 To 4
.Section(i).Height = .Section(i).Height * ScaleFactor * Extrascalar
Next i
On Error GoTo ErrorHandler
End If
For i = 0 To .Count – 1
Select Case .Controls(i).ControlType
Case acSubform
.Controls(i).Width = D(i, 0) * ScaleFactor * Extrascalar
.Controls(i).Height = D(i, 1) * ScaleFactor * Extrascalar
.Controls(i).Left = D(i, 2) * ScaleFactor * Extrascalar
.Controls(i).Top = D(i, 3) * ScaleFactor * Extrascalar
End Select
Next i
For i = 0 To .Count – 1
Select Case .Controls(i).ControlType
Case acOptionGroup, acTabCtl
.Controls(i).Left = D(i, 2) * ScaleFactor * Extrascalar
.Controls(i).Top = D(i, 3) * ScaleFactor * Extrascalar
.Controls(i).Width = D(i, 0) * ScaleFactor * Extrascalar
.Controls(i).Height = D(i, 1) * ScaleFactor * Extrascalar
End Select
Next i
‘Resize form dimensions and fit window to form
On Error Resume Next
For i = 0 To 4
.Section(i).Height = 0
Next i
On Error GoTo ErrorHandler
.Width = 0
DoCmd.RunCommand acCmdSizeToFitForm
GoTo Done
ErrorHandler:
If Err.Number 2046 Then ‘6/8/99
MsgBox “Error with control ” & .Controls(i).Name & vbCrLf & _
“L: ” & .Controls(i).Left & ” – ” & D(i, 2) & vbCrLf & _
“T: ” & .Controls(i).Top & ” – ” & D(i, 3) & vbCrLf & _
“W: ” & .Controls(i).Width & ” – ” & D(i, 0) & vbCrLf & _
“H: ” & .Controls(i).Height & ” – ” & D(i, 1) & vbCrLf
End If
GoTo Done
Done:
Exit Sub
End With
End Sub
Public Function dbcReSize(xForm As Form)
‘This subroutine will resize the form based on it’s current dimensions
Dim ActiveForm As Object
Dim strTag As String
Dim SH As Single
Dim SW As Single
On Error GoTo ErrorHandler
Set ActiveForm = xForm
‘If form in datasheet view then don’t resize
If xForm.CurrentView 1 Then GoTo Done
‘If the form is maximized then don’t resize
If IsZoomed(xForm.hWnd) 0 Then GoTo Done
‘If the form is minimized then don’t resize
If IsIconic(xForm.hWnd) 0 Then GoTo Done
With ActiveForm
If .tag = “Sizing” Then GoTo Done
strTag = .tag
.tag = “Sizing”
‘Determine size of window and set resize based on lowest proportion
SH = .WindowHeight / .Section(0).Height
SW = .WindowWidth / .Width
If SH > SW Then
SizeForm xForm, SW
Else
SizeForm xForm, SH
End If
.Width = 0
On Error Resume Next
.tag = strTag
GoTo Done
ErrorHandler:
MsgBox Err.Description
Done:
DoCmd.Echo True
End With
End Function
Function GetScreenRes() As String
Dim R As Rect
Dim hWnd As Long
Dim RetVal As Long
hWnd = GetDesktopWindow()
RetVal = GetWindowRect(hWnd, R)
GetScreenRes = (R.x2 – R.x1) & “x” & (R.y2 – R.y1)
End Function
Public Function GetScaleFactor(s) As Single
Select Case s
Case 0 ‘640 x 480
Select Case GetScreenRes
Case “640×480”
GetScaleFactor = 1
Case “800×600”
GetScaleFactor = 1.2
Case “1024×768”
GetScaleFactor = 1.5
Case “1280×1024”
GetScaleFactor = 1.9
Case “1600×1200”
GetScaleFactor = 2.4
End Select
Case -1 ‘800 x 600
Select Case GetScreenRes
Case “640×480”
GetScaleFactor = 0.8
Case “800×600”
GetScaleFactor = 1
Case “1024×768”
GetScaleFactor = 1.2
Case “1280×1024”
GetScaleFactor = 1.5
Case “1600×1200”
GetScaleFactor = 1.9
End Select
Case -2 ‘1024 x 768
Select Case GetScreenRes
Case “640×480”
GetScaleFactor = 0.6
Case “800×600”
GetScaleFactor = 0.7
Case “1024×768”
GetScaleFactor = 1
Case “1280×1024”
GetScaleFactor = 1.1
Case “1600×1200”
GetScaleFactor = 0.5
End Select
Case -3 ‘1280 x 1024
Select Case GetScreenRes
Case “640×480”
GetScaleFactor = 0.5
Case “800×600”
GetScaleFactor = 0.6
Case “1024×768”
GetScaleFactor = 0.8
Case “1280×1024”
GetScaleFactor = 1
Case “1600×1200”
GetScaleFactor = 1.1
End Select
Case -4 ‘1600 x 1200
Select Case GetScreenRes
Case “640×480”
GetScaleFactor = 0.3
Case “800×600”
GetScaleFactor = 0.4
Case “1024×768”
GetScaleFactor = 0.6
Case “1280×1024”
GetScaleFactor = 0.7
Case “1600×1200”
GetScaleFactor = 1
End Select
End Select
If LargeFonts Then GetScaleFactor = GetScaleFactor / 1.25
End Function
Public Function LargeFonts() As Boolean
Dim hdc, hWnd, PrevMapMode As Long
Dim tm As TEXTMETRIC
‘Get the handle of the desktop window
hWnd = GetDesktopWindow()
‘Get the device context for the desktop
hdc = GetWindowDC(hWnd)
If hdc Then ‘ Set the mapping mode to pixels
PrevMapMode = SetMapMode(hdc, MM_TEXT)
‘Get the size of the system font
GetTextMetrics hdc, tm
‘Set the mapping mode back to what it was
PrevMapMode = SetMapMode(hdc, PrevMapMode)
‘Release the device context
ReleaseDC hWnd, hdc
‘If the system font is more than 16 pixels high, then large fonts are being used
If tm.tmHeight > 16 Then LargeFonts = True Else LargeFonts = False
End If
End Function
Function GetFormSize(hWnd As Long) As String
Dim R As Rect
Dim RetVal As Long
RetVal = GetWindowRect(hWnd, R)
MsgBox R.x1 & “, ” & R.x2 & “, ” & R.y1 & “, ” & R.y2
End Function
