drawingtools.cls

枕善居汉化的stockchart股软 描 述：实时股票图表曲线示例 Ver 1.0 网 站：http://www.mndsoft.com/ e-mail ：[e-mail] 最新的

                Call SaveGdiInfo1
                picBxV.DrawMode = ToolMode
            End If
            'prevent the loop from rapid fire drawing by both setting a minimum
            'elapsed time and looking for mouse movement... if the mouse isn't moving
            'the rubberband line isn't either..... prevents flicker and slow line response
            If Timer - ltimer > 0.1 And ((XcurrMov <> X2) Or (YcurrMov <> Y2)) Then
                picBxV.DrawStyle = vbDot
                picBxV.DrawWidth = 1
                picBxV.Refresh
                X2 = XcurrMov
                Y2 = YcurrMov
                rXvecDiff = X2 - X1
                rYvecDiff = Y2 - Y1
                rAngle = Tan(rYvecDiff / rXvecDiff) * 180 / PI
                picBxV.Line (X1, Y1)-(X2, Y2), ToolColor
                picBxV.Line (X1 + Sin(rAngle), Y1 + Cos(rAngle))-(X2 + Sin(rAngle), Y2 + Cos(rAngle)), ToolColor
                rYdiff = Abs(rYvecDiff)
                rFib61 = rYdiff * 0.618
                rFib50 = rYdiff * 0.5
                rFib38 = rYdiff * 0.382
                If Y1 < Y2 Then
                    rYstart = Y1
                Else
                    rYstart = Y2
                End If
                If X1 > X2 Then
                    iXstart = X2
                Else
                    iXstart = X1
                End If
                picBxV.DrawStyle = ToolStyle
                picBxV.DrawWidth = ToolWidth
                picBxV.Line (iXstart, rYstart)-(iMaxDrawRightX, rYstart), ToolColor
                picBxV.Line (iXstart, rYstart + rFib61)-(iMaxDrawRightX, rYstart + rFib61), ToolColor
                picBxV.Line (iXstart, rYstart + rFib50)-(iMaxDrawRightX, rYstart + rFib50), ToolColor
                picBxV.Line (iXstart, rYstart + rFib38)-(iMaxDrawRightX, rYstart + rFib38), ToolColor
                picBxV.Line (iXstart, rYstart + rYdiff)-(iMaxDrawRightX, rYstart + rYdiff), ToolColor

                ltimer = Timer
            End If
        ElseIf iMouseClickNum = 2 Then '2nd pt has been clicked
            X2 = Xcurr
            Y2 = Ycurr
            rXvecDiff = X2 - X1
            rYvecDiff = Y2 - Y1
            rAngle = Tan(rYvecDiff / rXvecDiff) * 180 / PI
            rYdiff = Abs(rYvecDiff)
            rFib61 = rYdiff * 0.618
            rFib50 = rYdiff * 0.5
            rFib38 = rYdiff * 0.382
            If Y1 < Y2 Then
                rYstart = Y1
            Else
                rYstart = Y2
            End If
            If X1 > X2 Then
                iXstart = X2
            Else
                iXstart = X1
            End If
        End If
        Call DrawLoopEventTimer
    Loop
    Call RestoreSaveGdiInfo2
    picBx.DrawStyle = ToolStyle
    picBx.DrawMode = ToolMode
    picBx.DrawWidth = ToolWidth
    picBx.Line (X1, Y1)-(X2, Y2), ToolColor
    picBx.Line (iXstart, rYstart)-(iMaxDrawRightX, rYstart), ToolColor
    picBx.Line (iXstart, rYstart + rFib61)-(iMaxDrawRightX, rYstart + rFib61), ToolColor
    picBx.Line (iXstart, rYstart + rFib50)-(iMaxDrawRightX, rYstart + rFib50), ToolColor
    picBx.Line (iXstart, rYstart + rFib38)-(iMaxDrawRightX, rYstart + rFib38), ToolColor
    picBx.Line (iXstart, rYstart + rYdiff)-(iMaxDrawRightX, rYstart + rYdiff), ToolColor

    picBxV.Picture = picBx.Image
    Call RestoreGdiInfo3

End Sub
Private Sub DrawLoopEventTimer()
    If Timer - iPicTimer > 1 Then
        RaiseEvent DrawLoopIsRunning
        iPicTimer = Timer
    End If
End Sub
Private Sub InitDrawingTool()
    fCancelDrawingTool = False
    IsDrawing = True
    Screen.MouseIcon = LoadResPicture(101, vbResCursor)
    Screen.MousePointer = vbCustom
    ltimer = Timer
    iPicTimer = Timer
    iMouseClickNum = 0: fMouseClickEnabled = True
    RaiseEvent DrawingStarted
End Sub

Private Sub SaveGdiInfo1()
    'save all original pb settings
    iFillOld = picBxV.FillStyle
    iOldFillColor = picBxV.FillColor
    iOldStyle = picBxV.DrawStyle
    lOldWidth = picBxV.DrawWidth
    lDrawModeOld = picBxV.DrawMode
