jscaption.ctl

复件 VB界面换肤 复件 VB界面换肤

            If JS_BORDERSTYLE <> FIXED Then
                BitBlt UserControl.hdc, UserControl.ScaleWidth - JS_MAX.Width - JS_ICONSPACE - JS_CLOSE.Width - JS_FROMRIGHT, JS_FROMTOP, JS_MAX.Width, JS_MAX.Height, JS_MAX.hdc, 0, 0, SRCCOPY '去掉此代码就少了最大化按纽
                BitBlt UserControl.hdc, UserControl.ScaleWidth - JS_MIN.Width - JS_ICONSPACE - JS_MAX.Width - JS_ICONSPACE - JS_CLOSE.Width - JS_FROMRIGHT, JS_FROMTOP, JS_MIN.Width, JS_MIN.Height, JS_MIN.hdc, 0, 0, SRCCOPY '去掉此代码就少了最小化按纽
            End If
        End If
        If JS_SHOWONTOP = True Then
            BitBlt UserControl.hdc, UserControl.ScaleWidth - JS_BONTOP.Width - JS_ICONSPACE - JS_MIN.Width - JS_ICONSPACE - JS_MAX.Width - JS_ICONSPACE - JS_CLOSE.Width - JS_FROMRIGHT, JS_FROMTOP, JS_BONTOP.Width, JS_BONTOP.Height, JS_BONTOP.hdc, 0, 0, SRCCOPY
        End If

        '
        'PLACE THE CAPTION
        '如果只是打印一个标题，就写以下代码
        'UserControl.CurrentX = JS_XOFFSET
        'UserControl.CurrentY = JS_YOFFSET
        '　UserControl.Print UserControl.Parent.Caption '打印窗体标签
        '否则就用标签，就会有立体感

        Set JS_TOPLEFT = Nothing
        Set JS_TOPMID = Nothing
        Set JS_TOPRIGHT = Nothing

    End If

    '最大化代码
    If UserControl.Parent.WindowState = 2 Then
        UserControl.Parent.WindowState = 0
        JS_BORDERSTYLE2 = dig1 '奇怪只有左边的框消灭？

        JS_RESIZE = False
        hyfda = 1

        Dim lRet As Long
        Dim apiRECT As RECT

        lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, apiRECT, 0)
        If lRet Then

            hyfx = UserControl.Parent.Width
            hyfy = UserControl.Parent.Height
            hyfl = UserControl.Parent.Left
            hyft = UserControl.Parent.Top

            If apiRECT.aBottom > 0 And apiRECT.aLeft = 0 And apiRECT.aTop = 0 Then
                UserControl.Parent.Left = 0
                UserControl.Parent.Top = 0
            ElseIf apiRECT.aLeft > 0 And apiRECT.aTop = 0 Then
                UserControl.Parent.Left = apiRECT.aLeft * Screen.TwipsPerPixelX
                UserControl.Parent.Top = 0
            ElseIf apiRECT.aTop > 0 And apiRECT.aLeft = 0 Then
                UserControl.Parent.Left = 0
                UserControl.Parent.Top = apiRECT.aTop * Screen.TwipsPerPixelY
            ElseIf apiRECT.aRight > 0 And apiRECT.aTop = 0 Then
                UserControl.Parent.Left = 0
                UserControl.Parent.Top = 0
            End If

            UserControl.Parent.Width = (apiRECT.aRight - apiRECT.aLeft) * Screen.TwipsPerPixelX
            UserControl.Parent.Height = (apiRECT.aBottom - apiRECT.aTop) * Screen.TwipsPerPixelY

        End If
        '最大化代码
    End If

End Sub

Public Property Get ONTOP() As Boolean
    ONTOP = JS_ONTOP
End Property

Public Property Let ONTOP(newvalue As Boolean)
    JS_ONTOP = newvalue
    If JS_ONTOP = True Then
        FRMontop.MakeTopMost UserControl.Parent.hwnd
    ElseIf JS_ONTOP = False Then
        FRMontop.MakeNormal UserControl.Parent.hwnd

    End If
    PropertyChanged "ONTOP"
End Property

