GFCurveMaker/GFCurveMaker.frm
VERSION 5.00
Begin VB.Form GFCurveMakerfrm
Caption = "[...]"
ClientHeight = 5955
ClientLeft = 60
ClientTop = 435
ClientWidth = 6915
LinkTopic = "Form1"
ScaleHeight = 5955
ScaleWidth = 6915
StartUpPosition = 3 'Windows‑Standard
Begin VB.TextBox GFCMHelpText
BeginProperty Font
Name = "Fixedsys"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 0
MultiLine = ‑1 'True
ScrollBars = 2 'Vertikal
TabIndex = 3
Top = 780
Visible = 0 'False
Width = 2715
End
Begin VB.OptionButton GFCMModeHelpOption
Height = 675
Left = 660
Picture = "GFCurveMaker.frx":0000
Style = 1 'Grafisch
TabIndex = 1
Top = 0
Width = 675
End
Begin VB.OptionButton GFCMModeDrawOption
Height = 675
Left = 0
Picture = "GFCurveMaker.frx":0442
Style = 1 'Grafisch
TabIndex = 0
Top = 0
Value = ‑1 'True
Width = 675
End
Begin VB.PictureBox GFCMDrawPicture
AutoRedraw = ‑1 'True
Height = 5175
Left = 0
ScaleHeight = 341
ScaleMode = 3 'Pixel
ScaleWidth = 457
TabIndex = 4
Top = 780
Width = 6915
End
Begin VB.Label GFCMPosLabel
Caption = "[...]"
BeginProperty Font
Name = "MS Sans Serif"
Size = 24
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Left = 1440
TabIndex = 2
Top = 60
Width = 5475
End
End
Attribute VB_Name = "GFCurveMakerfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2003 by Louis. Form to create 'weight curves' for any task.
'
'Note that this project was developed step by step, first fixed values with no
'verifying were used and after some successful tests factors and verifying
'were added. It was very important to perform abstraction (create many
'auxiliary functions for often used actions), without abstraction everything
'had ended in chaos.
'
'GFCurveMaker_Draw
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'ProgramGetMousePos[X, Y]
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
'general use
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'ProgramGetMousePos[X, Y]
Private Type POINTAPI
X As Long
Y As Long
End Type
'CurveStruct ‑ general data about curve
Private Type CurveStruct
CurveArrayLBound As Long 'passed CurveArray()
CurveArrayUBound As Long 'passed CurveArray()
CurveArraySize As Long 'passed CurveArray()
CurveValueMin As Long ''description' of x value (e.g. 50 for 50 Hertz)
CurveValueMax As Long ''description' of x value (e.g. 20000 for 20 kHz)
CurveValueUnitDescription As String 'e.g. Hertz
CurveValueStep As Long 'min distance between two points (not supported yet)
CurveHelpText As String
CurveHelpTextFont As StdFont
FormCaption As String
DrawOffsetX As Long 'when waiting to get an array index from mouse pos then add, if wanting to draw then subtract
DrawOffsetY As Long 'not supported yet
End Type
Dim CurveStructVar As CurveStruct
Dim CurveArray() As Double 'not in user types as there size limited; 'private' CurveArray()
Dim CurvePointExistingFlagArray() As Boolean 'if there's a manipulation point at a given position in private CurveArray()
'Version
Const Version As String = "v1.0" 'the earlier the crappier
'other
Dim MouseXPosCurrent As Single
Dim MouseYPosCurrent As Single
Dim OffsetChangingEnabledFlag As Boolean
Dim MouseXPosOriginal As Long 'screen‑related mouse coordinated used for changing offset
Dim MouseYPosOriginal As Long 'screen‑related mouse coordinated used for changing offset
Dim DragPointUsedFlag As Boolean
Dim DragPointIndex As Long 'CurveArray() index
Dim CancelFlag As Boolean
Private Sub Form_Load()
'on error resume next
End Sub
Private Sub Form_Resize()
'on error resume next
GFCMDrawPicture.Height = MAX(Me.ScaleHeight ‑ GFCMDrawPicture.Top, 0)
GFCMHelpText.Height = MAX(Me.ScaleHeight ‑ GFCMHelpText.Top, 0)
GFCMDrawPicture.Width = MAX(Me.ScaleWidth ‑ GFCMDrawPicture.Left, 0)
GFCMHelpText.Width = MAX(Me.ScaleWidth ‑ GFCMHelpText.Left, 0)
GFCMPosLabel.Width = MAX(Me.ScaleWidth ‑ GFCMPosLabel.Left, 0)
Call Curve_Draw(CurveArray())
End Sub
Private Sub GFCMDrawPicture_KeyDown(KeyCode As Integer, Shift As Integer)
'on error resume next
Dim PointIndex As Long
Dim PointFor As Long
'begin
Select Case KeyCode
Case vbKeyInsert
PointIndex = STUFF_MAX(STUFF_MIN(CurveStructVar.CurveArraySize, MouseXPosCurrent + CurveStructVar.DrawOffsetX), 1&)
CurvePointExistingFlagArray(PointIndex) = True 'no matter if already inserted here (True is True)
Call Curve_Draw(CurveArray()) 'display changes
Case vbKeyDelete
PointIndex = STUFF_MAX(STUFF_MIN(CurveStructVar.CurveArraySize, MouseXPosCurrent + CurveStructVar.DrawOffsetX), 1&)
Select Case PointIndex
Case CurveStructVar.CurveArrayLBound, CurveStructVar.CurveArrayUBound
MsgBox "Sorry, these points cannot be deleted.", vbOKOnly + vbInformation
Case Else
CurvePointExistingFlagArray(PointIndex) = False
Call Curve_Draw(CurveArray()) 'display changes
End Select
Case vbKeyDown
For PointFor = 1 To CurveStructVar.CurveArraySize
If (CurveArray(PointFor) ‑ 0.01) < 0# Then GoTo Jump1:
Next PointFor
For PointFor = 1 To CurveStructVar.CurveArraySize
CurveArray(PointFor) = CurveArray(PointFor) ‑ 0.01
Next PointFor
Call Curve_Draw(CurveArray())
Jump1:
Case vbKeyUp
For PointFor = 1 To CurveStructVar.CurveArraySize
If (CurveArray(PointFor) + 0.01) > 1# Then GoTo Jump2:
Next PointFor
For PointFor = 1 To CurveStructVar.CurveArraySize
CurveArray(PointFor) = CurveArray(PointFor) + 0.01
Next PointFor
Call Curve_Draw(CurveArray())
Jump2:
End Select
End Sub
Private Sub GFCMDrawPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Dim IndexLeft As Long
Dim IndexRight As Long
'begin
Select Case Button
Case vbLeftButton
'
DragPointUsedFlag = True
'
IndexLeft = Curve_GetLeftNeighborPointIndex(MouseXPosCurrent + CurveStructVar.DrawOffsetX)
IndexRight = Curve_GetRightNeighborPointIndex(MouseXPosCurrent + CurveStructVar.DrawOffsetX)
'
If Abs(IndexLeft ‑ (MouseXPosCurrent + CurveStructVar.DrawOffsetX)) < _
Abs(IndexRight ‑ (MouseXPosCurrent + CurveStructVar.DrawOffsetX)) Then
DragPointIndex = IndexLeft
Else
DragPointIndex = IndexRight
End If
'
Case vbRightButton
'
OffsetChangingEnabledFlag = True
MouseXPosOriginal = ProgramGetMousePosX
MouseYPosOriginal = ProgramGetMousePosY
'
End Select
End Sub
Private Sub GFCMDrawPicture_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
'preset
MouseXPosCurrent = X
MouseYPosCurrent = Y
'begin
'
GFCMPosLabel.Caption = _
CStr(CurveStructVar.CurveValueMin + CSng(MouseXPosCurrent + CurveStructVar.DrawOffsetX) / CSng(CurveStructVar.CurveArraySize) * (CSng(CurveStructVar.CurveValueMax ‑ CurveStructVar.CurveValueMin + 1&))) + " " + _
CurveStructVar.CurveValueUnitDescription
'
If DragPointUsedFlag = True Then
CurveArray(DragPointIndex) = _
(1# ‑ (CDbl(MouseYPosCurrent) / GFCMDrawPicture.ScaleHeight))
Select Case CurveArray(DragPointIndex)
Case Is > 1#
CurveArray(DragPointIndex) = 1#
Case Is < 0#
CurveArray(DragPointIndex) = 0#
End Select
Call Curve_Smooth(Curve_GetLeftNeighborPointIndex(DragPointIndex ‑ 1&), DragPointIndex)
Call Curve_Smooth(DragPointIndex, Curve_GetRightNeighborPointIndex(DragPointIndex + 1&))
Call Curve_Draw(CurveArray())
End If
If OffsetChangingEnabledFlag = True Then
CurveStructVar.DrawOffsetX = CurveStructVar.DrawOffsetX ‑ (ProgramGetMousePosX ‑ MouseXPosOriginal)
CurveStructVar.DrawOffsetY = CurveStructVar.DrawOffsetY ‑ (ProgramGetMousePosY ‑ MouseYPosOriginal) 'although not in use
MouseXPosOriginal = ProgramGetMousePosX
MouseYPosOriginal = ProgramGetMousePosY
Select Case CurveStructVar.DrawOffsetX
Case Is > ((CurveStructVar.CurveArraySize ‑ GFCMDrawPicture.ScaleWidth) + 10&)
CurveStructVar.DrawOffsetX = (CurveStructVar.CurveArraySize ‑ GFCMDrawPicture.ScaleWidth) + 10
Case Is < ‑10&
CurveStructVar.DrawOffsetX = ‑10&
End Select
Select Case CurveStructVar.DrawOffsetY
Case Is > 0&, Is < 0&
CurveStructVar.DrawOffsetY = 0& 'not in use
End Select
Call Curve_Draw(CurveArray())
End If
End Sub
Private Sub GFCMDrawPicture_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Select Case Button
Case vbLeftButton
DragPointUsedFlag = False 'reset
DragPointIndex = 0 'reset
Case vbRightButton
OffsetChangingEnabledFlag = False 'reset
End Select
End Sub
Private Sub GFCMModeDrawOption_Click()
'on error resume next
If GFCMModeDrawOption.Value = True Then
GFCMDrawPicture.Visible = True
GFCMHelpText.Visible = False
Else
GFCMDrawPicture.Visible = False
GFCMHelpText.Visible = True
End If
End Sub
Private Sub GFCMModeHelpOption_Click()
'on error resume next
If GFCMModeDrawOption.Value = True Then
GFCMDrawPicture.Visible = True
GFCMHelpText.Visible = False
Else
GFCMDrawPicture.Visible = False
GFCMHelpText.Visible = True
End If
End Sub
'************************************INTERFACE SUBS*************************************
Public Sub GFCurveMaker_Draw(ByRef CurveArrayPassed() As Double, ByVal CurveValueMin As Long, ByVal CurveValueMax As Long, ByVal CurveValueUnitDescription As String, ByVal CurveValueStep As Long, ByVal CurveHelpText As String, ByVal FormCaption As String, Optional ByRef CurveHelpTextFont As StdFont)
'on error resume next
'preset
CurveStructVar.CurveArrayLBound = LBound(CurveArrayPassed())
CurveStructVar.CurveArrayUBound = UBound(CurveArrayPassed())
CurveStructVar.CurveArraySize = CurveStructVar.CurveArrayUBound ‑ CurveStructVar.CurveArrayLBound + 1&
CurveStructVar.CurveValueMin = CurveValueMin
CurveStructVar.CurveValueMax = CurveValueMax
CurveStructVar.CurveValueUnitDescription = CurveValueUnitDescription
CurveStructVar.CurveValueStep = CurveValueStep 'not supported yet
'
ReDim CurveArray(1 To CurveStructVar.CurveArraySize) As Double
ReDim CurvePointExistingFlagArray(1 To CurveStructVar.CurveArraySize) As Boolean
Call CopyMemory(CurveArray(1), CurveArrayPassed(CurveStructVar.CurveArrayLBound), CurveStructVar.CurveArraySize * 8&)
CurvePointExistingFlagArray(1) = True 'preset
CurvePointExistingFlagArray(CurveStructVar.CurveArraySize) = True 'preset
'
CurveStructVar.FormCaption = FormCaption
CurveStructVar.CurveHelpText = CurveHelpText
Set CurveStructVar.CurveHelpTextFont = CurveHelpTextFont
GFCurveMakerfrm.Caption = FormCaption
GFCMHelpText.Text = CurveHelpText
'
If Not (CurveHelpTextFont Is Nothing) Then
Set GFCMHelpText.Font = CurveHelpTextFont
End If
'reset
CancelFlag = False 'reset
CurveStructVar.DrawOffsetX = 0 'reset
CurveStructVar.DrawOffsetY = 0 'reset
'begin (enter modal loop)
Call Curve_Draw(CurveArray())
Me.Enabled = True
Me.Visible = True
Me.WindowState = vbNormal
Me.Refresh
Do
Call Sleep(10) 'decrease CPU usage
DoEvents
Loop Until (CancelFlag = True)
'
Me.Visible = False
Me.Enabled = False
Me.Refresh
'
Call CopyMemory(CurveArrayPassed(CurveStructVar.CurveArrayLBound), CurveArray(1), CurveStructVar.CurveArraySize * 8&)
End Sub
'*********************************END OF INTERFACE SUBS*********************************
'***CURVE***
Private Function Curve_Draw(ByRef CurveArray() As Double)
'on error resume next
Dim CurveFor As Long
'preset
'reset
GFCMDrawPicture.Cls 'reset
'begin
With CurveStructVar
For CurveFor = 1 To (CurveStructVar.CurveArraySize ‑ 1&)
Call StuffFastLine_Draw(GFCMDrawPicture.hDC, CurveFor ‑ .DrawOffsetX, GFCMDrawPicture.ScaleHeight ‑ CurveArray(CurveFor) * GFCMDrawPicture.ScaleHeight ‑ 1!, _
CurveFor ‑ .DrawOffsetX + 1&, GFCMDrawPicture.ScaleHeight ‑ CurveArray(CurveFor + 1&) * GFCMDrawPicture.ScaleHeight ‑ 1!)
If (CurvePointExistingFlagArray(CurveFor)) Then
GFCMDrawPicture.Line (CurveFor ‑ .DrawOffsetX ‑ 2!, GFCMDrawPicture.ScaleHeight ‑ CurveArray(CurveFor) * GFCMDrawPicture.ScaleHeight ‑ 3!)‑( _
CurveFor ‑ .DrawOffsetX + 2!, GFCMDrawPicture.ScaleHeight ‑ CurveArray(CurveFor) * GFCMDrawPicture.ScaleHeight + 1!), GFCMDrawPicture.ForeColor, BF
End If
Next CurveFor
CurveFor = CurveStructVar.CurveArraySize
If (CurvePointExistingFlagArray(CurveFor)) Then
GFCMDrawPicture.Line (CurveFor ‑ .DrawOffsetX ‑ 2!, GFCMDrawPicture.ScaleHeight ‑ CurveArray(CurveFor) * GFCMDrawPicture.ScaleHeight ‑ 3!)‑( _
CurveFor ‑ .DrawOffsetX + 2!, GFCMDrawPicture.ScaleHeight ‑ CurveArray(CurveFor) * GFCMDrawPicture.ScaleHeight + 1!), GFCMDrawPicture.ForeColor, BF
End If
End With
GFCMDrawPicture.Refresh 'important
End Function
Private Function Curve_GetLeftNeighborPointIndex(ByVal CurveArrayIndex As Long) As Long
'on error resume next
Dim Temp As Long
'verify
Select Case CurveArrayIndex
Case Is < 1
CurveArrayIndex = 1
Case Is > CurveStructVar.CurveArraySize
CurveArrayIndex = CurveStructVar.CurveArraySize
End Select
'begin
If (CurvePointExistingFlagArray(CurveArrayIndex)) Then
Curve_GetLeftNeighborPointIndex = CurveArrayIndex
Exit Function
End If
For Temp = (CurveArrayIndex ‑ 1&) To 1& Step (‑1&)
If (CurvePointExistingFlagArray(Temp)) Then
Curve_GetLeftNeighborPointIndex = Temp
Exit Function
End If
Next Temp
Curve_GetLeftNeighborPointIndex = 0 'should not happen (there are always two bordering points)
Exit Function
End Function
Private Function Curve_GetRightNeighborPointIndex(ByVal CurveArrayIndex As Long) As Long
'on error resume next
Dim Temp As Long
'verify
Select Case CurveArrayIndex
Case Is < 1
CurveArrayIndex = 1
Case Is > CurveStructVar.CurveArraySize
CurveArrayIndex = CurveStructVar.CurveArraySize
End Select
'begin
If (CurvePointExistingFlagArray(CurveArrayIndex)) Then
Curve_GetRightNeighborPointIndex = CurveArrayIndex
Exit Function
End If
For Temp = (CurveArrayIndex + 1&) To CurveStructVar.CurveArraySize
If (CurvePointExistingFlagArray(Temp)) Then
Curve_GetRightNeighborPointIndex = Temp
Exit Function
End If
Next Temp
Curve_GetRightNeighborPointIndex = 0 'should not happen (there are always two bordering points)
Exit Function
End Function
Private Sub Curve_Smooth(ByVal Index1 As Long, ByVal Index2 As Long)
'on error resume next 'Index2 must be greater than Index1
Dim CurveValue1 As Double
Dim CurveValue2 As Double
Dim Temp As Long
'preset
CurveValue1 = CurveArray(Index1) 'will be changed
CurveValue2 = CurveArray(Index2) 'will be changed
'begin
For Temp = (Index1 + 1&) To (Index2 ‑ 1&) 'don't move border points or rounding errors will screw 'em up (or division by 0)
CurveArray(Temp) = _
CurveValue1 * ((CDbl(Index2) ‑ CDbl(Temp)) / (CDbl(Index2) ‑ CDbl(Index1))) + _
CurveValue2 * (1# ‑ ((CDbl(Index2) ‑ CDbl(Temp)) / (CDbl(Index2) ‑ CDbl(Index1))))
Next Temp
End Sub
Public Property Let CurveForeColor(ByVal Color As Long)
'on error resume next
GFCMDrawPicture.ForeColor = CurveForeColor
End Property
Public Property Set CurveForeColor() As Long
'on error resume next
CurveForeColor = GFCMDrawPicture.ForeColor
End Property
Public Property Let CurveBackColor(ByVal Color As Long)
'on error resume next
GFCMDrawPicture.BackColor = Color
End Property
Public Property Set CurveBackColor() As Long
'on error resume next
CurveBackColor = GFCMDrawPicture.BackColor
End Property
'***END OF CURVE***
'***OTHER***
Public Function ProgramGetMousePosX() As Long
'On Error Resume Next 'the format is: pixels
Dim CurrentMousePos As POINTAPI
Call GetCursorPos(CurrentMousePos)
ProgramGetMousePosX = CurrentMousePos.X
End Function
Public Function ProgramGetMousePosY() As Long
'On Error Resume Next 'the format is: pixels
Dim CurrentMousePos As POINTAPI
Call GetCursorPos(CurrentMousePos)
ProgramGetMousePosY = CurrentMousePos.Y
End Function
Private Function MAX(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'on error resume next
If Value1 > Value2 Then
MAX = Value1
Else
MAX = Value2
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
'on error resume next
CancelFlag = True
End Sub
[END OF FILE]