xp_canvas.ctl

小小图书管理系统是功能完善,已经可以实用于小型单位或科室的图书管理.系统界面美观,操作方便,代码带有详尽的注释,相信大家一定会喜欢

Private Sub lblcaption_DblClick()
    If Fixed_Single = False Then If UserControl.Parent.WindowState = 0 Then UserControl.Parent.WindowState = 2 Else UserControl.Parent.WindowState = 0
End Sub

Private Sub pictop_DblClick()
    If Fixed_Single = False Then If UserControl.Parent.WindowState = 0 Then UserControl.Parent.WindowState = 2 Else UserControl.Parent.WindowState = 0
End Sub

Private Sub pictop_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If UserControl.Parent.WindowState = 0 Then
        ReleaseCapture
        SendMessage UserControl.Parent.hWnd, &HA1, 2, 0&
    End If
    DoEvents
End Sub

Private Sub Timer1_Timer()
    On Error Resume Next
    If Screen.ActiveForm.hWnd <> UserControl.Parent.hWnd Then
        lost_f
        UserControl_Resize
        Timer1.Enabled = False
    End If
End Sub

Private Sub Timer2_Timer()
    On Error Resume Next
    If Screen.ActiveForm.hWnd = UserControl.Parent.hWnd Then
        got_f
        UserControl_Resize
        Timer2.Enabled = False
    End If
End Sub

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub UserControl_EnterFocus()
    Timer1.Enabled = False
    got_f
    UserControl_Resize
End Sub

Private Sub UserControl_ExitFocus()
    Timer1.Enabled = True
    Timer2.Enabled = True
End Sub

Private Sub UserControl_GotFocus()
    Timer1.Enabled = False
    Timer2.Enabled = False
    got_f
    UserControl_Resize
End Sub

Private Sub UserControl_Initialize()
    got_f
    UserControl_Resize
End Sub

Private Sub imgresize_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then GetCursorPos oldcp
End Sub

Private Sub imgresize_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then
        GetCursorPos newcp
        ResizeForm UserControl.Parent, oldcp, newcp, Index
    End If
End Sub

Private Sub UserControl_InitProperties()
    Caption = Ambient.DisplayName
    Fixed_Single = False
    Set Icon = Image1.Picture
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Caption = PropBag.ReadProperty("Caption", Ambient.DisplayName)
    Set Icon = PropBag.ReadProperty("Icon", Image1.Picture)
    Fixed_Single = PropBag.ReadProperty("Fixed_Single", False)
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next
    
    UserControl.Parent.ScaleMode = 3
    UserControl.AutoRedraw = True
    UserControl.BackColor = RGB(236, 233, 216)
    UserControl.ScaleMode = 3
    UserControl.Cls
    picleft.Width = 5
    picright.Width = 5
    pictop.Height = 29
    picbottom.Height = 5
    picleft.Align = 3
    picright.Align = 4
    pictop.Align = 1
    picbottom.Align = 2
    picleft.PaintPicture imgleft.Picture, 0, 0, picleft.Width, picleft.Height, 0, 0, imgleft.Width, imgleft.Height
    picright.PaintPicture imgright.Picture, 0, 0, picright.Width, picright.Height, 0, 0, imgright.Width, imgright.Height

    If UserControl.Parent.WindowState = 0 Then
        pictop.PaintPicture imgtop.Picture, 0, 0, 5, pictop.Height, 0, 0, 5, imgright.Height
        pictop.PaintPicture imgtop.Picture, 5, 0, pictop.Width - 10, pictop.Height, 5, 0, imgtop.Width - 10, imgtop.Height
        pictop.PaintPicture imgtop.Picture, pictop.Width - 5, 0, 5, pictop.Height, imgtop.Width - 5, 0, 5, imgtop.Height
    ElseIf UserControl.Parent.WindowState = 2 Then
        pictop.PaintPicture imgtopmax.Picture, 0, 0, 5, pictop.Height, 0, 0, 5, imgright.Height
        pictop.PaintPicture imgtopmax.Picture, 5, 0, pictop.Width - 10, pictop.Height, 5, 0, imgtop.Width - 10, imgtop.Height
        pictop.PaintPicture imgtopmax.Picture, pictop.Width - 5, 0, 5, pictop.Height, imgtop.Width - 5, 0, 5, imgtop.Height
    End If

    picbottom.PaintPicture imgbottom.Picture, 0, 0, picbottom.Width, picbottom.Height, 0, 0, imgbottom.Width, imgbottom.Height
    lblcaption.Top = 6
    lblcaption.Left = 26
    lblshadow.Top = 8
    lblshadow.Left = 28
    
    imgresize(6).Top = 0
    imgresize(6).Left = UserControl.Parent.ScaleWidth - 9
    imgresize(4).Top = picbottom.ScaleHeight - 9
    imgresize(4).Left = picbottom.ScaleWidth - 9
    imgresize(2).Width = pictop.ScaleWidth - 18
    imgresize(2).Left = 9

    If Fixed_Single = False Then
        If UserControl.Parent.WindowState = 0 Then
            picleft.MousePointer = vbSizeWE
            picright.MousePointer = vbSizeWE
            picbottom.MousePointer = vbSizeNS
            imgresize(6).MousePointer = vbSizeNESW
            imgresize(2).MousePointer = vbSizeNS
            imgresize(4).MousePointer = vbSizeNWSE
            imgresize(5).MousePointer = vbSizeNESW
            imgresize(7).MousePointer = vbSizeNWSE
        ElseIf UserControl.Parent.WindowState = 2 Then
            picleft.MousePointer = vbDefault
            picright.MousePointer = vbDefault
            picbottom.MousePointer = vbDefault
            imgresize(6).MousePointer = vbDefault
            imgresize(2).MousePointer = vbDefault
            imgresize(4).MousePointer = vbDefault
            imgresize(5).MousePointer = vbDefault
            imgresize(7).MousePointer = vbDefault
        End If
    ElseIf Fixed_Single = True Then
        picleft.MousePointer = vbDefault
        picright.MousePointer = vbDefault
        picbottom.MousePointer = vbDefault
        imgresize(6).MousePointer = vbDefault
        imgresize(2).MousePointer = vbDefault
        imgresize(4).MousePointer = vbDefault
        imgresize(5).MousePointer = vbDefault
        imgresize(7).MousePointer = vbDefault
    End If
    
    DoEvents
    RaiseEvent Resize
