osen xp form.ctl

用vb编写的工程控制程序

            Set XP_Name = oCtl
          ElseIf TypeOf oCtl Is Menu Then 'NOT TYPEOF...
            If UCase$(oCtl.Tag) = "MAINMENU" Then
                pICmenu.Visible = True
                i = i + 1
                Load LbMenu(i)
                ReDim Preserve MyMainMenu(i)
                Set MyMainMenu(i) = oCtl
                
                With LbMenu(i)
                
                    .Caption = oCtl.Caption
                    .BackColor = pICmenu.BackColor
                    .Visible = True
                    .Enabled = oCtl.Enabled
                    .Top = 45
                    
                    If i = 1 Then
                        .Left = 60
                      Else 'NOT I...
                        .Left = LbMenu(i - 1).Width + LbMenu(i - 1).Left
                    End If
                
                End With 'LBMENU(I)
                oCtl.Visible = False
                MenuCOUNT = i
            End If
        End If
    Next oCtl
    If i <> 0 Then Load LbMenu(100) ':(燛xpand Structure
    '/Setting size
    IpForm.Width = XP_Name.Width
    IpForm.Height = XP_Name.Height

    If IpForm.BorderStyle <> 0 Then
        IpForm.Height = XP_Name.Height + 375
    End If

    If IpForm.BorderStyle <> 2 Then
        ShowMaximize = False
        ShowMinimize = False
    End If

    If Not MyForm.MaxButton Then EnableMaximize = False ':(燛xpand Structure

    If IpForm.BorderStyle = 1 Then

        If IpForm.MinButton Then

            ShowMinimize = True
            ShowMaximize = True
            EnableMaximize = False

        End If

    End If

    PicMain.Visible = HaveChild

    '*************** Set FORM Style *************************
    If IpForm.BorderStyle <> 0 Then SetStyle IpForm ':(燛xpand Structure

    XP_Name.Width = IpForm.Width
    XP_Name.Height = IpForm.Height

    '/**************** Set Transparant ************************
    ReTransObj IpForm
    SetCursorPos (MyForm.Left + MyForm.Width) / 15, (MyForm.Top / 15)
    DoEvents

    If Not OwnForm Is Nothing Then
        IpForm.Visible = False
        DoEvents
        IpForm.Show OptModal, OwnForm
        Exit Sub '>---> Bottom
      Else 'NOT NOT...
        If OptModal = 1 Or IpModal = 1 Then
            IpForm.Visible = False
            DoEvents
            IpForm.Show 1
        End If
    End If

Exit Sub

Z:
    MyForm.Show

End Sub

Public Sub MaxBtnClick()

    MaximizeButton_Click

End Sub

Private Sub MaximizeButton_Click()

    On Error GoTo xc
    If Not MyForm Is Nothing Then
        If MyForm.WindowState = 0 Then
            MyForm.WindowState = 2
          Else 'NOT MYFORM.WINDOWSTATE...
            MyForm.WindowState = 0
        End If
        DoEvents
        UserControl.Width = MyForm.Width
        UserControl.Height = MyForm.Height
        ReTransObj MyForm
        Repos
    End If
xc:
End Sub
Public Property Get MenuBackColor() As OLE_COLOR
Attribute MenuBackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."

    MenuBackColor = pICmenu.BackColor

End Property

Public Property Let MenuBackColor(ByVal New_MenuBackColor As OLE_COLOR)

    pICmenu.BackColor() = New_MenuBackColor
    PropertyChanged "MenuBackColor"

End Property

Private Sub MinimizeButton_Click()
    If Not MyForm Is Nothing Then
        MyForm.WindowState = 1
    End If
End Sub

Private Sub MYFORM_Activate()

    SetFormActiveStyle True

End Sub

Private Sub MYFORM_Deactivate()

    SetFormActiveStyle False

End Sub

Private Sub MyForm_Resize()
    If MyForm.WindowState = 2 Then
        MaximizeButton.ButtonStyle = RestoreButton
    Else
        MaximizeButton.ButtonStyle = MaxButton
    End If
End Sub

Private Sub PicMain_Click()

    RaiseEvent Click

End Sub

Private Sub PicMain_DblClick()

    RaiseEvent DblClick

End Sub

Private Sub PicMain_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    RaiseEvent MouseDown(Button, Shift, X, Y)

End Sub

Private Sub PicMain_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    RaiseEvent MouseMove(Button, Shift, X, Y)


End Sub

Private Sub pICmenu_Resize()

    Line1.X1 = 0
    Line2.X1 = 0
    Line1.X2 = pICmenu.Width * 15
    Line2.X2 = pICmenu.Width * 15
    Line1.Refresh
    Line2.Refresh

End Sub

