Option Explicit
Dim fCounter As Long
Dim fString As String
Dim fStrHeight As Single
Dim fStrWidth As Single
Dim fGradient As Double
Dim fB As Double
Dim fStep As Double
'Coordinates of lines to work out intersecting points
Private Type LineType
X1(1) As Double
Y1(1) As Double
X2(1) As Double
Y2(1) As Double
End Type
Dim MyLine As LineType
'Intersecting points
Dim XInt As Double
Dim YInt As Double
'Polygon api coords
Private Type apiCoords
x As Long
y As Long
End Type
Dim PolyPoints(1 To 4) As POINTAPI
Dim lPolyRgn As Long
Dim lBrush As Long
Dim lRet As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As apiCoords, ByVal nCount As Long) As Long
Private Sub Form_Load()
Command1.Caption = "Up"
Command2.Caption = "Down"
Command3.Caption = "Stop"
Timer1.Interval = 100
'1000 for chart and 200 for borders
Picture1.Scale (-200, -200)-(1200, 1200)
With Picture1
.ForeColor = vbRed
.DrawWidth = 2
'Tick marks & labels
'------------------------------------------------------------
For fCounter = 0 To 1000 Step 100
Picture1.Line (-20, fCounter)-(0, fCounter) 'Y Tick
Picture1.Line (fCounter, 1000)-(fCounter, 1020) 'X Tick
fString = CStr(1000 - fCounter)
fStrHeight = .TextHeight(fString) 'height of label
fStrWidth = .TextWidth(fString) 'width of label
'Y labels
.CurrentX = -40 - fStrWidth
.CurrentY = fCounter - fStrHeight \ 2
Picture1.Print fString;
'Y labels
.CurrentX = 1000 - fCounter - fStrWidth \ 2
.CurrentY = 1030
Picture1.Print fString;
Next
.ForeColor = vbBlack
.DrawWidth = 1
End With
'Draw lines and find intersecting points
'------------------------------------------------------------
With MyLine
.X1(0) = 0: .Y1(0) = 700: .X2(0) = 600: .Y2(0) = 0
Picture1.Line (.X1(0), 1000 - .Y1(0))-(.X2(0), 1000 - .Y2(0))
.X1(1) = 0: .Y1(1) = 500: .X2(1) = 900: .Y2(1) = 0
Picture1.Line (.X1(1), 1000 - .Y1(1))-(.X2(1), 1000 - .Y2(1))
XInt = (.Y1(0) - .Y1(1)) / ((.Y1(0) / .X2(0)) - (.Y1(1) / .X2(1)))
YInt = -.Y1(0) / .X2(0) * XInt + .Y1(0)
End With
'Polygon dimensions
'------------------------------------------------------------
PolyPoints(1) = Rescale(0, MyLine.Y1(1))
PolyPoints(2) = Rescale(0, 0)
PolyPoints(3) = Rescale(MyLine.X2(0), 0)
PolyPoints(4) = Rescale(XInt, YInt)
'API calls to fill polygon
'------------------------------------------------------------
lPolyRgn = CreatePolygonRgn(PolyPoints(1), 4, ALTERNATE)
lBrush = CreateSolidBrush(RGB(230, 230, 230)) 'Pick any colour
If Not lBrush = 0 Then
lRet = FillRgn(Picture1.hdc, lPolyRgn, lBrush)
lRet = DeleteObject(lBrush)
End If
lRet = DeleteObject(lPolyRgn)
'Moved axis drawing here to make sure shows up as thick line
'------------------------------------------------------------
With Picture1
.ForeColor = vbRed
.DrawWidth = 2
Picture1.Line (0, 0)-(0, 1000)
Picture1.Line (0, 1000)-(1000, 1000)
End With
'Movable Line
'------------------------------------------------------------
With Line1
.X1 = 0
.Y1 = 700
.X2 = 400
.Y2 = 1000
fGradient = -(1000 - .Y1) / .X2
fB = 1000 - .Y1
End With
End Sub
Private Function Rescale(ByVal XCoord As Long, ByVal YCoord As Long) As POINTAPI
'Function to rescale coordinates to suit scaling
With Picture1
Rescale.x = (XCoord + 200) / Screen.TwipsPerPixelX * .Width / .ScaleWidth
Rescale.y = (1200 - YCoord) / Screen.TwipsPerPixelY * .Height / .ScaleHeight
End With
End Function
Private Sub Command1_Click()
'Move up
fStep = 20
Timer1.Enabled = True
End Sub
Private Sub Command2_Click()
'Move down
fStep = -20
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
With Line1
.X2 = .X2 + fStep
.Y1 = 1000 + fGradient * .X2
End With
End Sub
Private Sub Command3_Click()
Timer1.Enabled = False
End Sub