End Sub

Private Sub lost_f()
    imgleft.Picture = imgleft2.Picture
    imgright.Picture = imgright2.Picture
    imgtop.Picture = imgtop2.Picture
    imgtopmax.Picture = imgtopmax2.Picture
    imgbottom.Picture = imgbottom2.Picture
End Sub

Private Sub got_f()
    imgleft.Picture = imgleft1.Picture
    imgright.Picture = imgright1.Picture
    imgtop.Picture = imgtop1.Picture
    imgtopmax.Picture = imgtopmax1.Picture
    imgbottom.Picture = imgbottom1.Picture
End Sub

Private Sub lblcaption_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If UserControl.Parent.WindowState = 0 Then
        ReleaseCapture
        SendMessage UserControl.Parent.hWnd, &HA1, 2, 0&
    End If
End Sub

Private Sub picbottom_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then GetCursorPos oldcp
End Sub

Private Sub picbottom_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then
        GetCursorPos newcp
        ResizeForm UserControl.Parent, oldcp, newcp, 3
    End If
End Sub

Private Sub picleft_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then GetCursorPos oldcp
End Sub

Private Sub picleft_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then
        GetCursorPos newcp
        ResizeForm UserControl.Parent, oldcp, newcp, 0
    End If
End Sub

Private Sub picright_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then GetCursorPos oldcp
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
    
End Sub

Private Sub picright_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Fixed_Single = False Then
        GetCursorPos newcp
        ResizeForm UserControl.Parent, oldcp, newcp, 1
    End If
End Sub

Public Sub make_trans(frm As Form)
    frm.Cls
    frm.ScaleMode = 3
    
    If frm.WindowState = 0 Then
        frm.PaintPicture imgtop.Picture, 0, 0, 5, pictop.Height, 0, 0, 5, imgtop.Height
        frm.PaintPicture imgtop.Picture, pictop.Width - 5, 0, 5, pictop.Height, imgtop.Width - 5, 0, 5, imgtop.Height
    End If
    
    AutoFormShape frm, RGB(255, 0, 255)
End Sub

Public Property Get Caption() As String
Attribute Caption.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute Caption.VB_UserMemId = -518
    Caption = lblcaption.Caption
End Property

Public Property Let Caption(ByVal vNewCaption As String)
    lblcaption.Caption() = vNewCaption
    lblshadow.Caption() = vNewCaption
    UserControl.Parent.Caption = vNewCaption
    Call UserControl_Resize
    PropertyChanged "Caption"
End Property

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Caption", lblcaption.Caption, Ambient.DisplayName)
    Call PropBag.WriteProperty("Icon", m_Icon, Image1.Picture)
    Call PropBag.WriteProperty("Fixed_Single", FixedSingle, False)
End Sub

Public Property Get Icon() As Picture
    Set Icon = m_Icon
End Property

Public Property Set Icon(ByVal New_Icon As Picture)
    Set m_Icon = New_Icon
    imgicon.Picture = New_Icon
    PropertyChanged "Icon"
End Property

Public Sub SetFocus()
    Timer1.Enabled = False
    Timer2.Enabled = False
    got_f
    UserControl_Resize
End Sub

Public Property Get Fixed_Single() As Boolean
    Fixed_Single = FixedSingle
End Property

Public Property Let Fixed_Single(ByVal vNewValue As Boolean)
    FixedSingle = vNewValue
    UserControl_Resize
End Property