Public Property Set Picture(ByVal New_Picture As Picture)
Attribute Picture.VB_Description = "Returns/sets a graphic to be displayed in a control."

    Set PicMain.Picture = New_Picture
    PropertyChanged "Picture"

End Property

Public Property Get Picture() As Picture

    Set Picture = PicMain.Picture

End Property

Public Sub Repos()

  'This repositions the different controls on the form when it is resized
  Dim X As Single ':(燤ove line to top of current Sub
  Dim Y As Single ':(燤ove line to top of current Sub

    If UserControl.Height < 615 Then UserControl.Height = 615   'Checks that form':(燛xpand Structure
    If UserControl.Width < 1695 Then UserControl.Width = 1695   'is not too small':(燛xpand Structure

    X = UserControl.Width / Screen.TwipsPerPixelX   'Registers the size of the
    Y = UserControl.Height / Screen.TwipsPerPixelY  'form in pixels

    'Titlebar
    With TitleLeft
        .Left = 0
        .Top = 0
        .Height = 30
    End With 'TITLELEFT

    With Title
        .Height = 30
        .Left = TitleLeft.Width
        .Top = 0
        .Width = X - TitleLeft.Width - TitleRight.Width
        pICmenu.Top = .Top + .Height
    End With 'TITLE

    With TitleRight
        .Left = Title.Left + Title.Width
        .Top = 0
        .Height = 30
    End With 'TITLERIGHT

    'Borders
    With BottomLeft
        .Left = 0
        .Height = 4
        .Top = Y - .Height
        .Width = 4
    End With 'BOTTOMLEFT

    With BottomRight
        .Height = 4
        .Width = 4
        .Left = X - .Width
        .Top = Y - .Height
    End With 'BOTTOMRIGHT

    With Left
        .Left = 0
        .Width = 4
        .Top = TitleLeft.Top + TitleLeft.Height
        .Height = BottomLeft.Top - .Top
    End With 'LEFT

    With Right
        .Width = 4
        .Left = X - .Width
        .Top = TitleRight.Top + TitleRight.Height
        .Height = BottomRight.Top - .Top
    End With 'RIGHT

    With Bottom
        .Height = 4
        .Left = BottomLeft.Width
        .Top = Y - Bottom.Height
        .Width = X - BottomLeft.Width - BottomRight.Width
        pICmenu.Width = .Width
        pICmenu.Left = .Left
    End With 'BOTTOM

    'Buttons
    With CloseButton
        .Left = Right.Left - .Width - 2
        .Top = (Title.Height - .Height) / 2
    End With 'CLOSEBUTTON

    With MaximizeButton
        .Left = CloseButton.Left - .Width - 2
        .Top = (Title.Height - .Height) / 2
    End With 'MAXIMIZEBUTTON


    With Minimizebutton
        .Left = MaximizeButton.Left - .Width - 2
        .Top = (Title.Height - .Height) / 2
    End With 'MINIMIZEBUTTON

    'Icon
    With TitleIcon
        .Left = Left.Left + Left.Width + 2
        .Top = IconTop '(Title.Height - .Height) / 2
    End With 'TITLEICON

    'Titlebar Caption
    With Caption1
        If TitleIcon.Visible = True Then ':(燫emove Pleonasm
            .Left = TitleIcon.Left + TitleIcon.Width + 3
          Else 'NOT TITLEICON.VISIBLE...
            .Left = Left.Left + Left.Width + 2.5
        End If
        .Top = (((Title.Height - 13) / 2) - 9) + Caption1.FontSize + m_TitleTop
        .Width = Minimizebutton.Left - TitleIcon.Left - TitleIcon.Width - 10
        If Minimizebutton.Visible = False Then
            .Width = MaximizeButton.Left - TitleIcon.Left - TitleIcon.Width - 10
        End If
        If Minimizebutton.Visible = False And TitleIcon.Visible = False Then
            .Width = MaximizeButton.Left - Left.Left - Left.Width - 10
        End If
        If Minimizebutton.Visible = False And MaximizeButton.Visible = False Then
            .Width = CloseButton.Left - TitleIcon.Left - TitleIcon.Width - 10
        End If
        If Minimizebutton.Visible = False And MaximizeButton.Visible = False And TitleIcon.Visible = False Then
            .Width = CloseButton.Left - Left.Left - Left.Width - 10
        End If
        .AutoSize = True
    End With 'CAPTION1

    With Caption2
        .Left = Caption1.Left - 1
        .Top = Caption1.Top - 1
        .Width = Caption1.Width
        .Caption = Caption1.Caption
        .Width = Caption1.Width
    End With 'CAPTION2

    'Checks if it should have transparent corners
    If bTransparent = True Then ':(燫emove Pleonasm
        ReTrans
    End If
    
    Minimizebutton.RefreshControl
    MaximizeButton.RefreshControl
    CloseButton.RefreshControl
    
    SetFormActiveStyle True
    
    If pICmenu.Visible Then

        RaiseEvent Resize(450 + (pICmenu.Height * 15), UserControl.Height - 510 - (pICmenu.Height * 15), UserControl.Width - 120)
        PicMain.Top = pICmenu.Height + 30

      Else 'PICMENU.VISIBLE = FALSE/0

        RaiseEvent Resize(450, UserControl.Height - 510, UserControl.Width - 120)
        PicMain.Top = 30

    End If

End Sub

Private Sub ResizeForm(frm As Form, Oldcp As POINTAPI, Newcp As POINTAPI, ResizeMode As Integer)

    On Error Resume Next
      Dim DifferenceX ':(燗s Variant ?':(燤ove line to top of current Sub
      Dim DifferenceY ':(燗s Variant ?':(燤ove line to top of current Sub
        DifferenceX = (Newcp.X - Oldcp.X) * Screen.TwipsPerPixelX
        DifferenceY = (Newcp.Y - Oldcp.Y) * Screen.TwipsPerPixelY
        Select Case ResizeMode
          Case 0
            frm.Move frm.Left + DifferenceX, frm.Top, frm.Width - DifferenceX, frm.Height
          Case 1
            frm.Move frm.Left, frm.Top, frm.Width + DifferenceX, frm.Height
          Case 2
            frm.Move frm.Left, frm.Top + DifferenceY, frm.Width, frm.Height - DifferenceY
          Case 3
            frm.Move frm.Left, frm.Top, frm.Width, frm.Height + DifferenceY
          Case 4
            frm.Move frm.Left, frm.Top, frm.Width + DifferenceX, frm.Height + DifferenceY
          Case 5
            frm.Move frm.Left + DifferenceX, frm.Top, frm.Width - DifferenceX, frm.Height + DifferenceY
          Case 6
            frm.Move frm.Left, frm.Top + DifferenceY, frm.Width + DifferenceX, frm.Height - DifferenceY
          Case 7
            frm.Move frm.Left + DifferenceX, frm.Top + DifferenceY, frm.Width - DifferenceX, frm.Height - DifferenceY
        End Select

End Sub ':(燨n Error Resume still active

Private Sub ReTrans()

  Dim Add As Long
  Dim Sum As Long

  Dim X As Single
  Dim Y As Single

    If UserControl.Height < 615 Then UserControl.Height = 615   'Checks that form':(燛xpand Structure
    If UserControl.Width < 1695 Then UserControl.Width = 1695   'is not too small':(燛xpand Structure

    X = UserControl.Width / Screen.TwipsPerPixelX   'Registers the size of the
    Y = UserControl.Height / Screen.TwipsPerPixelY  'form in pixels

    Sum = CreateRectRgn(5, 0, X - 5, 1)
    CombineRgn Sum, Sum, CreateRectRgn(3, 1, X - 3, 2), 2
    CombineRgn Sum, Sum, CreateRectRgn(2, 2, X - 2, 3), 2
    CombineRgn Sum, Sum, CreateRectRgn(1, 3, X - 1, 4), 2
    CombineRgn Sum, Sum, CreateRectRgn(1, 4, X - 1, 5), 2
    CombineRgn Sum, Sum, CreateRectRgn(0, 5, X, Y), 2
    SetWindowRgn UserControl.ContainerHwnd, Sum, True   'Sets corners transparent

End Sub

Public Sub ReTransObj(IpObject As Object)

    On Error Resume Next
      Dim Add As Long ':(燤ove line to top of current Sub
      Dim Sum As Long ':(燤ove line to top of current Sub
      Dim X As Single ':(燤ove line to top of current Sub
      Dim Y As Single ':(燤ove line to top of current Sub
        If IpObject.Height < 615 Then IpObject.Height = 615   'Checks that form':(燛xpand Structure
        If IpObject.Width < 1695 Then IpObject.Width = 1695   'is not too small':(燛xpand Structure
        X = IpObject.Width / Screen.TwipsPerPixelX   'Registers the size of the
        Y = IpObject.Height / Screen.TwipsPerPixelY  'form in pixels
        Sum = CreateRectRgn(5, 0, X - 5, 1)
        CombineRgn Sum, Sum, CreateRectRgn(3, 1, X - 3, 2), 2
        CombineRgn Sum, Sum, CreateRectRgn(2, 2, X - 2, 3), 2
        CombineRgn Sum, Sum, CreateRectRgn(1, 3, X - 1, 4), 2
        CombineRgn Sum, Sum, CreateRectRgn(1, 4, X - 1, 5), 2
        CombineRgn Sum, Sum, CreateRectRgn(0, 5, X, Y), 2
        SetWindowRgn IpObject.hwnd, Sum, True   'Sets corners transparent

End Sub ':(燨n Error Resume still active