drawingtools.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CDrawingTools"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************************
' ：） 人人为我，我为人人 ：）
'枕善居汉化收藏整理
'发布日期：06/06/26
'描    述：实时股票图表曲线示例 Ver 1.0
'网    站：http://www.mndsoft.com/
'e-mail  ：[e-mail]   最新的邮箱,如果您有新的好的代码别忘记给枕善居哦
'OICQ    ：88382850
'****************************************************************************
Option Explicit

Public Event DrawingInstructions(sText As String)
Public Event DrawLoopIsRunning()
Public Event DrawingStarted()
Public Event DrawingDone()

Private lDrawModeOld As Long, iOldStyle As Long, lOldWidth As Long, iFillOld As Integer
Private iPicTimer As Long, ltimer As Single, iPanel As Integer
Private rectOrg As RECT, iExtend As Long, iToolFillColor As Long, iOldFillColor As Long
Private iToolMode As Integer, iToolWidth As Long, iToolStyle As Long
Private iToolColor As Long, objpicBxV As PictureBox, objpicBx As PictureBox
Private fMouseClickEnabled As Boolean, iMouseClickNum As Long
Private iXcurr As Long, iYcurr As Long, iYcurrMov As Long, iXcurrMov As Long
Private iToolFillStyle As Integer, fUseOrigin As Boolean
Private X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
Private XextR As Single, YextR As Single, XextL As Single, YextL As Single
Private diffX1 As Single, diffY1 As Single, diffX2 As Single, diffY2 As Single

Public Sub TrendLine(Optional fDrawParallel As Boolean = False)

    Dim rRect As RECT, iHasRun As Integer, iNumOfMousePts As Long
'*******************
    If fDrawParallel Then
        Dim X3 As Single, Y3 As Single
        iNumOfMousePts = 3
    Else
        iNumOfMousePts = 2
    End If
    Call InitDrawingTool
    On Error Resume Next
    RaiseEvent DrawingInstructions("Pick 1st Pt.")
    Do While iMouseClickNum < iNumOfMousePts
        DoEvents
        If fCancelDrawingTool Then Call CancelDrawing: Exit Sub
        If iMouseClickNum = 1 Then
            If iHasRun = 0 Then 'do onetime ops for this leg of the loop
                X1 = Xcurr
                Y1 = Ycurr
                iHasRun = 1  'prevent from entering this section again
                RaiseEvent DrawingInstructions("Pick Last Pt.")
                iPanel = Panel2Draw(Ycurr)
                Call SaveGdiInfo1
                picBxV.DrawStyle = ToolStyle
                picBxV.DrawMode = ToolMode
                picBxV.DrawWidth = ToolWidth
            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.Refresh
                X2 = XcurrMov
                Y2 = YcurrMov
                picBxV.Line (X1, Y1)-(X2, Y2), ToolColor
                ltimer = Timer
            End If
        ElseIf iMouseClickNum = 2 Then '2nd pt has been clicked
            If iHasRun = 1 Then
                X2 = Xcurr
                Y2 = Ycurr
                If Not fDrawParallel Then Exit Do 'we have all pts for 1 line
                iHasRun = 2  'lockout this if-then section
                RaiseEvent DrawingInstructions("Place Parallel Line")
                diffX1 = ((X1 + X2) / 2) - X1  'get the line segments from the mid pt
                diffY1 = ((Y1 + Y2) / 2) - Y1  'to each end of the 1st line
                diffX2 = ((X1 + X2) / 2) - X2
                diffY2 = ((Y1 + Y2) / 2) - Y2
            End If
            'flicker control
            If Timer - ltimer > 0.1 And ((XcurrMov <> X3) Or (YcurrMov <> Y3)) Then
                picBxV.Refresh
                picBxV.Line (X1, Y1)-(X2, Y2), ToolColor
                X3 = XcurrMov  'pts for the parallel line... it will have the same
                Y3 = YcurrMov  'slope as the 1st. Use these for the mid pt.
                picBxV.Line (X3 - diffX1, Y3 - diffY1)-(X3 - diffX2, Y3 - diffY2), ToolColor
                ltimer = Timer
            End If
        ElseIf iMouseClickNum = 3 Then
            X3 = Xcurr
            Y3 = Ycurr
            diffX1 = X3 - diffX1
            diffY1 = Y3 - diffY1
            diffX2 = X3 - diffX2
            diffY2 = Y3 - diffY2
        End If
        Call DrawLoopEventTimer
    Loop
    Call RestoreSaveGdiInfo2
    picBx.DrawStyle = ToolStyle
    picBx.DrawMode = ToolMode
    picBx.DrawWidth = ToolWidth
    'extension routine.. 0= no ext., 1=right only, 2=left only, 3=both
    If iExtend = 0 Then
        picBx.Line (X1, Y1)-(X2, Y2), ToolColor
        If fDrawParallel Then picBx.Line (diffX1, diffY1)-(diffX2, diffY2), ToolColor
    Else
        If Y1 = Y2 Then 'horz line...  no reason to do the calculations
            If iExtend And 1 Then X2 = iMaxDrawRightX  'ext. right
            If iExtend And 10 Then X1 = 0  'ext left
            picBx.Line (X1, Y1)-(X2, Y2), ToolColor
            If fDrawParallel Then
                picBx.Line (X1, diffY1)-(X2, diffY2), ToolColor
            End If
        Else
            XextR = X2: YextR = Y2
            XextL = X1: YextL = Y1
            'if x>x2 then we want to switch the pts around
            If X1 > X2 Then
                XextR = X1: YextR = Y1
                XextL = X2: YextL = Y2
            End If
            If iExtend And 1 Then Call GetXYExtentLine  'ext. right
            If iExtend And 10 Then Call GetXYExtentLine(False) 'ext left
            picBx.Line (XextL, YextL)-(XextR, YextR), ToolColor
            If fDrawParallel Then
                XextR = diffX2: YextR = diffY2
                XextL = diffX1: YextL = diffY1
                If diffX1 > diffX2 Then
                    XextR = diffX1: YextR = diffY1
                    XextL = diffX2: YextL = diffY2
                End If
                If iExtend And 1 Then Call GetXYExtentLine     'ext. right
                If iExtend And 10 Then Call GetXYExtentLine(False)    'ext left
                picBx.Line (XextL, YextL)-(XextR, YextR), ToolColor
            End If
        End If
    End If

    picBxV.Picture = picBx.Image
    Call RestoreGdiInfo3

End Sub
Private Sub GetXYExtentLine(Optional iDirRight As Long = 1)
    Dim m As Single

    m = (YextR - YextL) / (XextR - XextL) 'slope of line

    If iDirRight = 1 Then 'extend right
        If m > 0 Then 'slope is negative, use lower divider y cross
            'the y coordinate system is backwards so m is positive when slope negative
            If iPanel = 1 Then
                YextR = rSplit1
            ElseIf iPanel = 2 Then
                YextR = rSplit2
            ElseIf iPanel = 3 Then
                YextR = iBottomPlotMargin
            End If
        Else 'slope positive or zero
            If iPanel = 1 Then
                YextR = 0
            ElseIf iPanel = 2 Then
                YextR = rSplit1
            ElseIf iPanel = 3 Then
                YextR = rSplit2
            End If
        End If
        XextR = (YextR - YextL) / m + XextL
        If XextR > iMaxDrawRightX Then
            XextR = iMaxDrawRightX
            YextR = (XextR - XextL) * m + YextL
        End If
    Else  'extend left
        If m > 0 Then 'slope is negative, use upper divider y cross
            'the y coordinate system is backwards so m is positive when slope negative
            If iPanel = 1 Then
                YextL = 0
            ElseIf iPanel = 2 Then
                YextL = rSplit1
            ElseIf iPanel = 3 Then
                YextL = rSplit2
            End If
        Else 'slope positive or zero
            If iPanel = 1 Then
                YextL = rSplit1
            ElseIf iPanel = 2 Then
                YextL = rSplit2
            ElseIf iPanel = 3 Then
                YextL = iBottomPlotMargin
            End If
        End If
        XextL = (YextL - YextR) / m + XextR
        If XextL < 0 Then
            XextL = 0
            YextL = (XextL - XextR) * m + YextR
        End If
    End If
