objdraw.cls

套打程序

Public Sub OnStartDrag(X As Single, Y As Single)
    IsDraging = True
    mvarOldX = X
    mvarOldY = Y
    Call ShowHd(False)
    Screen.MousePointer = vbSizeAll
End Sub

'正在拖动
Public Function OnDraging(X As Single, Y As Single, Optional bLim As Boolean = False, Optional LimX As Single = 0, Optional LimY As Single = 0) As Boolean
Dim tmpx As Single, tmpy As Single, tmpw As Single, tmph As Single
Dim blnx As Boolean, blny As Boolean, blnLine As Boolean
    
    blnLine = TypeOf mvarObjCtl Is Line
    
    With mvarObjCtl
        If blnLine Then
            blnx = (.x1 > .x2)
            tmpx = IIf(blnx, .x2, .x1)
            blny = (.y1 > .y2)
            tmpy = IIf(blny, .y2, .y1)
            tmpw = Abs(.x1 - .x2)
            tmph = Abs(.y1 - .y2)
        Else
            tmpx = .Left
            tmpy = .Top
            tmpw = .Width
            tmph = .Height
        End If
        tmpx = tmpx + (X - mvarOldX)
        tmpy = tmpy + (Y - mvarOldY)
        If bLim Then
            If tmpx < 0 Then tmpx = 0
            If tmpy < 0 Then tmpy = 0
            If (tmpx + tmpw) > LimX And LimX <> 0 Then tmpx = LimX - tmpw
            If (tmpy + tmph) > LimY And LimY <> 0 Then tmpy = LimY - tmph
        End If
        If blnLine Then
            .x1 = IIf(blnx, tmpx + tmpw, tmpx)
            .y1 = IIf(blny, tmpy + tmph, tmpy)
            .x2 = IIf(blnx, tmpx, tmpx + tmpw)
            .y2 = IIf(blny, tmpy, tmpy + tmph)
        Else
            .Move tmpx, tmpy
        End If
    End With
    mvarOldX = X
    mvarOldY = Y
End Function

'结束拖动
Public Sub OnEndDrag(X As Single, Y As Single)
    Call MoveHd
    IsDraging = False
    Call ShowHd(True)
    mvarIsDraging = False
    Screen.MousePointer = vbDefault
End Sub