End Sub
Private Sub RestoreSaveGdiInfo2()
    'restore settings to 1st pb and save 2nd ones
    On Error Resume Next
    picBxV.DrawMode = lDrawModeOld
    picBxV.FillStyle = iFillOld
    picBxV.FillColor = iOldFillColor
    picBxV.DrawWidth = lOldWidth
    picBxV.DrawStyle = iOldStyle
    iOldStyle = picBx.DrawStyle
    lOldWidth = picBx.DrawWidth
    lDrawModeOld = picBx.DrawMode
    iFillOld = picBx.FillStyle
    iOldFillColor = picBx.FillColor
End Sub
Private Sub RestoreGdiInfo3()
    'restore 2nd pb settings and clean up
    On Error Resume Next
    picBx.DrawMode = lDrawModeOld
    picBx.FillStyle = iFillOld
    picBx.FillColor = iOldFillColor
    picBx.DrawWidth = lOldWidth
    picBx.DrawStyle = iOldStyle
    RaiseEvent DrawingDone
    fMouseClickEnabled = False
    IsDrawing = False
    Call ClipCursor(rectOrg)
    Screen.MousePointer = vbDefault
End Sub
Private Sub CancelDrawing()
    Call RestoreSaveGdiInfo2
    Call RestoreGdiInfo3
    picBxV.Cls
    picBx.Cls
    IsDrawing = False
End Sub
Private Function Panel2Draw(iYcurr As Long) As Long
    'deterimine which panel to draw to
    Dim lpRect As RECT, iCaptionHeight As Long

    iCaptionHeight = GetSystemMetrics(SM_CYCAPTION)
    lpRect.Left = picBxV.Left \ Screen.TwipsPerPixelX
    lpRect.Right = (picBxV.Left + picBxV.Width) \ Screen.TwipsPerPixelX
    Select Case iYcurr
        Case Is < rSplit1  'price panel
            lpRect.Top = picBxV.ScaleTop + iCaptionHeight
            lpRect.Bottom = rSplit1 + iCaptionHeight
            Panel2Draw = 1
        Case Is > rSplit2  'indicator panel
            lpRect.Top = (picBxV.Top + rSplit2 + 2) + iCaptionHeight
            lpRect.Bottom = (picBxV.Top + iBottomPlotMargin) + iCaptionHeight
            Panel2Draw = 2
        Case Else  'vol panel
            lpRect.Top = (picBxV.Top + rSplit1 + 2) + iCaptionHeight
            lpRect.Bottom = (picBxV.Top + rSplit2) + iCaptionHeight
            Panel2Draw = 3
    End Select
    'restrict mouse to the panel drawn to
    Call GetClipCursor(rectOrg)
    Call ClipCursor(lpRect)

End Function
Private Function RectFrom2PointsF(Pt1 As POINTSINGLE, Pt2 As POINTSINGLE, rcReturn As RECT) As Boolean
    'Get bounding rect of 2 points
    If Pt1.x = Pt2.x Or Pt1.y = Pt2.y Then Exit Function  'points the same
    If Pt1.x > Pt2.x Then
        rcReturn.Right = Pt1.x
        rcReturn.Left = Pt2.x
    Else
        rcReturn.Right = Pt2.x
        rcReturn.Left = Pt1.x
    End If
    If Pt1.y > Pt2.y Then
        rcReturn.Top = Pt2.y
        rcReturn.Bottom = Pt1.y
    Else
        rcReturn.Top = Pt1.y
        rcReturn.Bottom = Pt2.y
    End If
    RectFrom2PointsF = True
End Function
Private Function SqrFrom2PointsF(Pt1 As POINTSINGLE, Pt2 As POINTSINGLE, rcReturnSQ As RECT) As Boolean
    'Get bounding square of 2 points
    If Pt1.x = Pt2.x Or Pt1.y = Pt2.y Then Exit Function 'points the same
    Dim rDiffX As Single, rDiffY As Single, iUpBnd As Long, iLoBnd As Long

    rDiffX = Abs(Pt1.x - Pt2.x)
    rDiffY = Abs(Pt1.y - Pt2.y)
    'make sure we don't draw out of bounds
    Select Case iPanel
        Case 1
            iUpBnd = 0
            iLoBnd = rSplit1
        Case 2
            iUpBnd = rSplit1
            iLoBnd = rSplit2
        Case 3
            iUpBnd = rSplit2
            iLoBnd = iBottomPlotMargin
    End Select
    If rDiffX > rDiffY Then  'change top-bott
        If Pt1.x > Pt2.x Then
            rcReturnSQ.Right = Pt1.x
            rcReturnSQ.Left = Pt2.x
        Else
            rcReturnSQ.Right = Pt2.x
            rcReturnSQ.Left = Pt1.x
        End If
        If Pt1.y > Pt2.y Then 'y1 is bottom
            rcReturnSQ.Top = Pt1.y - rDiffX
            If rcReturnSQ.Top < iUpBnd Then Exit Function
            rcReturnSQ.Bottom = Pt1.y
        Else 'y1 is top
            rcReturnSQ.Top = Pt1.y
            rcReturnSQ.Bottom = Pt1.y + rDiffX
            If rcReturnSQ.Bottom > iLoBnd Then Exit Function
        End If
    Else  'change right-left
        If Pt1.x > Pt2.x Then  'x1 is right
            rcReturnSQ.Right = Pt1.x
            rcReturnSQ.Left = Pt1.x - rDiffY
            If rcReturnSQ.Left < 0 Then Exit Function
        Else  'x1 is left
            rcReturnSQ.Right = Pt1.x + rDiffY
            If rcReturnSQ.Right > iMaxDrawRightX Then Exit Function
            rcReturnSQ.Left = Pt1.x
        End If
        If Pt1.y > Pt2.y Then
            rcReturnSQ.Top = Pt2.y
            rcReturnSQ.Bottom = Pt1.y
        Else
            rcReturnSQ.Top = Pt1.y
            rcReturnSQ.Bottom = Pt2.y
        End If
    End If

    SqrFrom2PointsF = True
