'***********************************
' ITALIANO
' ridimensionamento automatico dei controlli di una maschera
' autore: Alberto Marchi e-mail: a.marchi@libero.it
' a.marchi@tiscalinet.it
' a.marchi@infinito.it
' queste routine sono freeware.
'
' Per favore, speditemi tutti i consigli/bug che trovate,
' in modo che le routine diventino il piu' possibile 'perfette' :-)
'
' Modalita' d'uso
' Nell'evento Form_Open inserire questa riga:
' SetScale ME
' Nell'evento Form_Resize inserire questa riga:
' ReScale ME
'
' Modifiche
' 17-giugno-2000
' Corretta gestione larghezza colonne di una list box
' 18-giugno 2001 (1 anno dopo,per caso)
' Corretta ancora la gestione colonne di combo box e list box
' 29-settembre 2003
' Corretto un bug in chisura di alcune maschere.
'***********************************
' ENGLISH
' automatic resing of controls in a form
'
' author: Alberto Marchi e-mail: a.marchi@libero.it
' a.marchi@tiscalinet.it
' a.marchi@infinito.it
' this code is freeware
'
' Please, email me any bug/problem you encounter.
'
' Use:
' In the Form_Open event insert this line:
' SetScale ME
' In the OnResize event insert this line:
' ReScale ME
'***********************************


Option Explicit
Option Compare Database

Global width As Single
Global height As Single
Type Dati
   top As Single
   left As Single
   width As Single
   height As Single
   fontsize As Single
   columnsize As String
   listwidth As Single
End Type
Type Scheda
   name As String
   width As Single
   height As Single
   section_height(4) As Single ' altezza delle sezioni
   count As Integer ' numero di oggetti
   Info() As Dati ' contiene le informazioni sugli oggetti
End Type

Dim elenco() As Scheda
Global QuanteForm As Integer

Function SetScale(f As Form)
   Dim i As Integer
   Dim cont As Integer
   cont = 0
   While cont < QuanteForm
      If elenco(cont).name = f.name Then GoTo Modifica
      cont = cont + 1
   Wend
   cont = QuanteForm
   QuanteForm = QuanteForm + 1
   ReDim Preserve elenco(QuanteForm) As Scheda
Modifica:
   elenco(cont).name = f.name
   elenco(cont).width = f.InsideWidth
   elenco(cont).height = f.InsideHeight
   On Error Resume Next
   For i = 0 To 4
      elenco(cont).section_height(i) = f.Section(i).height
   Next
   On Error GoTo 0
   elenco(cont).count = f.count
   ReDim elenco(cont).Info(f.count) As Dati
   For i = 0 To f.count - 1
      On Error Resume Next
      elenco(cont).Info(i).top = f.Controls(i).top
      elenco(cont).Info(i).left = f.Controls(i).left
      elenco(cont).Info(i).width = f.Controls(i).width
      elenco(cont).Info(i).height = f.Controls(i).height
      elenco(cont).Info(i).fontsize = f.Controls(i).fontsize
      If f.Controls(i).ControlType = acListBox Or f.Controls(i).ControlType = acComboBox Then
         elenco(cont).Info(i).columnsize = f.Controls(i).ColumnWidths
      End If
      If f.Controls(i).ControlType = acComboBox Then
         elenco(cont).Info(i).listwidth = f.Controls(i).listwidth
      End If
      On Error GoTo 0
      If f.Controls(i).ControlType = acSubform Then
         SetScale f.Controls(i).Form
      End If
   Next i
End Function

Function Min(a As Single, b As Single) As Single
   If a < b Then Min = a Else Min = b
End Function

Function Rescale(f As Form)
   Dim c, i As Integer
   Dim ratiox, ratioy, ratio As Single
   i = 0
   While i < QuanteForm
      If elenco(i).name = f.name Then
         ratiox = f.InsideWidth / elenco(i).width
         ratioy = f.InsideHeight / elenco(i).height
         If ratiox < ratioy Then
            ratio = ratiox
            'f.InsideHeight = elenco(i).height * ratio
         Else
            'If (f.RowHeight <> -1) Then
            ratio = ratioy
            'Else
            ' ratio = ratiox
            'End If
            'f.InsideWidth = elenco(i).width * ratio
         End If
         If ratio < 0 Then ratio = 0
         If f.RowHeight <> -1 Then f.RowHeight = f.RowHeight * ratio
         On Error Resume Next
         For c = 0 To 4
            f.Section(c).height = elenco(i).section_height(c) * ratio
         Next c
         On Error GoTo 0
         For c = 0 To f.count - 1
            f.Controls(c).width = elenco(i).Info(c).width * ratio
            f.Controls(c).height = elenco(i).Info(c).height * ratio
            On Error Resume Next
            f.Controls(c).top = elenco(i).Info(c).top * ratio
            f.Controls(c).left = elenco(i).Info(c).left * ratio
            f.Controls(c).fontsize = elenco(i).Info(c).fontsize * ratio
            On Error GoTo 0
            If f.Controls(c).ControlType = acListBox Or f.Controls(c).ControlType = acComboBox Then
               If elenco(i).Info(c).columnsize <> "" Then
                  Dim tmp As String
                  Dim nuovo As String
                  Dim col As String
                  Dim pos As Integer
                  tmp = elenco(i).Info(c).columnsize & ";"
                  pos = InStr(1, tmp, ";")
                  nuovo = ""
                  While pos > 0
                     nuovo = nuovo & Format(Val(left(tmp, pos)) * ratio) & ";"
                     tmp = Right(tmp, Len(tmp) - pos)
                     pos = InStr(1, tmp, ";")
                  Wend
                  f.Controls(c).ColumnWidths = nuovo
               End If
            End If
            If f.Controls(c).ControlType = acComboBox Then
               f.Controls(c).listwidth = elenco(i).Info(c).listwidth * ratio
            End If
            If f.Controls(c).ControlType = acSubform Then
                On Error Resume Next
               Rescale f.Controls(c).Form
               On Error GoTo 0
            End If

         Next c
         Exit Function
      End If
      i = i + 1
   Wend
   Beep
   MsgBox ("Errore: inserire una chiamata a Setscale ME nella routine evento Su Apertura")
End Function