jsborder.ctl

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

VERSION 5.00
Begin VB.UserControl JSBORDER 
   Alignable       =   -1  'True
   BackColor       =   &H00DC7E5A&
   ClientHeight    =   375
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2985
   ScaleHeight     =   25
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   199
   ToolboxBitmap   =   "JSBORDER.ctx":0000
End
Attribute VB_Name = "JSBORDER"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private JS_BMP1 As clsBitmap
Private JS_BMP2 As clsBitmap
Private JS_BMP3 As clsBitmap
'Dim oldcp As POINTAPI
'Dim newcp As POINTAPI
'Dim ji As Byte
Private pbl As PropertyBag

Enum BTYPE
    wLeft = 1
    wRight = 2
    wBottom = 3
End Enum

Private BORDERSTYLES As BTYPE
Private RESIZEHOW As Integer
Private JS_path As String
Public Property Let BORDERTYPE(NewBordertype As BTYPE)
    BORDERSTYLES = NewBordertype

    If BORDERSTYLES = wLeft Then
        UserControl.Parent.Controls(UserControl.Ambient.DisplayName).Align = vbAlignLeft
    ElseIf BORDERSTYLES = wRight Then
        UserControl.Parent.Controls(UserControl.Ambient.DisplayName).Align = vbAlignRight
    ElseIf BORDERSTYLES = wBottom Then
        UserControl.Parent.Controls(UserControl.Ambient.DisplayName).Align = vbAlignBottom
    End If

    PropertyChanged "BORDERTYPE"
End Property

Public Property Get BORDERTYPE() As BTYPE
    BORDERTYPE = BORDERSTYLES
End Property

'Private JS_BMP1 As clsBitmap
Private Sub DOSKIN()
    If Ambient.UserMode = True Then

        Dim varTemp As Variant
        Dim byteArr() As Byte
        On Error Resume Next
        '
        'INIALIZE THE IMAGES IN DC
        '

        Set JS_BMP1 = New clsBitmap
        Set JS_BMP2 = New clsBitmap

        If BORDERSTYLES = wBottom Then
            Set JS_BMP3 = New clsBitmap
        End If
        '
        'OPEN SKIN FILE AND COPY CONTENTS INTO MEMORY
        '
        Set pbl = New PropertyBag
        Open JS_path For Binary As #1
        Get #1, , varTemp
        Close #1
        ' Convert the variant to byte.
        byteArr = varTemp
        ' Property bag contents as byte.
        pbl.Contents = byteArr
        ' NOW SET THE IMAGES INTO MEMORY
        With pbl
            If BORDERSTYLES = 1 Then
                JS_BMP1.LoadResource .ReadProperty("LEFTTOP")
                JS_BMP2.LoadResource .ReadProperty("LEFTMID")
            ElseIf BORDERSTYLES = 2 Then
                JS_BMP1.LoadResource .ReadProperty("RIGHTTOP")
                JS_BMP2.LoadResource .ReadProperty("RIGHTMID")
            ElseIf BORDERSTYLES = 3 Then
                JS_BMP1.LoadResource .ReadProperty("LEFTBOT")
                JS_BMP2.LoadResource .ReadProperty("RIGHTBOT")
                JS_BMP3.LoadResource .ReadProperty("BOTTOM")
            End If
        End With

        '
        'SET CONTROLHEIGHT OR WIDTH
        '
        If BORDERSTYLES = wLeft Then
            UserControl.Width = (JS_BMP1.Width) * Screen.TwipsPerPixelX
        ElseIf BORDERSTYLES = wRight Then
            UserControl.Width = (JS_BMP1.Width) * Screen.TwipsPerPixelX
        ElseIf BORDERSTYLES = wBottom Then
            UserControl.Height = (JS_BMP3.Height) * Screen.TwipsPerPixelY
        End If

        '
        'PLACE THE IMAGES ON THE USERCONTROL
        '

        'MIDDLE IMAGE
        If BORDERSTYLES = wLeft Then
            For z = 0 To UserControl.ScaleHeight
                BitBlt UserControl.hdc, 0, JS_BMP2.Height * z, JS_BMP2.Width, JS_BMP2.Height, JS_BMP2.hdc, 0, 0, SRCCOPY
            Next z
            BitBlt UserControl.hdc, 0, 0, JS_BMP1.Width, JS_BMP1.Height, JS_BMP1.hdc, 0, 0, SRCCOPY
        ElseIf BORDERSTYLES = wRight Then
            For n = 0 To UserControl.ScaleHeight
                BitBlt UserControl.hdc, 0, JS_BMP2.Height * n, JS_BMP2.Width, JS_BMP2.Height, JS_BMP2.hdc, 0, 0, SRCCOPY
            Next n
            BitBlt UserControl.hdc, 0, 0, JS_BMP1.Width, JS_BMP1.Height, JS_BMP1.hdc, 0, 0, SRCCOPY
        ElseIf BORDERSTYLES = wBottom Then
            For i = 0 To UserControl.ScaleWidth
                BitBlt UserControl.hdc, JS_BMP3.Width * i, 0, JS_BMP3.Width, JS_BMP3.Height, JS_BMP3.hdc, 0, 0, SRCCOPY
            Next i
            BitBlt UserControl.hdc, 0, 0, JS_BMP1.Width, JS_BMP1.Height, JS_BMP1.hdc, 0, 0, SRCCOPY
            BitBlt UserControl.hdc, UserControl.ScaleWidth - (JS_BMP2.Width), 0, JS_BMP2.Width, JS_BMP2.Height, JS_BMP2.hdc, 0, 0, SRCCOPY
        End If

        Set JS_BMP1 = Nothing
        Set JS_BMP2 = Nothing
        Set JS_BMP3 = Nothing
        Set pbl = Nothing
    End If

