Results 1 to 2 of 2
  1. #1
    MrLuvigz
    Guest

    Re: Access Resizing

    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 = "640x480" 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 < 0 Then .Controls(i).Left = 0
    .Controls(i).Left = .Controls(i).Left * ScaleFactor * Extrascalar
    .Controls(i).Top = .Controls(i).Top * ScaleFactor * Extrascalar
    .Controls(i).Height = .Controls(i).Height * ScaleFactor * Extrascalar
    .Controls(i).Width = .Controls(i).Width * ScaleFactor * Extrascalar
    .Controls(i).fontsize = .Controls(i).fontsize * ScaleFactor * Extrascalar
    On Error GoTo ErrorHandler
    End Select
    Next i
    'fix dimensions of subforms/groups/tabs
    If ScaleFactor > 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 "640x480"
    GetScaleFactor = 1
    Case "800x600"
    GetScaleFactor = 1.2
    Case "1024x768"
    GetScaleFactor = 1.5
    Case "1280x1024"
    GetScaleFactor = 1.9
    Case "1600x1200"
    GetScaleFactor = 2.4
    End Select
    Case -1 '800 x 600
    Select Case GetScreenRes
    Case "640x480"
    GetScaleFactor = 0.8
    Case "800x600"
    GetScaleFactor = 1
    Case "1024x768"
    GetScaleFactor = 1.2
    Case "1280x1024"
    GetScaleFactor = 1.5
    Case "1600x1200"
    GetScaleFactor = 1.9
    End Select
    Case -2 '1024 x 768
    Select Case GetScreenRes
    Case "640x480"
    GetScaleFactor = 0.6
    Case "800x600"
    GetScaleFactor = 0.7
    Case "1024x768"
    GetScaleFactor = 1
    Case "1280x1024"
    GetScaleFactor = 1.1
    Case "1600x1200"
    GetScaleFactor = 0.5
    End Select
    Case -3 '1280 x 1024
    Select Case GetScreenRes
    Case "640x480"
    GetScaleFactor = 0.5
    Case "800x600"
    GetScaleFactor = 0.6
    Case "1024x768"
    GetScaleFactor = 0.8
    Case "1280x1024"
    GetScaleFactor = 1
    Case "1600x1200"
    GetScaleFactor = 1.1
    End Select
    Case -4 '1600 x 1200
    Select Case GetScreenRes
    Case "640x480"
    GetScaleFactor = 0.3
    Case "800x600"
    GetScaleFactor = 0.4
    Case "1024x768"
    GetScaleFactor = 0.6
    Case "1280x1024"
    GetScaleFactor = 0.7
    Case "1600x1200"
    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

  2. #2
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts

    Re: Access Resizing

    Hi,
    First a confession - I didn't read through all your code![img]/w3timages/icons/grin.gif[/img]
    However, you have declared extrascalar to be an integer, so if you set it to 1.5 it will round up to 2 but any value between 0.5 and 1.5 will evaluate to 1 (except 0.5 which for some reason seems to evaluate to 0) so as a factor it won't make any difference.
    Does this help? (If not, please repost and I'll try working through the whole thing...)
    Regards,
    Rory

    Microsoft MVP - Excel

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •