Vom Internet kopierte Resize-Funktion ändern

D

DrMueller

Erfahrenes Mitglied
Hallo Leute mal wieder,
fröhliches neues Jahr wünsche ich Euch allen. Seit gestern wieder angefangen zu arbeiten und wieder ein übles Problem, bei dem ich kein Plan habe, was ich machen könnte:

Code: 
Option Explicit

Private Type Rect
     WidthP As Single
     HeigthP As Single
     TopP As Single
     LeftP As Single
End Type

Private Type ControlInfo
     Cont As Control
     measures As Rect
End Type

Dim fForm As Form
Dim AllControls() As ControlInfo
Dim bNoSaveInSettings As Boolean
Dim iFormMindestHoehe As Integer
Dim iFormMindestBreite As Integer

Private Const REGISTRY_APPLICATION_NAME As String = "Dowar"
Private Const REGISTRY_FENSTER_NAME As String = "DowarFenster "

Public Property Let Form(f As Object)
  Set fForm = f
  Call GetAllPositions
End Property

Public Property Set setForm(f As Object)
  Set fForm = f
  Call GetAllPositions
End Property

Public Property Get Form() As Object
  Set Form = fForm
End Property

Public Property Let formMindestHoehe(value As Integer)
  iFormMindestHoehe = value
End Property

Public Property Let formMindestBreite(value As Integer)
  iFormMindestBreite = value
End Property

Public Sub Resize()
  Dim SW As Single
  Dim SH As Single
  Dim i As Integer
  
  On Error Resume Next
  
  If Me.Form.Height < iFormMindestHoehe Then
    Me.Form.Top = GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Top")
    Me.Form.Height = iFormMindestHoehe
  End If

  If Me.Form.Width < iFormMindestBreite Then
    Me.Form.Left = GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Left")
    Me.Form.Width = iFormMindestBreite
  End If
  
  SW = Me.Form.ScaleWidth
  SH = Me.Form.ScaleHeight
  
  For i = 0 To UBound(AllControls)
    With AllControls(i)
      'Gebastel
      If .Cont.Name = "fraRegister" Then
        Dim iIndex As Integer
        iIndex = 0
        While Err.Number = 0
          .Cont.Index = 0
          .Cont.Left = (SW * .measures.LeftP) / 100
          .Cont.Top = (SH * .measures.TopP) / 100
          .Cont.Width = (SW * .measures.WidthP) / 100
          .Cont.Height = (SH * .measures.HeigthP) / 100
          iIndex = iIndex + 1
        Wend
        If Err.Number > 0 Then
          MsgBox Err.Description
          Err.Clear
        End If
      Else
      'Gebastel
        .Cont.Left = (SW * .measures.LeftP) / 100
        .Cont.Top = (SH * .measures.TopP) / 100
        .Cont.Width = (SW * .measures.WidthP) / 100
        .Cont.Height = (SH * .measures.HeigthP) / 100
      End If
    End With
  Next i
  
  Call saveAktuelleWerteInRegistry
  
  If Err.Number > 0 Then
    OutputDebugString "Funktion Resize Fehler: " & Err.Description
  End If
End Sub

Private Sub GetAllPositions()
    Dim c As Control
    Dim i As Integer
    Dim iFraRegister As Integer
    
    On Error Resume Next

    For Each c In Me.Form.Controls
        If Not (TypeOf c Is ImageList) Then
          Call AddControl(c, c.Left, c.Top, c.Width, c.Height)
        End If

    Next c
    iFraRegister = 0
'    If Err.Number > 0 Then
'      OutputDebugString "PAV: getallPositions : " & Err.Description
'    End If
End Sub

Private Sub AddControl(ByRef Cont As Control, ByVal X As Single, _
ByVal Y As Single, ByVal W As Single, ByVal H As Single)
     Dim pos As Integer
     On Error Resume Next
     pos = UBound(AllControls) + 1
     If Err Then pos = 0
     On Error GoTo 0
     
     ReDim Preserve AllControls(pos)
     
     Dim SW As Single
     Dim SH As Single
     SW = Me.Form.ScaleWidth
     SH = Me.Form.ScaleHeight

     With AllControls(pos)
          Set .Cont = Cont
          With .measures
               .LeftP = (X * 100) / SW
               .TopP = (Y * 100) / SH
               .WidthP = (W * 100) / SW
               .HeigthP = (H * 100) / SH
          End With
     End With
     
    If Err.Number > 0 Then
      OutputDebugString "Funktion AddControl. Fehler: " & Err.Description
    End If
