17 Agustus 2012

Buat sebuah form dan sebuah module
Pada module, beri nama dengan Resize, dan masukkan code ini pada module ..



Public Type ctrObj
  Name As String
  Index As Long
  Parrent As String
  Top As Long
  Left As Long
  Height As Long
  Width As Long
  ScaleHeight As Long
  ScaleWidth As Long
End Type

Private FormRecord() As ctrObj
Private ControlRecord() As ctrObj
Private bRunning As Boolean
Private MaxForm As Long
Private MaxControl As Long

Private Function ActualPos(plLeft As Long) As Long
  If plLeft < 0 Then
    ActualPos = plLeft + 75000
  Else
    ActualPos = plLeft
  End If
End Function

Private Function FindForm(pfrmIn As Object) As Long
  Dim i As Long
 
  FindForm = -1
  If MaxForm > 0 Then
    For i = 0 To (MaxForm - 1)
      If FormRecord(i).Name = pfrmIn.Name Then
        FindForm = i
        Exit Function
      End If
    Next i
  End If
End Function


Private Function AddForm(pfrmIn As Object) As Long
  Dim FormControl As Control
  Dim i As Long
  ReDim Preserve FormRecord(MaxForm + 1)

  FormRecord(MaxForm).Name = pfrmIn.Name
  FormRecord(MaxForm).Top = pfrmIn.Top
  FormRecord(MaxForm).Left = pfrmIn.Left
  FormRecord(MaxForm).Height = pfrmIn.Height
  FormRecord(MaxForm).Width = pfrmIn.Width
  FormRecord(MaxForm).ScaleHeight = pfrmIn.ScaleHeight

  FormRecord(MaxForm).ScaleWidth = pfrmIn.ScaleWidth
  AddForm = MaxForm
  MaxForm = MaxForm + 1

  For Each FormControl In pfrmIn
    i = FindControl(FormControl, pfrmIn.Name)
    If i < 0 Then i = AddControl(FormControl, pfrmIn.Name)
  Next FormControl
End Function

Private Function FindControl(inControl As Control, inName As String) As Long
  Dim i As Long
 
  FindControl = -1
  For i = 0 To (MaxControl - 1)
    If ControlRecord(i).Parrent = inName Then
      If ControlRecord(i).Name = inControl.Name Then
        On Error Resume Next
       
        If ControlRecord(i).Index = inControl.Index Then
          FindControl = i
          Exit Function
        End If
        On Error GoTo 0
     
      End If
    End If
  Next i
End Function

Private Function AddControl(inControl As Control, inName As String) As Long
  ReDim Preserve ControlRecord(MaxControl + 1)
  On Error Resume Next
 
  ControlRecord(MaxControl).Name = inControl.Name
  ControlRecord(MaxControl).Index = inControl.Index
  ControlRecord(MaxControl).Parrent = inName

  If TypeOf inControl Is Line Then
    ControlRecord(MaxControl).Top = inControl.Y1
    ControlRecord(MaxControl).Left = ActualPos(inControl.X1)
    ControlRecord(MaxControl).Height = inControl.Y2
    ControlRecord(MaxControl).Width = ActualPos(inControl.X2)
  Else
    ControlRecord(MaxControl).Top = inControl.Top
    ControlRecord(MaxControl).Left = ActualPos(inControl.Left)
    ControlRecord(MaxControl).Height = inControl.Height
    ControlRecord(MaxControl).Width = inControl.Width
  End If

  inControl.IntegralHeight = False
 
  On Error GoTo 0
  AddControl = MaxControl
  MaxControl = MaxControl + 1
End Function

Private Function PerWidth(pfrmIn As Object) As Long
  Dim i As Long
 
  i = FindForm(pfrmIn)
  If i < 0 Then i = AddForm(pfrmIn)
 
  PerWidth = (pfrmIn.ScaleWidth * 100) \ FormRecord(i).ScaleWidth
End Function

Private Function PerHeight(pfrmIn As Object) As Single
  Dim i As Long
 
  i = FindForm(pfrmIn)
  If i < 0 Then i = AddForm(pfrmIn)
 
  PerHeight = (pfrmIn.ScaleHeight * 100) \ FormRecord(i).ScaleHeight
End Function

Private Sub ResizeControl(inControl As Control, pfrmIn As Object)
  On Error Resume Next
  Dim i As Long
   Dim yRatio, xRatio, lTop, lLeft, lWidth, lHeight As Long
 
  yRatio = PerHeight(pfrmIn)
  xRatio = PerWidth(pfrmIn)
  i = FindControl(inControl, pfrmIn.Name)

  If inControl.Left < 0 Then
    lLeft = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
  Else
    lLeft = CLng((ControlRecord(i).Left * xRatio) \ 100)
  End If

  lTop = CLng((ControlRecord(i).Top * yRatio) \ 100)
  lWidth = CLng((ControlRecord(i).Width * xRatio) \ 100)
  lHeight = CLng((ControlRecord(i).Height * yRatio) \ 100)
 
  If TypeOf inControl Is Line Then
    If inControl.X1 < 0 Then
      inControl.X1 = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
    Else
      inControl.X1 = CLng((ControlRecord(i).Left * xRatio) \ 100)
    End If
   
    inControl.Y1 = CLng((ControlRecord(i).Top * yRatio) \ 100)
    If inControl.X2 < 0 Then
      inControl.X2 = CLng(((ControlRecord(i).Width * xRatio) \ 100) - 75000)
    Else
      inControl.X2 = CLng((ControlRecord(i).Width * xRatio) \ 100)
    End If

    inControl.Y2 = CLng((ControlRecord(i).Height * yRatio) \ 100)
  Else
    inControl.Move lLeft, lTop, lWidth, lHeight
    inControl.Move lLeft, lTop, lWidth
    inControl.Move lLeft, lTop
  End If