Public Property Get Path() As String
    Path = JS_path
End Property

Public Property Let Path(NewPath As String)
    JS_path = NewPath
    PropertyChanged "Path"
    DOSKIN
End Property

Public Property Get ShowIcon() As Boolean
    ShowIcon = JS_SHOWICON
End Property

Public Property Let ShowIcon(newvalue As Boolean)
    JS_SHOWICON = newvalue
    PropertyChanged "ShowIcon"
End Property

Public Property Get SHOWONTOP() As Boolean
    SHOWONTOP = JS_SHOWONTOP
End Property

Public Property Let SHOWONTOP(newvalue As Boolean)
    JS_SHOWONTOP = newvalue
    PropertyChanged "SHOWONTOP"
End Property

Public Property Get Style() As JS_BORDER
    Style = JS_BORDERSTYLE
End Property

Public Property Let Style(newstyle As JS_BORDER)
    JS_BORDERSTYLE = newstyle
    PropertyChanged "Style"
End Property

Public Property Get Style2() As JS_BORDER2
    Style2 = JS_BORDERSTYLE2
End Property

Public Property Let Style2(newstyle2 As JS_BORDER2)
    JS_BORDERSTYLE2 = newstyle2
    PropertyChanged "Style2"
End Property

Public Function REDRAW()
    UserControl.Refresh
End Function

Private Sub Label1_DblClick()
    Call UserControl_DblClick
End Sub

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call UserControl_MouseDown(1, 1, 1, 1)
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call UserControl_MouseMove(1, 1, 1, 1)
End Sub

Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call UserControl_MouseUp(1, 1, 1, 1)
End Sub

Private Sub UserControl_Click()
    If JS_CONTROLBOX = True Then
        If JS_DOACTION = True Then
            If JS_DOWHAT = jsclose Then
                If JS_BORDERSTYLE <> FIXEDx Then Unload UserControl.Parent '如果是FIXEDX就不能关闭
            ElseIf JS_DOWHAT = jsontop Then
                If JS_ONTOP = True Then
                    FRMontop.MakeNormal UserControl.Parent.hwnd
                    JS_ONTOP = False
                    JS_BONTOP.LoadResource pb.ReadProperty("ONTOP1")
                    BitBlt UserControl.hdc, UserControl.ScaleWidth - JS_BONTOP.Width - JS_ICONSPACE - JS_MIN.Width - JS_ICONSPACE - JS_MAX.Width - JS_ICONSPACE - JS_CLOSE.Width - JS_FROMRIGHT, JS_FROMTOP, JS_BONTOP.Width, JS_BONTOP.Height, JS_BONTOP.hdc, 0, 0, SRCCOPY

                ElseIf JS_ONTOP = False Then
                    FRMontop.MakeTopMost UserControl.Parent.hwnd
                    JS_ONTOP = True
                    JS_BONTOP.LoadResource pb.ReadProperty("ONTOP3")
                    BitBlt UserControl.hdc, UserControl.ScaleWidth - JS_BONTOP.Width - JS_ICONSPACE - JS_MIN.Width - JS_ICONSPACE - JS_MAX.Width - JS_ICONSPACE - JS_CLOSE.Width - JS_FROMRIGHT, JS_FROMTOP, JS_BONTOP.Width, JS_BONTOP.Height, JS_BONTOP.hdc, 0, 0, SRCCOPY
                End If

            ElseIf JS_DOWHAT = jsmax And JS_BORDERSTYLE <> FIXED2 Then

                If hyfda = 1 Then '按了最大化按纽后
                    'JS_BORDERSTYLE2 = dig1
                    hyfda = 0
                    Dim lRet As Long
                    Dim apiRECT As RECT

                    lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, apiRECT, 0)
                    If lRet Then

                        UserControl.Parent.Width = hyfx
                        UserControl.Parent.Height = hyfy
                        UserControl.Parent.Left = hyfl
                        UserControl.Parent.Top = hyft

                        '按了最大化按纽后
                    Else
                        Print "调用 SystemParametersInfo 失败"
                    End If

                Else
                    hyfda = 1

                    lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, apiRECT, 0)
                    If lRet Then

                        hyfx = UserControl.Parent.Width
                        hyfy = UserControl.Parent.Height
                        hyfl = UserControl.Parent.Left
                        hyft = UserControl.Parent.Top

                        UserControl.Parent.Width = (apiRECT.aRight - apiRECT.aLeft) * Screen.TwipsPerPixelX
                        UserControl.Parent.Height = (apiRECT.aBottom - apiRECT.aTop) * Screen.TwipsPerPixelY

                        If apiRECT.aBottom > 0 And apiRECT.aLeft = 0 And apiRECT.aTop = 0 Then
                            UserControl.Parent.Left = 0
                            UserControl.Parent.Top = 0
                        ElseIf apiRECT.aLeft > 0 And apiRECT.aTop = 0 Then
                            UserControl.Parent.Left = apiRECT.aLeft * Screen.TwipsPerPixelX
                            UserControl.Parent.Top = 0
                        ElseIf apiRECT.aTop > 0 And apiRECT.aLeft = 0 Then
                            UserControl.Parent.Left = 0
                            UserControl.Parent.Top = apiRECT.aTop * Screen.TwipsPerPixelY
                        ElseIf apiRECT.aRight > 0 And apiRECT.aTop = 0 Then
                            UserControl.Parent.Left = 0
                            UserControl.Parent.Top = 0
                        End If

                    Else
                        Print "调用 SystemParametersInfo 失败"
                    End If
                End If
            ElseIf JS_DOWHAT = jsmin Then
                UserControl.Parent.WindowState = 1 '窗体最小化
                JS_BORDERSTYLE2 = dig0
            End If
        End If
    End If