End Sub
Public Function RectAndSquareTool(Optional fDrawSquare As Boolean = False)

    Dim iHasRun As Integer, Pt1 As POINTSINGLE, Pt2 As POINTSINGLE
    Dim rRect As RECT, fValidDraw As Boolean
'*******************

    Call InitDrawingTool
    On Error Resume Next
    RaiseEvent DrawingInstructions("Pick 1st Corner Pt.")
    Do While iMouseClickNum < 2
        DoEvents
        If fCancelDrawingTool Then Call CancelDrawing: Exit Function
        If iMouseClickNum = 1 Then
            If iHasRun = 0 Then
                Pt1.x = Xcurr
                Pt1.y = Ycurr
                iHasRun = 1
                RaiseEvent DrawingInstructions("Pick Last Corner Pt.")
                iPanel = Panel2Draw(Ycurr)
                Call SaveGdiInfo1
                picBxV.DrawStyle = ToolStyle
                picBxV.DrawMode = vbMergePen
                picBxV.DrawWidth = ToolWidth
                picBxV.FillColor = ToolFillColor
                picBxV.FillStyle = ToolFillStyle
            End If
            If Timer - ltimer > 0.1 And ((XcurrMov <> Pt2.x) Or (YcurrMov <> Pt2.y)) Then
                picBxV.Refresh
                Pt2.x = XcurrMov
                Pt2.y = YcurrMov
                If fDrawSquare Then
                    fValidDraw = SqrFrom2PointsF(Pt1, Pt2, rRect)
                Else
                    fValidDraw = RectFrom2PointsF(Pt1, Pt2, rRect)
                End If
                If fValidDraw Then picBxV.Line (rRect.Left, rRect.Top)-(rRect.Right, rRect.Bottom), ToolColor, B
                ltimer = Timer
            End If
        ElseIf iMouseClickNum = 2 Then
            picBxV.DrawMode = ToolMode
            Pt2.x = Xcurr
            Pt2.y = Ycurr
            If fDrawSquare Then
                fValidDraw = SqrFrom2PointsF(Pt1, Pt2, rRect)
            Else
                fValidDraw = RectFrom2PointsF(Pt1, Pt2, rRect)
            End If
        End If
        Call DrawLoopEventTimer
    Loop
    Call RestoreSaveGdiInfo2
    picBx.FillStyle = ToolFillStyle
    picBx.FillColor = ToolFillColor
    picBx.DrawStyle = ToolStyle
    picBx.DrawMode = vbMergePen
    picBx.DrawWidth = ToolWidth
    If fValidDraw Then picBx.Line (rRect.Left, rRect.Top)-(rRect.Right, rRect.Bottom), ToolColor, B
    picBxV.Picture = picBx.Image
    Call RestoreGdiInfo3
End Function

Public Function CircleElipseTool(Optional fDrawCirc As Boolean = False)
    Dim iHasRun As Integer
    Dim rRect As RECT, fValidDraw As Boolean, rDist As Single, oldForeColor As Long
    Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