End Sub

Private Sub saveAktuelleWerteInRegistry()
  If bNoSaveInSettings = False Then
    SaveSetting REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Left", Me.Form.Left
    SaveSetting REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Top", Me.Form.Top
    SaveSetting REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Breite", Me.Form.Width
    SaveSetting REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Hoehe", Me.Form.Height
  End If
End Sub

Public Sub setFormProportionen()
  On Error Resume Next
  Dim b As Boolean 'Hilfsvariable
  
  bNoSaveInSettings = True
  Me.Form.Left = GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Left")
  Me.Form.Top = GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Top")
  Me.Form.Width = GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Breite")
  Me.Form.Height = GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Hoehe")
  
  If Me.Form.Left <= 0 Or Me.Form.Top <= 0 Then
    Call putFensterinMiddle
    b = False
  Else
    b = True
  End If
  
  If b Then
    If Len(GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Breite")) = 0 And Len(GetSetting(REGISTRY_APPLICATION_NAME, REGISTRY_FENSTER_NAME & Me.Form.Name, "Hoehe")) = 0 Then
      OutputDebugString "Automatische Fensterausrichtung in Mitte"
      Call putFensterinMiddle
    End If
  Else
    MsgBox "Das Fenster wurde automatisch in die Mitte ausgerichtet.", vbInformation, "Automatische Ausrichtung"
  End If
  
  bNoSaveInSettings = False
  If Err.Number > 0 Then
    OutputDebugString Err.Description
  End If
End Sub
  
'####################################################################################
'#   Description: Stellt ein beliebiges Fenster in die Mitte.
'#                Oder verkleinert es.
'#
'#   Author:  Müller Matthias
'#   Datum:   25.07.06
'#   Version: 1.0
'#   Changes:
'####################################################################################
Private Sub putFensterinMiddle()
  Dim iScreenBreite As Integer
  Dim iScreenHoehe As Integer
  Dim iFensterBreite As Integer
  Dim iFensterHoehe As Integer
  Dim iFensterTop As Integer
  Dim iFensterLeft As Integer

  On Error GoTo errhnd:

  iScreenBreite = Screen.Width
  iScreenHoehe = Screen.Height

  iFensterBreite = Me.Form.Width
  iFensterHoehe = Me.Form.Height


  iFensterLeft = iScreenBreite / 2
  iFensterLeft = iFensterLeft - (iFensterBreite / 2)

  iFensterTop = iScreenHoehe / 2
  iFensterTop = iFensterTop - (iFensterHoehe / 2)

  Me.Form.Top = iFensterTop
  Me.Form.Left = iFensterLeft

Exit Sub
errhnd:
  OutputDebugString "Fehler putFensterinMiddle: " & Err.Description
End Sub


Dies ist eine Funktion, die 9ich zu drei Viertel vom Internet kopiert, und zu einem Viertel angepasst habe. Meine Anpassungen betreffen das Speichern in und Lesen aus der Registry, sowie das Mitgeben eines Mindestwertes, der nicht überschrieben werden darf.

Dies funktioniert toll, doch jetzt kommt folgendes Problem: Mein ehrenwerter Vorgängerprogrammierer hat es nicht für nötig befunden, den Registerframes, namentlich "fraRegister", eigenständige Namen zu geben, sondern einfach nur diese mittels Index zu unterscheiden.

Jetzt erkennt das Programm natürlich EIN fraRegister aber jedoch nicht alle.

Ich habe versucht einfach mal was zu basteln, was ich im Code mit "Gebastel" tituliert habe. Natürlich kann ich den Indexwert nicht einfach ändern, aber hat jemand eine Idee wie ich diesen ansprechen und die einzelnen Registerframes speichern und dann auch wieder auslesen kann?
 
Um antworten zu können musst du eingeloggt sein.

Neue Beiträge

Zurück