End Sub

Private Sub UserControl_DblClick()
    If JS_DOACTION = False And JS_BORDERSTYLE <> FIXED And JS_BORDERSTYLE <> FIXED2 Then   'JS_BORDERSTYLE <> FIXED是为了防fixed还可以双击放大
        If hyfda = 1 Then
            hyfda = 0 '双击回原代码

            UserControl.Parent.Width = hyfx
            UserControl.Parent.Height = hyfy
            UserControl.Parent.Left = hyfl
            UserControl.Parent.Top = hyft

        Else
            'UserControl.Parent.WindowState = 2   '双击放大代码
            JS_RESIZE = False
            hyfda = 1

            Dim lRet As Long
            Dim apiRECT As RECT

            lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, apiRECT, 0)
            If lRet Then

                hyfx = UserControl.Parent.Width
                hyfy = UserControl.Parent.Height
                hyfl = UserControl.Parent.Left
                hyft = UserControl.Parent.Top

                If apiRECT.aBottom > 0 And apiRECT.aLeft = 0 And apiRECT.aTop = 0 Then
                    UserControl.Parent.Left = 0
                    UserControl.Parent.Top = 0
                ElseIf apiRECT.aLeft > 0 And apiRECT.aTop = 0 Then
                    UserControl.Parent.Left = apiRECT.aLeft * Screen.TwipsPerPixelX
                    UserControl.Parent.Top = 0
                ElseIf apiRECT.aTop > 0 And apiRECT.aLeft = 0 Then
                    UserControl.Parent.Left = 0
                    UserControl.Parent.Top = apiRECT.aTop * Screen.TwipsPerPixelY
                ElseIf apiRECT.aRight > 0 And apiRECT.aTop = 0 Then
                    UserControl.Parent.Left = 0
                    UserControl.Parent.Top = 0
                End If

                UserControl.Parent.Width = (apiRECT.aRight - apiRECT.aLeft) * Screen.TwipsPerPixelX
                UserControl.Parent.Height = (apiRECT.aBottom - apiRECT.aTop) * Screen.TwipsPerPixelY

            Else
                Print "调用 SystemParametersInfo 失败"
            End If

        End If
    End If
End Sub

Private Sub UserControl_Initialize()
    Set FRMontop = New clsOnTop

End Sub

Private Sub UserControl_InitProperties()

    Set UserControl.Font = Ambient.Font
    UserControl.Parent.Controls(UserControl.Ambient.DisplayName).Align = vbAlignTop