'*******************

    Call InitDrawingTool
    On Error Resume Next
    RaiseEvent DrawingInstructions("Pick Origin")
    Do While iMouseClickNum < 2
        DoEvents
        If fCancelDrawingTool Then Call CancelDrawing: Exit Function
        If iMouseClickNum = 1 Then
            If iHasRun = 0 Then
                X1 = Xcurr
                Y1 = Ycurr
                iHasRun = 1
                RaiseEvent DrawingInstructions("Pick Last Pt.")
                iPanel = Panel2Draw(Ycurr)
                Call SaveGdiInfo1
                picBxV.DrawStyle = ToolStyle
                picBxV.DrawMode = vbMergePen
                picBxV.DrawWidth = ToolWidth
                picBxV.FillColor = ToolFillColor
                picBxV.FillStyle = ToolFillStyle
            End If
            If Timer - ltimer > 0.1 And ((XcurrMov <> X2) Or (YcurrMov <> Y2)) Then
                picBxV.Refresh
                X2 = XcurrMov
                Y2 = YcurrMov
                If fDrawCirc Then
                    rDist = Sqr((X2 - X1) * (X2 - X1) + (Y2 - Y1) * (Y2 - Y1)) 'radius
                    If fUseOrigin Then
                        picBxV.Circle (X1, Y1), rDist, ToolColor  'origin + radius
                    Else 'opp sides on diameter
                        picBxV.Circle ((X1 + X2) / 2, (Y1 + Y2) / 2), rDist / 2, ToolColor
                    End If
                Else
                    'could select a gdi pen here but using the forecolor works also
                    oldForeColor = picBxV.ForeColor
                    picBxV.ForeColor = ToolColor
                    If fUseOrigin Then
                        'origin + corner
                        Ellipse picBxV.hDC, X1 * 2 - X2, Y1 * 2 - Y2, X2, Y2
                    Else
                        Ellipse picBxV.hDC, X1, Y1, X2, Y2  'diagonal corners
                    End If
                    picBxV.ForeColor = oldForeColor
                End If
                ltimer = Timer
                End If
        ElseIf iMouseClickNum = 2 Then
            picBxV.DrawMode = ToolMode
            X2 = Xcurr
            Y2 = Ycurr
        End If
        Call DrawLoopEventTimer
    Loop
    Call RestoreSaveGdiInfo2
    picBx.FillStyle = ToolFillStyle
    picBx.FillColor = ToolFillColor
    picBx.DrawStyle = ToolStyle
    picBx.DrawMode = vbMergePen
    picBx.DrawWidth = ToolWidth
    If fDrawCirc Then
        rDist = Sqr((X2 - X1) * (X2 - X1) + (Y2 - Y1) * (Y2 - Y1)) 'radius
        If fUseOrigin Then
            picBx.Circle (X1, Y1), rDist, ToolColor  'origin + radius
        Else 'opp sides on diameter
            picBx.Circle ((X1 + X2) / 2, (Y1 + Y2) / 2), rDist / 2, ToolColor
        End If
    Else
        oldForeColor = picBx.ForeColor
        picBx.ForeColor = ToolColor
        If fUseOrigin Then
            'origin + corner
            Ellipse picBx.hDC, X1 * 2 - X2, Y1 * 2 - Y2, X2, Y2
        Else
            Ellipse picBx.hDC, X1, Y1, X2, Y2  'diagonal corners
        End If
        picBx.ForeColor = oldForeColor
    End If
    picBxV.Picture = picBx.Image
    Call RestoreGdiInfo3
End Function

Public Sub FibRetrace()

    Dim rRect As RECT, iHasRun As Integer, iNumOfMousePts As Long, rYdiff As Single
    Dim rFib61 As Single, rFib50 As Single, rFib38 As Single, iXstart As Long
    Dim rXvecDiff As Single, rYvecDiff As Single, rAngle As Single, rYstart As Single
'*******************

    iNumOfMousePts = 2
    Call InitDrawingTool
    On Error Resume Next
    RaiseEvent DrawingInstructions("Pick 1st Extreme.")
    Do While iMouseClickNum < iNumOfMousePts
        DoEvents
        If fCancelDrawingTool Then Call CancelDrawing: Exit Sub
        If iMouseClickNum = 1 Then
            If iHasRun = 0 Then 'do onetime ops for this leg of the loop
                X1 = Xcurr
                Y1 = Ycurr
                iHasRun = 1  'prevent from entering this section again
                RaiseEvent DrawingInstructions("Pick Opposite Extreme")
                iPanel = Panel2Draw(Ycurr)