End Sub

Public Sub ResizeForm(pfrmIn As Object)
 
  Dim FormControl As Control
  Dim isVisible As Boolean
  Dim StartX, StartY, MaxX, MaxY As Long
  Dim bNew As Boolean
 
 
  If Not bRunning Then
    bRunning = True
   
     
   
    If FindForm(pfrmIn) < 0 Then
      bNew = True
    Else
      bNew = False
    End If

    If pfrmIn.Top < 30000 Then
      isVisible = pfrmIn.Visible
      On Error Resume Next
     
      If Not pfrmIn.MDIChild Then
        On Error GoTo 0
        'pfrmIn.Visible = False
       
      Else
        If bNew Then
          StartY = pfrmIn.Height
          StartX = pfrmIn.Width
          On Error Resume Next

         
          For Each FormControl In pfrmIn
            If FormControl.Left + FormControl.Width + 200 > MaxX Then _
              MaxX = FormControl.Left + FormControl.Width + 200
            If Xctrl.Top + FormControl.Height + 500 > MaxY Then _
              MaxY = FormControl.Top + FormControl.Height + 500
            If FormControl.X1 + 200 > MaxX Then _
              MaxX = FormControl.X1 + 200
            If FormControl.Y1 + 500 > MaxY Then _
              MaxY = FormControl.Y1 + 500
            If FormControl.X2 + 200 > MaxX Then _
              MaxX = FormControl.X2 + 200
            If FormControl.Y2 + 500 > MaxY Then _
              MaxY = FormControl.Y2 + 500

             
          Next FormControl
          On Error GoTo 0
         
          pfrmIn.Height = MaxY
          pfrmIn.Width = MaxX
        End If
        On Error GoTo 0

      End If
     
      For Each FormControl In pfrmIn
        ResizeControl FormControl, pfrmIn
                    
      Next FormControl
      On Error Resume Next

      If Not pfrmIn.MDIChild Then
        On Error GoTo 0
        pfrmIn.Visible = isVisible
      Else
        If bNew Then
          pfrmIn.Height = StartY
          pfrmIn.Width = StartX
         
          For Each FormControl In pfrmIn
            ResizeControl FormControl, pfrmIn
          Next FormControl
        End If
      End If
      On Error GoTo 0
     
    End If
    bRunning = False
  End If
  EventActive = False
End Sub

Public Sub SaveFormPosition(pfrmIn As Object)
  Dim i As Long

  If MaxForm > 0 Then
    For i = 0 To (MaxForm - 1)
      If FormRecord(i).Name = pfrmIn.Name Then
        FormRecord(i).Top = pfrmIn.Top
        FormRecord(i).Left = pfrmIn.Left
        FormRecord(i).Height = pfrmIn.Height
        FormRecord(i).Width = pfrmIn.Width
        Exit Sub
      End If
    Next i
    AddForm (pfrmIn)
  End If
End Sub

Public Sub RestoreFormPosition(pfrmIn As Object)
  Dim i As Long

  If MaxForm > 0 Then
    For i = 0 To (MaxForm - 1)
      If FormRecord(i).Name = pfrmIn.Name Then
        If FormRecord(i).Top < 0 Then
          pfrmIn.WindowState = 2
        ElseIf FormRecord(i).Top < 30000 Then
          pfrmIn.WindowState = 0
          pfrmIn.Move FormRecord(i).Left, FormRecord(i).Top, FormRecord(i).Width, FormRecord(i).Height
        Else
          pfrmIn.WindowState = 1
        End If
        Exit Sub
      End If
    Next i
  End If
End Sub



Dan pada form masukkan ini di form Resizenya :

Call ResizeForm(me)
Gampangkan ..
Semoga bermanfaat ...

4 komentar:

  1. Kalo Untuk Memperbesar Semua Objek Kalo di Maximize Gimana Mas???

    BalasHapus
  2. Call nya di Form_Resize ny om

    BalasHapus
  3. mengapa hasilnya menjadi kacau saat form berada di dalam MDI Form, jika form bukan MDI Child baru bisa dipakai Functionnya... mohon penjelasan atau arahan jika form adalah MDIChild, bagaimana cara penggunaannya.

    BalasHapus

Syarat dan Ketentuan Berkomentar :
- Jangan memasang Link Aktif
- Jangan meniggalkan Spam, karena sangat menggangu
- Tidak diperbolehkan menggunakan 'Anonymous', gunakanlah Name/Url atau Akun Anda
- Jangan menggunakan username yang tidak layak.
- Jangan menulis kata-kata yang tidak layak, tidak etis secara moral, SARA dll.

Peraturan bisa berubah setiap saat.
Terima Kasih