public_resizeform.bas

企业的进销存源码

Attribute VB_Name = "Public_ReSizeForm"
'QQ:75347626
'MSN:[e-mail]
'本段代码是网上其他网友提供的

Option Explicit

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 Const WM_NCLBUTTONDOWN = &HA1
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ReleaseCapture Lib "USER32" () As Long

Function ActualPos(plLeft As Long) As Long


              If plLeft < 0 Then
                     ActualPos = plLeft + 75000
              Else
                     ActualPos = plLeft
              End If

End Function


Function FindForm(pfrmIn As Form) 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


Function AddForm(pfrmIn As Form) 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)
                                                                                                                              End If

                                                                                                                Next FormControl

                                                                                                  End Function


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


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


Function PerWidth(pfrmIn As Form) As Long

       Dim I As Long
       I = FindForm(pfrmIn)

              If I < 0 Then
                     I = AddForm(pfrmIn)
              End If

       PerWidth = (pfrmIn.ScaleWidth * 100) \ FormRecord(I).ScaleWidth
End Function


Function PerHeight(pfrmIn As Form) As Double

       Dim I As Long
       I = FindForm(pfrmIn)

              If I < 0 Then
                     I = AddForm(pfrmIn)
              End If

       PerHeight = (pfrmIn.ScaleHeight * 100) \ FormRecord(I).ScaleHeight
End Function


Public Sub ResizeControl(inControl As Control, pfrmIn As Form)

       On Error Resume Next
       Dim I As Long
       Dim widthfactor As Single, heightfactor As Single
       Dim minFactor As Single
       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