End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

    If JS_RESIZE = True Then

        If BORDERSTYLES = wLeft Then

            If RESIZEHOW = 0 Then
                ReleaseCapture
                SendMessage UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0

            ElseIf RESIZEHOW = 1 Then
                ReleaseCapture
                SendMessage UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTLEFT, 0

                'ElseIf RESIZEHOW = 2 Then
                'ReleaseCapture
                'SendMessage UserControl.Parent.hWnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0

            End If

            'SendMessage UserControl.Parent.hWnd, WM_NCLBUTTONDOWN, HTLEFT, 0

        ElseIf BORDERSTYLES = wRight Then

            If RESIZEHOW = 0 Then
                '  ReleaseCapture
                ' SendMessage UserControl.Parent.hWnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0

            ElseIf RESIZEHOW = 1 Then
                ReleaseCapture
                SendMessage UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTRIGHT, 0

            ElseIf RESIZEHOW = 2 Then
                ReleaseCapture
                SendMessage UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0

            End If

        ElseIf BORDERSTYLES = wBottom Then
            If RESIZEHOW = 0 Then
                ReleaseCapture
                SendMessage UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0

            ElseIf RESIZEHOW = 1 Then
                ReleaseCapture
                SendMessage UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTBOTTOM, 0

            ElseIf RESIZEHOW = 2 Then
                ReleaseCapture
                SendMessage UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0

            End If

        End If

    End If

End Sub

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 Function REDRAW()
    UserControl.Refresh
End Function

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

    If JS_RESIZE = True Then
        If BORDERSTYLES = wBottom Then
            If x >= 0 And x <= 10 Then
                RESIZEHOW = 0
                UserControl.MousePointer = 6
            ElseIf x >= UserControl.ScaleWidth - 10 And x <= UserControl.ScaleWidth Then
                RESIZEHOW = 2
                UserControl.MousePointer = 8
            Else
                RESIZEHOW = 1
                UserControl.MousePointer = 7
            End If
        Else
            UserControl.MousePointer = 9
            RESIZEHOW = 1
            If y >= UserControl.ScaleHeight - 10 And y <= UserControl.ScaleHeight And BORDERSTYLES = wLeft Then
                UserControl.MousePointer = 6
                RESIZEHOW = 0
            End If
            If y >= UserControl.ScaleHeight - 10 And y <= UserControl.ScaleHeight And BORDERSTYLES = wRight Then

                RESIZEHOW = 2
                UserControl.MousePointer = 8
            End If

        End If
    End If

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

    '   If JS_RESIZE = True Then
    ' GetCursorPos newcp

    'If BORDERSTYLES = wLeft Then

    'ResizeForm UserControl.Parent, oldcp, newcp, 0

    'ElseIf BORDERSTYLES = wRight Then

    'ResizeForm UserControl.Parent, oldcp, newcp, 1

    'ElseIf BORDERSTYLES = wBottom Then

    ' If RESIZEHOW = 0 Then '等于0就是左下角

    'ResizeForm UserControl.Parent, oldcp, newcp, 0
    ' ResizeForm UserControl.Parent, oldcp, newcp, 3

    '  ElseIf RESIZEHOW = 1 Then '等于1就是下面

    'ResizeForm UserControl.Parent, oldcp, newcp, 3

    ' ElseIf RESIZEHOW = 2 Then '等于6就是右下角

    'ResizeForm UserControl.Parent, oldcp, newcp, 1
    'ResizeForm UserControl.Parent, oldcp, newcp, 3

    '  End If

    'End If

    'End If

    'ji = 0 '记住鼠标松开了。

End Sub

Private Sub UserControl_Paint()
    DOSKIN
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    BORDERSTYLES = PropBag.ReadProperty("BORDERTYPE", 0)
    JS_path = PropBag.ReadProperty("Path", "")

End Sub

Private Sub UserControl_Resize()
    If Ambient.UserMode = False Then
        If BORDERSTYLES = wLeft Then
            UserControl.Width = 100
        ElseIf BORDERSTYLES = wRight Then
            UserControl.Width = 100
        ElseIf BORDERSTYLES = wBottom Then
            UserControl.Height = 100
        End If
    End If

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "BORDERTYPE", BORDERSTYLES, 0
    PropBag.WriteProperty "Path", JS_path, ""

End Sub

Private Sub ResizeForm(frm As Form, oldcp As POINTAPI, newcp As POINTAPI, ResizeMode As Integer)

    On Error Resume Next
    ' Oldcp: Old cursor position (MouseDown)
    ' Newcp: New cursor position (MouseUp)
    ' ResizeMode:   0 - Left side
    '               1 - Right side
    '               2 - Top side
    '               3 - Bottom side
    '               4 - Bottom right corner
    '               5 - Bottom left corner
    '               6 - Top right corner
    '               7 - Top left corner
    Dim DifferenceX
    Dim DifferenceY

    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

    If frm.Width < 4045 Or frm.Height < 2500 Then   '防尺寸变为零

        frm.Width = 4045
        frm.Height = 2500

        Exit Sub
    End If '防尺寸变为零

End Sub