End Function

Public Property Get ToolColor() As Long
    ToolColor = iToolColor
End Property

Public Property Let ToolColor(iToolColorA As Long)
    iToolColor = iToolColorA
End Property
Public Property Get ToolFillColor() As Long
    ToolFillColor = iToolFillColor
End Property

Public Property Let ToolFillColor(iToolFillColorA As Long)
    iToolFillColor = iToolFillColorA
End Property
Public Property Get ToolFillStyle() As Integer
    ToolFillStyle = iToolFillStyle
End Property

Public Property Let ToolFillStyle(iToolFillStyleA As Integer)
    iToolFillStyle = iToolFillStyleA
End Property
Public Property Get ToolStyle() As Long
    ToolStyle = iToolStyle
End Property

Public Property Let ToolStyle(iToolStyleA As Long)
    iToolStyle = iToolStyleA
End Property
Public Property Get ToolWidth() As Long
    ToolWidth = iToolWidth
End Property

Public Property Let ToolWidth(iToolWidthA As Long)
    iToolWidth = iToolWidthA
End Property
Public Property Get ToolMode() As Integer
    ToolMode = iToolMode
End Property

Public Property Let ToolMode(iToolModeA As Integer)
    iToolMode = iToolModeA
End Property
Public Property Get Extend() As Long
    Extend = iExtend
End Property

Public Property Let Extend(iExtendA As Long)
    iExtend = iExtendA
End Property

Public Property Get UseOrigin() As Boolean
    UseOrigin = fUseOrigin
End Property

Public Property Let UseOrigin(fUseOriginA As Boolean)
    fUseOrigin = fUseOriginA
End Property
Public Property Get picBx() As PictureBox
    Set picBx = objpicBx
End Property

Public Property Set picBx(objpicBxA As PictureBox)
    Set objpicBx = objpicBxA
End Property
Public Property Get picBxV() As PictureBox
    Set picBxV = objpicBxV
End Property

Public Property Set picBxV(objpicBxVA As PictureBox)
    Set objpicBxV = objpicBxVA
End Property

Public Property Get MouseClickEnabled() As Boolean
    MouseClickEnabled = fMouseClickEnabled
End Property

Public Property Let MouseClickEnabled(fMouseClickEnabledA As Boolean)
    fMouseClickEnabled = fMouseClickEnabledA
End Property

Public Property Get MouseClickNum() As Long
    MouseClickNum = iMouseClickNum
End Property

Public Property Let MouseClickNum(iMouseClickNumA As Long)
    iMouseClickNum = iMouseClickNumA
End Property
Public Property Get Xcurr() As Long
    Xcurr = iXcurr
End Property

Public Property Let Xcurr(iXcurrA As Long)
    iXcurr = iXcurrA
End Property

Public Property Get Ycurr() As Long
    Ycurr = iYcurr
End Property

Public Property Let Ycurr(iYcurrA As Long)
    iYcurr = iYcurrA
End Property


Public Property Get YcurrMov() As Long
    YcurrMov = iYcurrMov
End Property

Public Property Let YcurrMov(iYcurrMovA As Long)
    iYcurrMov = iYcurrMovA
End Property


Public Property Get XcurrMov() As Long
    XcurrMov = iXcurrMov
End Property

Public Property Let XcurrMov(iXcurrMovA As Long)
    iXcurrMov = iXcurrMovA
End Property


Private Sub Class_Initialize()
    ToolColor = vbRed
    ToolStyle = vbSolid
    ToolWidth = 1
    ToolMode = vbCopyPen
    ToolFillStyle = 1
    ToolFillColor = 10900825
    Extend = False
    fUseOrigin = True
    fMouseClickEnabled = False
    iMouseClickNum = 0
End Sub