'开始调整大小
Public Sub OnStartSize(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If mvareType = mObjLine Then
        With mvarObjCtl
            mvarOldX = IIf(Index <> 0, .x1, .x2)
            mvarOldY = IIf(Index <> 0, .y1, .y2)
        End With
    ElseIf mvareType = mObjText Then
        If Not mvarObjCtl Is Nothing Then mvarObjCtl.AutoSize = False
    End If
    mvarActHdID = Index
    IsSizing = True
    Call ShowHd(False)
End Sub

'正在调整大小
Public Sub OnSizing(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim tmprect  As RECTAPI
    If Button = vbLeftButton And mvarIsSizing Then
        If mvareType = mObjLine Then
            mvarObjCtl.Visible = False
            g_ActFrm.PicPage.Cls
            g_ActFrm.PicPage.Line (mvarOldX, mvarOldY)-(X, Y)
            mvarRect.Right = X
            mvarRect.Bottom = Y
        Else
            Call SetRectToCtrl(mvarObjCtl, tmprect)
            Call AdjustRect(mvarActHdID, tmprect, X, Y)
            With tmprect
                If Not (.Left >= .Right Or .Top >= .Bottom) Then Call SetCtrlToRect(mvarObjCtl, tmprect)
            End With
        End If
    End If
End Sub

'结束调整大小
Public Sub OnEndSize(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And mvarIsSizing Then
        If mvareType = mObjLine Then
            With mvarRect
                .Left = OldX
                .Top = OldY
                g_ActFrm.PicPage.Cls
                mvarObjCtl.x1 = .Left
                mvarObjCtl.y1 = .Top
                mvarObjCtl.x2 = .Right
                mvarObjCtl.y2 = .Bottom
            End With
            mvarObjCtl.Visible = True
        End If
        Call MoveHd
        Call ShowHd(True)
        IsSizing = False
    End If
End Sub

'检查区域
Public Function CheckRange(x1 As Single, y1 As Single, x2 As Single, y2 As Single) As Boolean
Dim ctlrect As RECTAPI
Dim diffrect As RECTAPI
Dim tmprect As RECTAPI
    If Not ObjCtl.Visible Then Exit Function
    With tmprect
        .Left = x1: .Right = x2
        .Top = y1: .Bottom = y2
    End With
    With ctlrect
        If TypeOf ObjCtl Is Line Then
            .Left = IIf(ObjCtl.x1 > ObjCtl.x2, ObjCtl.x2, ObjCtl.x1)
            .Right = IIf(ObjCtl.x1 > ObjCtl.x2, ObjCtl.x1, ObjCtl.x2)
            .Top = IIf(ObjCtl.y1 > ObjCtl.y2, ObjCtl.y2, ObjCtl.y1)
            .Bottom = IIf(ObjCtl.y1 > ObjCtl.y2, ObjCtl.y1, ObjCtl.y2)
            If .Left = .Right Then .Left = .Left - 20: .Right = .Right + 20
            If .Top = .Bottom Then .Top = .Top - 20: .Bottom = .Bottom + 20
        Else
            .Left = ObjCtl.Left
            .Right = ObjCtl.Left + ObjCtl.Width
            .Top = ObjCtl.Top
            .Bottom = ObjCtl.Height + ObjCtl.Top
        End If
    End With
    If IntersectRect(diffrect, tmprect, ctlrect) Then
        CheckRange = True
    Else
        CheckRange = False
    End If
End Function

'检查点
Public Function CheckPoint(X As Single, Y As Single) As Boolean
    If Not ObjCtl.Visible Then Exit Function
    Call SetRectToCtrl(ObjCtl, mvarRect)
    With mvarRect
        .Left = .Left - 75
        .Bottom = .Bottom + 75
        .Top = .Top - 75
        .Right = .Right + 75
        If X >= .Left And X <= .Right And Y >= .Top And Y <= .Bottom Then
            If TypeOf ObjCtl Is Line Then
                CheckPoint = HitInLine(ObjCtl, X, Y)
            Else
                CheckPoint = True
            End If
        Else
            CheckPoint = False
        End If
    End With
End Function

'Check Point Is Like In Line
Private Function HitInLine(tmpline As Line, X As Single, Y As Single) As Boolean
Dim tmpx1 As Single, tmpx2 As Single, tmpy As Single
Dim k As Single, k1 As Single, k2 As Single
    With tmpline
        tmpx1 = .x1
        tmpx2 = .x2
        If tmpx1 = tmpx2 Or tmpx1 = X Or tmpx2 = X Then
            HitInLine = (Y <= IIf(.y2 > .y1, .y2, .y1) And Y > IIf(.y2 > tmpline.y1, .y1, .y2))
        ElseIf tmpline.y1 = .y2 Or .y1 = Y Or .y2 = Y Then
            HitInLine = (X <= IIf(.x2 > .x1, .x2, .x1) And X > IIf(.x2 > tmpline.x1, .x1, .x2))
        Else
            k = Abs((.y2 - .y1) / (tmpx2 - tmpx1))
            k1 = Abs((.y2 - Y) / (tmpx2 - X))
            k2 = Abs((.y1 - Y) / (tmpx1 - X))
            HitInLine = ((Abs(k1 - k) < 0.1) And (Abs(k2 - k) < 0.1))
        End If
    End With
End Function

'Show The Handle
Private Sub ShowHd(Optional bShow As Boolean = True)
Dim objtmp As ObjHd
Dim tmpcount As Integer
    tmpcount = HdCount
    For Each objtmp In mvarHandls
        If objtmp.HdID < tmpcount And mvarObjCtl.Visible Then objtmp.ObjCtl.Visible = bShow
    Next
End Sub

'AdjustRect On Sizing
Private Sub AdjustRect(hdidx As Integer, tmprect As RECTAPI, X As Single, Y As Single)
    With tmprect
        Select Case hdidx
            'Top Left
            Case 0: .Left = X: .Top = Y
            'Top center
            Case 1: .Top = Y
            'Top right
            Case 2: .Right = X: .Top = Y
            'Center right
            Case 3: .Right = X
            'Bottom Right
            Case 4: .Right = X: .Bottom = Y
            'Bottom center
            Case 5: .Bottom = Y
            'Bottom left
            Case 6: .Left = X: .Bottom = Y
            'Center left
            Case 7: .Left = X
        End Select
        If hdidx = 2 Or hdidx = 3 Or hdidx = 4 Then If .Left >= .Right Then .Right = .Left
        If hdidx = 4 Or hdidx = 5 Or hdidx = 6 Then If .Top >= .Bottom Then .Bottom = .Top
        If hdidx = 0 Or hdidx = 6 Or hdidx = 7 Then If .Left >= .Right Then .Left = .Right
        If hdidx = 0 Or hdidx = 1 Or hdidx = 2 Then If .Top >= .Bottom Then .Top = .Bottom
    End With
End Sub

'MoveHd
Public Sub MoveHd()
Dim xFudge As Integer, yFudge As Integer, nWidth As Integer, nHeight As Integer

    nWidth = (g_ActFrm.PicHD(0).Width \ 2)
    nHeight = (g_ActFrm.PicHD(0).Height \ 2)
    xFudge = (0.5 * Screen.TwipsPerPixelX)
    yFudge = (0.5 * Screen.TwipsPerPixelY)
    
    With mvarObjCtl
        If TypeOf mvarObjCtl Is Line Then
            If .x1 < .x2 Then
                'Top Left
                mvarHandls(1).ObjCtl.Move (.x1 - nWidth) + xFudge, (.y1 - nHeight) + yFudge
                'Bottom right
                mvarHandls(5).ObjCtl.Move .x2 - nWidth - xFudge, .y2 - nHeight - yFudge
            Else
                'Top Left
                mvarHandls(1).ObjCtl.Move (.x1 - nWidth) + xFudge, (.y1 - nHeight) + yFudge
                'Bottom right
                mvarHandls(5).ObjCtl.Move .x2 - nWidth - xFudge, .y2 - nHeight - yFudge
            End If
            mvarHandls(5).HdID = 1
            mvarHandls(2).HdID = 5
        Else
            'Top Left
            mvarHandls(1).ObjCtl.Move (.Left - nWidth) + xFudge, (.Top - nHeight) + yFudge
            'Bottom right
            mvarHandls(5).ObjCtl.Move (.Left + .Width) - nWidth - xFudge, .Top + .Height - nHeight - yFudge
            'Top center
            mvarHandls(2).ObjCtl.Move .Left + (.Width / 2) - nWidth, .Top - nHeight + yFudge
            'Bottom center
            mvarHandls(6).ObjCtl.Move .Left + (.Width / 2) - nWidth, .Top + .Height - nHeight - yFudge
            'Top right
            mvarHandls(3).ObjCtl.Move .Left + .Width - nWidth - xFudge, .Top - nHeight + yFudge
            'Bottom left
            mvarHandls(7).ObjCtl.Move .Left - nWidth + xFudge, .Top + .Height - nHeight - yFudge
            'Center right
            mvarHandls(4).ObjCtl.Move .Left + .Width - nWidth - xFudge, .Top + (.Height / 2) - nHeight
            'Center left
            mvarHandls(8).ObjCtl.Move .Left - nWidth + xFudge, .Top + (.Height / 2) - nHeight
        End If
    End With

End Sub

'LoadHd
Public Sub LoadHd()
Dim tmpID As Long
Dim i As Integer
    tmpID = (mvarnID - 1) * 8 + 1
    mvarHandls.Clear
    For i = 0 To 7
        ' Error Resume Next
        Load g_ActFrm.PicHD(tmpID + i)
        g_ActFrm.PicHD(tmpID + i).Tag = i + 1
        mvarHandls.Add i, 0, g_ActFrm.PicHD(tmpID + i), mvarnID & i
        Set mvarHandls(i + 1).ObjCtl = g_ActFrm.PicHD(tmpID + i)
        mvarHandls(i + 1).ObjCtl.MousePointer = GetPointType(i + 1)
        mvarHandls(i + 1).ObjCtl.ZOrder
    Next
End Sub

'GetPointType
Private Function GetPointType(tmpidx As Integer) As Integer
    Select Case tmpidx
        'Top Left
        Case 1: GetPointType = vbSizeNWSE
        'Top center
        Case 2: GetPointType = vbSizeNS
        'Top right
        Case 3: GetPointType = vbSizeNESW
        'Center right
        Case 4: GetPointType = vbSizeWE
        'Bottom Right
        Case 5: GetPointType = vbSizeNWSE
        'Bottom center
        Case 6: GetPointType = vbSizeNS
        'Bottom left
        Case 7: GetPointType = vbSizeNESW
        'Center left
        Case 8: GetPointType = vbSizeWE
        'Default
        Case Else: GetPointType = vbDefault
    End Select
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Support Sub Or Function

'DrawDragRect
Private Sub DrawDragRect(tmprect As RECTAPI, Optional bSel As Boolean = False)
    Dim hPen As Long, hOldPen As Long
    Dim hBrush As Long, hOldBrush As Long
    Dim hScreenDC As Long, nDrawMode As Long
    Dim tmppoint As POINTAPI
    
    hScreenDC = GetDC(0)
    'Select GDI object
    If bSel Then
        hPen = CreatePen(PS_DASH, 1, 0)
    Else
        hPen = CreatePen(PS_SOLID, 1, 0)
    End If
    hOldPen = SelectObject(hScreenDC, hPen)
    hBrush = GetStockObject(NULL_BRUSH)
    hOldBrush = SelectObject(hScreenDC, hBrush)
    nDrawMode = SetROP2(hScreenDC, R2_NOT)
    'Draw Rectangle
    Rectangle hScreenDC, tmprect.Left, tmprect.Top, tmprect.Right, tmprect.Bottom
    'Restore DC
    SetROP2 hScreenDC, nDrawMode
    SelectObject hScreenDC, hOldBrush
    SelectObject hScreenDC, hOldPen
    ReleaseDC 0, hScreenDC
    'Delete GDI objects
    DeleteObject hPen
End Sub

'ScreenToTwips
Private Sub ScreenToTwips(tmphwnd As Long, tmprect As RECTAPI)
Dim pt As POINTAPI
    With tmprect
        pt.X = .Left
        pt.Y = .Top
        ScreenToClient tmphwnd, pt
        .Left = pt.X * Screen.TwipsPerPixelX
        .Top = pt.Y * Screen.TwipsPerPixelX
        pt.X = .Right
        pt.Y = .Bottom
        ScreenToClient tmphwnd, pt
        .Right = pt.X * Screen.TwipsPerPixelX
        .Bottom = pt.Y * Screen.TwipsPerPixelX
    End With
End Sub

'TwipsToScreen
Private Sub TwipsToScreen(tmphwnd As Long, tmprect As RECTAPI)
Dim pt As POINTAPI
    With tmprect
        pt.X = .Left / Screen.TwipsPerPixelX
        pt.Y = .Top / Screen.TwipsPerPixelX
        ClientToScreen tmphwnd, pt
        .Left = pt.X
        .Top = pt.Y
        pt.X = .Right / Screen.TwipsPerPixelX
        pt.Y = .Bottom / Screen.TwipsPerPixelX
        ClientToScreen tmphwnd, pt
        .Right = pt.X
        .Bottom = pt.Y
    End With
End Sub

'SetCtrlToRect
Private Sub SetCtrlToRect(ctl As Control, tmprect As RECTAPI)
Dim tmpswap As Integer
    With tmprect
        If TypeOf ctl Is Line Then
            tmpswap = m_Swap
            'Restore normalized rectangle if needed
            If tmpswap And SWAP_X Then
                ctl.x1 = .Right: ctl.x2 = .Left
            Else
                ctl.x1 = .Left: ctl.x2 = .Right
            End If
            If tmpswap And SWAP_Y Then
                ctl.y1 = .Bottom: ctl.y2 = .Top
            Else
                ctl.y1 = .Top: ctl.y2 = .Bottom
            End If
            'Force to valid rectangle
            Call NormalizeRect(tmprect)
        Else
            'Force to valid rectangle
            Call NormalizeRect(tmprect)
            ctl.Move .Left, .Top, .Right - .Left, .Bottom - .Top
        End If
    End With
End Sub

'SetRectToCtrl
Private Sub SetRectToCtrl(ctl As Control, tmprect As RECTAPI)
Dim tmpswap As Integer
    tmpswap = SWAP_NONE
    With tmprect
        If TypeOf ctl Is Line Then
            .Left = ctl.x1
            .Top = ctl.y1
            .Right = ctl.x2
            .Bottom = ctl.y2
            If .Left > .Right Then tmpswap = tmpswap Or SWAP_X
            If .Top > .Bottom Then tmpswap = tmpswap Or SWAP_Y
            If tmpswap <> SWAP_NONE Then Call NormalizeRect(tmprect)
        Else
            .Left = ctl.Left
            .Top = ctl.Top
            .Right = ctl.Left + ctl.Width
            .Bottom = ctl.Top + ctl.Height
        End If
    End With
    m_Swap = tmpswap
End Sub

'NormalizeRect
Private Sub NormalizeRect(tmprect As RECTAPI)
Dim nTemp As Long
    With tmprect
        If .Left > .Right Then
            nTemp = .Right
            .Right = .Left
            .Left = nTemp
        End If
        If .Top > .Bottom Then
            nTemp = .Bottom
            .Bottom = .Top
            .Top = nTemp
        End If
    End With
End Sub

Private Sub Class_Initialize()
    mvarPrinted = True
    mvarFix = True
    mvarClip = True
    mvarScroll = False
    mvarSumed = False
    mvarSumPage = False
    mvarDataType = 0
    mvarFormat = ""
    mvarEditFalg = 0
    mvarColor = 0
    mvarWidth = 1
    mvarStyle = 1
End Sub