GFTextMarker/GFTextMarker.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3906
ClientLeft = 56
ClientTop = 350
ClientWidth = 3738
LinkTopic = "Form1"
ScaleHeight = 3906
ScaleWidth = 3738
StartUpPosition = 3 'Windows‑Standard
Begin VB.CommandButton Command1
Caption = "Get Result"
Height = 375
Left = 1560
TabIndex = 2
Top = 3420
Width = 2055
End
Begin VB.PictureBox GFTextMarkerLegendPicture
BeginProperty Font
Name = "Small Fonts"
Size = 5.703
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF80FF&
Height = 2115
Left = 120
ScaleHeight = 2058
ScaleWidth = 3444
TabIndex = 1
Top = 1140
Width = 3495
End
Begin VB.PictureBox GFTextMarkerPicture
BeginProperty Font
Name = "Courier"
Size = 9.27
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 735
Left = 120
ScaleHeight = 686
ScaleWidth = 3444
TabIndex = 0
Top = 180
Width = 3495
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001‑2003 by Louis. Developed for the use in MP3 Renamer 2 only.
'GFTextMarker_ReceiveText
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFTextMarker
Private Type GFTextMarkerStruct
MarkText As String
MarkTextLength As Long
MarkNumber As Integer 'number of different marks
MarkPointer As Integer 'which mark is to be used for next marking
UseMarkPointerFlag As Boolean 'if a mark is to be set or removed
MarkDescriptionArray() As String
MarkColorArray() As Long
MarkSelectionNumber As Integer
MarkSelectionArray() As Integer 'UBound() = Len(MarkText), contains reference to a MarkNumber or 0 for every char
CursorPos As Integer '1‑Len(MarkText)
CursorMoveDirectionOld As Integer 'vbKeyLeft or vbKeyRight
SpaceKeyPressedFlag As Boolean
EffectsEnabledFlag As Boolean
End Type
Dim GFTextMarkerStructVar As GFTextMarkerStruct
'other
Dim NULLARRAYINT() As Integer
Private Sub Form_Load()
'on error resume next
Dim MarkSelectionNumber As Integer
Dim MarkSelectionArray() As Integer
MarkSelectionNumber = Len("ABBA ‑ Waterloo ‑ 01 ‑ Dancing Queen (recorded by Jacco) ‑ (Cut)")
ReDim MarkSelectionArray(1 To MarkSelectionNumber) As Integer
MarkSelectionArray(2) = 2
MarkSelectionArray(3) = 2
MarkSelectionArray(4) = 2
MarkSelectionArray(5) = 2 'etc.
GFTextMarkerStructVar.EffectsEnabledFlag = True
Call GFTextMarker_ReceiveText("ABBA ‑ Waterloo ‑ 01 ‑ Dancing Queen (recorded by Jacco) ‑ (Cut)", MarkSelectionNumber, MarkSelectionArray())
Call GFTextMarker_AddMark("song name", RGB(255, 0, 0))
Call GFTextMarker_AddMark("artist name", RGB(0, 255, 0))
Call GFTextMarker_AddMark("album name", RGB(0, 0, 255))
Call GFTextMarker_AddMark("year name", RGB(0, 255, 255))
Call GFTextMarker_AddMark("comment", RGB(200, 200, 0))
Call GFTextMarker_AddMark("trash", RGB(100, 100, 100))
Call GFTextMarker_DrawLegend(GFTextMarkerStructVar)
Call GFTextMarker_Refresh(GFTextMarkerStructVar)
Call GFTextMarkerLegendPicture_MouseDown(vbLeftButton, 0, 1, 1) 'preset
End Sub
Private Sub Command1_Click()
'on error resume next
Dim mn As Integer
Dim ms() As String
Dim mea() As String
Dim ByteString1() As Byte
Dim ByteString2() As Byte
Dim ByteString3() As Byte
Dim ByteString4() As Byte
Dim Temp As Long
'begin
Call GETBYTESTRINGFROMSTRING(260, ByteString1(), GFTextMarkerStructVar.MarkText)
Call GFTextMarker_GetBorderStringArray(mn, ms(), mea())
For Temp = 1 To mn
Debug.Print ms(Temp)
Debug.Print mea(Temp)
Next Temp
Call BYTESTRINGREMOVESPACE(ByteString1())
ReDim ByteString4(1 To 260) As Byte
Debug.Print "FUCK!"
For Temp = 1 To (mn ‑ 1)
Call GETBYTESTRINGFROMSTRING(260, ByteString2(), ms(Temp))
Call GETBYTESTRINGFROMSTRING(260, ByteString3(), mea(Temp))
Call GetBorderedStringByteEx(ByteString1(), ByteString2(), ByteString3(), ByteString4(), 260)
Call DISPLAYBYTESTRING(ByteString4())
Next Temp
End Sub
'*************************************GFTEXTMARKER**************************************
'NOTE: GFTextMarker was developed for the use in MP3 Renamer 2.
'The user colors the letters of a string to mark special items, in this case
'e.g. the song, artist or album name included in a file name.
'Note that the font of GFTextMarkerPicture must be a font whose letters have
'all the equal width.
'v1.5.
Private Sub GFTextMarker_AddMark(ByVal MarkDescription As String, ByVal MarkColor As Long)
'on error resume next
If Not (GFTextMarkerStructVar.MarkNumber = 32767) Then 'verify
GFTextMarkerStructVar.MarkNumber = GFTextMarkerStructVar.MarkNumber + 1
Else
MsgBox "internal error in GFTextMarker_AddMark(): overflow !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
ReDim Preserve GFTextMarkerStructVar.MarkDescriptionArray(1 To GFTextMarkerStructVar.MarkNumber) As String
ReDim Preserve GFTextMarkerStructVar.MarkColorArray(1 To GFTextMarkerStructVar.MarkNumber) As Long
GFTextMarkerStructVar.MarkDescriptionArray(GFTextMarkerStructVar.MarkNumber) = MarkDescription
GFTextMarkerStructVar.MarkColorArray(GFTextMarkerStructVar.MarkNumber) = MarkColor
End Sub
Private Sub GFTextMarker_ReceiveText(ByVal MarkText As String, ByVal MarkSelectionNumber As Integer, ByRef MarkSelectionArray() As Integer)
'on error resume next 'NOTE: MarkSelectionNumber may be 0 to avoid any letter to be marked.
GFTextMarkerStructVar.MarkText = MarkText
GFTextMarkerStructVar.MarkTextLength = Len(MarkText)
If Not (GFTextMarkerStructVar.MarkTextLength = 0) Then 'verify
'NOTE: do not use 'Preserve' to reset selection array.
GFTextMarkerStructVar.MarkSelectionNumber = GFTextMarkerStructVar.MarkTextLength
ReDim GFTextMarkerStructVar.MarkSelectionArray(1 To GFTextMarkerStructVar.MarkSelectionNumber) As Integer
If Not (MarkSelectionNumber = 0) Then 'because of MarkSelectionArray(0 To 0)
'
'NOTE: GFTextMarkerStructVar.MarkSelectionArray() has always the
'element count MarkTextLength, but not all elements need to be preset.
'
Call CopyMemory(GFTextMarkerStructVar.MarkSelectionArray(1), MarkSelectionArray(1), MIN(MarkSelectionNumber, UBound(GFTextMarkerStructVar.MarkSelectionArray())) * Len(MarkSelectionArray(1)))
End If
Else
GFTextMarkerStructVar.MarkSelectionNumber = 0 'reset
ReDim GFTextMarkerStructVar.MarkSelectionArray(1 To 1) As Integer 'reset
End If
End Sub
Private Function GFTextMarker_GetResult(ByRef MarkSelectionNumber As Integer, ByRef MarkSelectionArray() As Integer) As Boolean
'on error resume next 'function returns True for success or False for any error (user made bad selections)
Dim MarkSelectionUsedArray() As Boolean
Dim TransferLoop As Integer
Dim TestLoop As Integer
'preset
MarkSelectionNumber = GFTextMarkerStructVar.MarkTextLength
'begin
If Not (MarkSelectionNumber = 0) Then
ReDim MarkSelectionArray(1 To MarkSelectionNumber) As Integer
ReDim MarkSelectionUsedArray(1 To MarkSelectionNumber) As Boolean
For TransferLoop = 1 To MarkSelectionNumber
'check if two markings of the same type appear not coherent
If Not (GFTextMarkerStructVar.MarkSelectionArray(TransferLoop) = 0) Then
If TransferLoop > 1 Then
If MarkSelectionUsedArray(GFTextMarkerStructVar.MarkSelectionArray(TransferLoop)) = True Then
If GFTextMarkerStructVar.MarkSelectionArray(TransferLoop) = _
GFTextMarkerStructVar.MarkSelectionArray(TransferLoop ‑ 1) Then
Else
GoTo MarkingError:
End If
End If
End If
'If Not (GFTextMarkerStructVar.MarkSelectionArray(TransferLoop) = 6) Then
' 'NOTE: only trash can be marked uncoherent. 'no!
MarkSelectionUsedArray(GFTextMarkerStructVar.MarkSelectionArray(TransferLoop)) = True
'End If
End If
MarkSelectionArray(TransferLoop) = GFTextMarkerStructVar.MarkSelectionArray(TransferLoop)
Next TransferLoop
Else
GoTo Error:
End If
GFTextMarker_GetResult = True 'ok
Exit Function
Error:
MarkSelectionNumber = 0 'reset (error)
ReDim MarkSelectionArray(1 To 1) As Integer 'reset (error)
GFTextMarker_GetResult = False 'error
Exit Function
MarkingError:
MsgBox "Unfortunately your markings are invalid. Please use one coherent marking per type only !", vbOKOnly + vbExclamation
GoTo Error:
End Function
Private Function GFTextMarker_GetBorderStringArray(ByRef MarkingNumber As Integer, ByRef MarkingStartStringArray() As String, ByRef MarkingEndStringArray() As String) As Boolean
'on error resume next 'function returns True if border strings have been set, False if any error occurred
Dim MarkSelectionNumber As Integer '1 to length of text to mark
Dim MarkSelectionArray() As Integer '1 to number of marks added by GFTextMarker_AddMark()
Dim MarkingLoop As Integer
Dim SearchEndOrStartFlag As Boolean 'True: search end string, False: search start string
Dim Temp As Long
Dim Temp2 As Long
'
'NOTE: this sub was designed for use in MP3 Renamer 2.
'It initializes the passed arrays with the start/end string belonging to the markings.
'Note that MarkingNumber will be equal to the number of markings added by
'GFTextMarker_AddMark() (also the order will be equal).
'Chr$(1)/Chr$(255) element of start/end string means border string (if any) at string start/end.
'A start/end string can also contain '*#*', see GetBorderedStringByteEx() for annotations.
'NOTE: god damn this sub!
'
'preset
MarkingNumber = 0 'reset (error)
ReDim MarkingStartStringArray(1 To 1) As String 'reset (error)
ReDim MarkingEndStringArray(1 To 1) As String 'reset (error)
'begin
If GFTextMarker_GetResult(MarkSelectionNumber, MarkSelectionArray()) = False Then
GFTextMarker_GetBorderStringArray = False 'error
Exit Function
End If
MarkingNumber = GFTextMarkerStructVar.MarkNumber
If Not (MarkingNumber = 0) Then
ReDim MarkingStartStringArray(1 To MarkingNumber) As String
ReDim MarkingEndStringArray(1 To MarkingNumber) As String
End If
For MarkingLoop = 1 To MarkingNumber
For Temp = 1 To MarkSelectionNumber
If SearchEndOrStartFlag = False Then
If MarkSelectionArray(Temp) = MarkingLoop Then
SearchEndOrStartFlag = True
For Temp2 = (Temp ‑ 1) To 1 Step (‑1)
If Not (MarkSelectionArray(Temp2) = 0) Then
MarkingStartStringArray(MarkingLoop) = _
GFTextMarker_RemoveSpace(Mid$(GFTextMarkerStructVar.MarkText, (Temp2 + 1), (Temp ‑ 1) ‑ Temp2))
MarkingStartStringArray(MarkingLoop) = MarkingStartStringArray(MarkingLoop) + _
GFTextMarker_GetBorderStringIndexString(MarkSelectionNumber, MarkSelectionArray(), MarkingStartStringArray(MarkingLoop), (Temp2 + 1))
Exit For
Else
If Temp2 = 1 Then
MarkingStartStringArray(MarkingLoop) = _
Chr$(1) + GFTextMarker_RemoveSpace(Mid$(GFTextMarkerStructVar.MarkText, 1, (Temp ‑ 1)))
'
'NOTE: as the filtered border start string represents the very first char(s) in the
'string Chr$(1) as sign for 'border string located at string start' is added.
'
MarkingStartStringArray(MarkingLoop) = MarkingStartStringArray(MarkingLoop) + _
GFTextMarker_GetBorderStringIndexString(MarkSelectionNumber, MarkSelectionArray(), MarkingStartStringArray(MarkingLoop), 1)
Exit For
End If
End If
Next Temp2
If Temp = 1 Then
MarkingStartStringArray(MarkingLoop) = Chr$(1)
'Exit For 'no!
End If
End If
Else
If Not (MarkSelectionArray(Temp) = MarkingLoop) Then
SearchEndOrStartFlag = False 'reset
For Temp2 = Temp To MarkSelectionNumber
If Not (MarkSelectionArray(Temp2) = 0) Then
MarkingEndStringArray(MarkingLoop) = _
GFTextMarker_RemoveSpace(Mid$(GFTextMarkerStructVar.MarkText, Temp, Temp2 ‑ Temp))
MarkingEndStringArray(MarkingLoop) = MarkingEndStringArray(MarkingLoop) + _
GFTextMarker_GetBorderStringIndexString(MarkSelectionNumber, MarkSelectionArray(), MarkingEndStringArray(MarkingLoop), Temp)
GoTo Jump:
Else
If Temp2 = MarkSelectionNumber Then
MarkingEndStringArray(MarkingLoop) = _
GFTextMarker_RemoveSpace(Mid$(GFTextMarkerStructVar.MarkText, Temp, MarkSelectionNumber ‑ Temp + 1)) + Chr$(255)
'
'NOTE: as the filtered border start string represents the very last char(s) in the
'string Chr$(255) as sign for 'border string located at string start' is added.
'
MarkingEndStringArray(MarkingLoop) = MarkingEndStringArray(MarkingLoop) + _
GFTextMarker_GetBorderStringIndexString(MarkSelectionNumber, MarkSelectionArray(), MarkingEndStringArray(MarkingLoop), Temp)
GoTo Jump:
End If
End If
Next Temp2
End If
If Temp = MarkSelectionNumber Then
SearchEndOrStartFlag = False 'reset
MarkingEndStringArray(MarkingLoop) = Chr$(255)
GoTo Jump:
End If
End If
Next Temp
Jump:
Next MarkingLoop
GFTextMarker_GetBorderStringArray = True 'ok
Exit Function
End Function
Private Function GFTextMarker_GetBorderStringIndexString(ByVal MarkSelectionNumber As Integer, ByRef MarkSelectionArray() As Integer, ByVal BorderString As String, ByVal BorderStringStartPos) As String
'on error resume next 'returns e.g. '*3*'
'Dim BorderStringStartPos As Long
Dim BorderStringEndPos As Long
Dim BorderStringNumber As Long 'number of strings that appear 'before' BorderString (beginning with 0)
Dim SearchStartOrEndFlag As Boolean
Dim Temp As Long
Dim Tempstr$
'
'NOTE: this sub returns an extension string for a border string, e.g. '*3*'.
'God damn this sub, too!
'
For Temp = (BorderStringStartPos ‑ 1) To 1 Step (‑1)
If SearchStartOrEndFlag = False Then
If MarkSelectionArray(Temp) = 0 Then
SearchStartOrEndFlag = True
BorderStringEndPos = Temp
End If
Else
If Not (MarkSelectionArray(Temp) = 0) Then
SearchStartOrEndFlag = False 'reset
BorderStringStartPos = Temp + 1
Tempstr$ = GFTextMarker_RemoveSpace(Mid$(GFTextMarkerStructVar.MarkText, BorderStringStartPos, BorderStringEndPos ‑ BorderStringStartPos + 1))
If Tempstr$ = BorderString Then BorderStringNumber = BorderStringNumber + 1
Else
If Temp = 1 Then
SearchStartOrEndFlag = False 'reset
BorderStringStartPos = Temp
Tempstr$ = GFTextMarker_RemoveSpace(Mid$(GFTextMarkerStructVar.MarkText, BorderStringStartPos, BorderStringEndPos ‑ BorderStringStartPos + 1))
If Tempstr$ = BorderString Then BorderStringNumber = BorderStringNumber + 1
End If
End If
End If
Next Temp
If BorderStringNumber = 0 Then
GFTextMarker_GetBorderStringIndexString = "*1*"
Else
GFTextMarker_GetBorderStringIndexString = "*" + LTrim$(Str$(BorderStringNumber + 1)) + "*"
End If
End Function
Private Sub GFTextMarker_DrawLegend(ByRef GFTextMarkerStructVar As GFTextMarkerStruct)
'on error resume next
Dim LineHeight As Long
Dim DrawColorUnchanged As Long
Dim DrawLoop As Integer
Dim XLoop As Integer
Dim YLoop As Integer
'
'NOTE: marking color and marked text color are fixed
'(Windows colors are used).
'
'reset
GFTextMarkerLegendPicture.Cls 'reset
'preset
GFTextMarkerLegendPicture.AutoRedraw = True 'important
GFTextMarkerLegendPicture.ScaleMode = vbPixels 'important
If (GFTextMarkerLegendPicture.TextHeight(Chr$(32)) + 2) > 15 Then 'ScaleMode is vbPixels
LineHeight = (GFTextMarkerLegendPicture.TextHeight(Chr$(32)) + 2)
Else
LineHeight = 15
End If
'begin
For DrawLoop = 1 To GFTextMarkerStructVar.MarkNumber
With GFTextMarkerLegendPicture
If DrawLoop = GFTextMarkerStructVar.MarkPointer Then
GFTextMarkerLegendPicture.DrawStyle = vbDot
GFTextMarkerLegendPicture.Line (0, (DrawLoop ‑ 1) * LineHeight)‑(GFTextMarkerLegendPicture.ScaleWidth ‑ 1, (DrawLoop ‑ 0) * LineHeight), &H8000000D, BF 'mark color
GFTextMarkerLegendPicture.DrawStyle = vbNormal 'reset
'GFTextMarkerLegendPicture.DrawWidth = 2
For XLoop = 1 To 9
For YLoop = 1 To 9
GFTextMarkerLegendPicture.PSet (5 + XLoop, (DrawLoop ‑ 1) * LineHeight + (LineHeight / 2) ‑ 5 + YLoop), _
GFColor_ChangeBrightness( _
GFTextMarkerStructVar.MarkColorArray(DrawLoop), _
‑((XLoop ‑ 5) * 3 + (YLoop ‑ 5) * 3))
Next YLoop
Next XLoop
'GFTextMarkerLegendPicture.Line (5, (DrawLoop ‑ 1) * LineHeight + (LineHeight / 2) ‑ 5)‑(15, (DrawLoop ‑ 1) * LineHeight + (LineHeight / 2) + 5), RGB(255, 255, 255), B
'GFTextMarkerLegendPicture.DrawWidth = 1
Else
'GFTextMarkerLegendPicture.DrawWidth = 2
For XLoop = 1 To 9
For YLoop = 1 To 9
GFTextMarkerLegendPicture.PSet (5 + XLoop, (DrawLoop ‑ 1) * LineHeight + (LineHeight / 2) ‑ 5 + YLoop), _
GFColor_ChangeBrightness( _
GFTextMarkerStructVar.MarkColorArray(DrawLoop), _
‑((XLoop ‑ 5) * 3 + (YLoop ‑ 5) * 3))
Next YLoop
Next XLoop
'GFTextMarkerLegendPicture.Line (5, (DrawLoop ‑ 1) * LineHeight + (LineHeight / 2) ‑ 5)‑(15, (DrawLoop ‑ 1) * LineHeight + (LineHeight / 2) + 5), RGB(0, 0, 0), B
'GFTextMarkerLegendPicture.DrawWidth = 1
End If
'draw text shadow if enabled 'no! not readable
' If GFTextMarkerStructVar.EffectsEnabledFlag = True Then
' DrawColorUnchanged = GFTextMarkerLegendPicture.ForeColor
' GFTextMarkerLegendPicture.ForeColor = GFColor_MixColor(DrawColorUnchanged, GFTextMarkerLegendPicture.BackColor, 0.1!)
' .CurrentX = 1 + 20
' .CurrentY = 1 + (DrawLoop ‑ 1) * LineHeight + 3 ‑ 2
' GFTextMarkerLegendPicture.Print GFTextMarkerStructVar.MarkDescriptionArray(DrawLoop)
' GFTextMarkerLegendPicture.ForeColor = DrawColorUnchanged
' End If
'draw original text
.CurrentX = 20
.CurrentY = (DrawLoop ‑ 1) * LineHeight + 3 + (10 ‑ GFTextMarkerLegendPicture.TextHeight(" ")) / 2!
GFTextMarkerLegendPicture.Print GFTextMarkerStructVar.MarkDescriptionArray(DrawLoop)
End With
Next DrawLoop
End Sub
Private Sub GFTextMarker_Refresh(ByRef GFTextMarkerStructVar As GFTextMarkerStruct)
'on error resume next
Dim PrintForeColorUnchanged As Long
Dim PrintForeColor As Long
Dim PrintMarkColor As Long
Dim CurrentLine As Integer
Dim CurrentRow As Integer
Dim XLoop As Integer 'not in use
Dim YLoop As Integer
Dim DrawLoop As Integer
'reset
GFTextMarkerPicture.Cls 'reset
'preset
CurrentLine = 1
CurrentRow = 1
'
GFTextMarkerPicture.AutoRedraw = True 'important
GFTextMarkerPicture.ScaleMode = vbPixels 'important
'
'verify
If GFTextMarkerStructVar.CursorPos < 1 Then GFTextMarkerStructVar.CursorPos = 1
If GFTextMarkerStructVar.CursorPos > GFTextMarkerStructVar.MarkTextLength Then GFTextMarkerStructVar.CursorPos = GFTextMarkerStructVar.MarkTextLength
'begin
For DrawLoop = 1 To GFTextMarkerStructVar.MarkTextLength
Select Case GFTextMarkerStructVar.MarkSelectionArray(DrawLoop)
Case 0
GFTextMarkerPicture.CurrentX = (CurrentRow ‑ 1) * GFTextMarkerPicture.TextWidth(Chr$(32))
GFTextMarkerPicture.CurrentY = (CurrentLine ‑ 1) * GFTextMarkerPicture.TextHeight(Chr$(32))
GFTextMarkerPicture.Print Mid$(GFTextMarkerStructVar.MarkText, DrawLoop, 1)
Case Else
'
PrintMarkColor = GFTextMarkerStructVar.MarkColorArray(GFTextMarkerStructVar.MarkSelectionArray(DrawLoop))
PrintForeColor = GFTextMarkerPicture.ForeColor
PrintForeColorUnchanged = GFTextMarkerPicture.ForeColor
'
For YLoop = 1 To 5 'draw 'linear gradiented' (looks better), don't use too many steps to avoid slow‑downs (no praise for VB graphics functions, SLOW!!!)
GFTextMarkerPicture.Line ((CurrentRow ‑ 1) * GFTextMarkerPicture.TextWidth(Chr$(32)), (CSng(YLoop ‑ 1) / 5!) * GFTextMarkerPicture.TextHeight(Chr$(32)) + (CurrentLine ‑ 1) * (GFTextMarkerPicture.TextHeight(Chr$(32))))‑ _
((CurrentRow ‑ 0) * GFTextMarkerPicture.TextWidth(Chr$(32)), (CSng(YLoop ‑ 0) / 5!) * GFTextMarkerPicture.TextHeight(Chr$(32)) + (CurrentLine ‑ 1) * (GFTextMarkerPicture.TextHeight(Chr$(32))) ‑ 1), _
GFColor_ChangeBrightness(PrintMarkColor, (2 ‑ YLoop) * 8), BF
Next YLoop
GFTextMarkerPicture.CurrentX = (CurrentRow ‑ 1) * GFTextMarkerPicture.TextWidth(Chr$(32))
GFTextMarkerPicture.CurrentY = (CurrentLine ‑ 1) * GFTextMarkerPicture.TextHeight(Chr$(32))
If GFColor_IsColorEqual(PrintMarkColor, PrintForeColor) = False Then
GFTextMarkerPicture.Print Mid$(GFTextMarkerStructVar.MarkText, DrawLoop, 1)
Else
GFTextMarkerPicture.ForeColor = GFColor_InvertColorSave(GFTextMarkerPicture.ForeColor)
GFTextMarkerPicture.Print Mid$(GFTextMarkerStructVar.MarkText, DrawLoop, 1)
GFTextMarkerPicture.ForeColor = PrintForeColorUnchanged 'reset
End If
End Select
If DrawLoop = GFTextMarkerStructVar.CursorPos Then
'draw cursor
GFTextMarkerPicture.CurrentX = (CurrentRow ‑ 1) * GFTextMarkerPicture.TextWidth(Chr$(32))
GFTextMarkerPicture.CurrentY = (CurrentLine ‑ 1) * GFTextMarkerPicture.TextHeight(Chr$(32)) ‑ 1 'move cursor one pixel up
GFTextMarkerPicture.Line (GFTextMarkerPicture.CurrentX, GFTextMarkerPicture.CurrentY + GFTextMarkerPicture.TextHeight(Chr$(32)))‑( _
GFTextMarkerPicture.CurrentX + GFTextMarkerPicture.TextWidth(Chr$(32)), GFTextMarkerPicture.CurrentY + GFTextMarkerPicture.TextHeight(Chr$(32))), _
&H80000008 'text fore color
End If
CurrentRow = CurrentRow + 1 'do after printing (draw at least one letter per line)
If (CurrentRow * GFTextMarkerPicture.TextWidth(Chr$(32))) > GFTextMarkerPicture.ScaleWidth Then
CurrentRow = 1
CurrentLine = CurrentLine + 1
End If
Next DrawLoop
End Sub
Private Sub GFTextMarkerLegendPicture_KeyDown(KeyCode As Integer, Shift As Integer)
'on error resume next
Dim LineHeight As Long
'preset
If (GFTextMarkerLegendPicture.TextHeight(Chr$(32)) + 2) > 15 Then 'ScaleMode is vbPixels
LineHeight = (GFTextMarkerLegendPicture.TextHeight(Chr$(32)) + 2)
Else
LineHeight = 15
End If
'begin
Select Case KeyCode
Case vbKeyUp, vbKeyLeft
Call GFTextMarkerLegendPicture_SetMarkPointer(GFTextMarkerStructVar.MarkPointer ‑ 1)
Case vbKeyDown, vbKeyRight
Call GFTextMarkerLegendPicture_SetMarkPointer(GFTextMarkerStructVar.MarkPointer + 1)
End Select
End Sub
Private Sub GFTextMarkerLegendPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Dim LineHeight As Long
Dim MarkPointerTemp As Integer
'preset
If (GFTextMarkerLegendPicture.TextHeight(Chr$(32)) + 2) > 15 Then 'ScaleMode is vbPixels
LineHeight = (GFTextMarkerLegendPicture.TextHeight(Chr$(32)) + 2)
Else
LineHeight = 15
End If
'begin
MarkPointerTemp = Int(Y / LineHeight) + 1
If Not ((MarkPointerTemp < 1) Or (MarkPointerTemp > GFTextMarkerStructVar.MarkNumber)) Then 'verify
GFTextMarkerStructVar.MarkPointer = MarkPointerTemp
Call GFTextMarker_DrawLegend(GFTextMarkerStructVar) 'display changes
End If
End Sub
Private Sub GFTextMarkerLegendPicture_SetMarkPointer(ByVal MarkPointer As Integer)
'on error resume next 'chooses a color for marking
GFTextMarkerStructVar.MarkPointer = MarkPointer
Select Case GFTextMarkerStructVar.MarkPointer 'verify
Case Is < 1
GFTextMarkerStructVar.MarkPointer = 1
Case Is > GFTextMarkerStructVar.MarkNumber
GFTextMarkerStructVar.MarkPointer = GFTextMarkerStructVar.MarkNumber
End Select
Call GFTextMarker_DrawLegend(GFTextMarkerStructVar) 'display changes
End Sub
Private Sub GFTextMarkerPicture_KeyDown(KeyCode As Integer, Shift As Integer)
'on error resume next 'past text of clipboard (if any)
Dim Tempstr$
Select Case KeyCode
Case vbKeyC
If Shift = 2 Then 'Ctrl‑V
If Clipboard.GetFormat(vbCFText) = True Then
Tempstr$ = Left$(Clipboard.GetText(vbCFText), 256) 'almost MAX_PATH (260)
If Not (Tempstr$ = GFTextMarkerStructVar.MarkText) Then
'NOTE: avoid that user removes selection without reason.
Call GFTextMarker_ReceiveText(Tempstr$, 0, NULLARRAYINT())
Call GFTextMarker_Refresh(GFTextMarkerStructVar)
End If
End If
End If
Case vbKeySpace
GFTextMarkerStructVar.SpaceKeyPressedFlag = True
GFTextMarkerStructVar.CursorMoveDirectionOld = 0 'reset
If GFTextMarkerStructVar.SpaceKeyPressedFlag = True Then _
Call GFTextMarkerPicture_MouseDown(vbLeftButton, 0, GFTextMarkerPicture.TextWidth(Chr$(32)) * (GFTextMarkerStructVar.CursorPos ‑ 1), 0) 'sub will wrap line
Call GFTextMarker_Refresh(GFTextMarkerStructVar)
Case vbKeyRight
GFTextMarkerStructVar.CursorPos = GFTextMarkerStructVar.CursorPos + 1
If GFTextMarkerStructVar.SpaceKeyPressedFlag = True Then _
Call GFTextMarkerPicture_MouseMove(vbLeftButton, 0, GFTextMarkerPicture.TextWidth(Chr$(32)) * (GFTextMarkerStructVar.CursorPos ‑ 1), 0) 'sub will wrap line
If Not (GFTextMarkerStructVar.CursorMoveDirectionOld = vbKeyRight) Then _
If GFTextMarkerStructVar.SpaceKeyPressedFlag = True Then _
Call GFTextMarkerPicture_MouseMove(vbLeftButton, 0, GFTextMarkerPicture.TextWidth(Chr$(32)) * (GFTextMarkerStructVar.CursorPos ‑ 2), 0) 'sub will wrap line
Call GFTextMarker_Refresh(GFTextMarkerStructVar)
GFTextMarkerStructVar.CursorMoveDirectionOld = vbKeyRight
Case vbKeyLeft
GFTextMarkerStructVar.CursorPos = GFTextMarkerStructVar.CursorPos ‑ 1
If GFTextMarkerStructVar.SpaceKeyPressedFlag = True Then _
Call GFTextMarkerPicture_MouseMove(vbLeftButton, 0, GFTextMarkerPicture.TextWidth(Chr$(32)) * (GFTextMarkerStructVar.CursorPos ‑ 1), 0) 'sub will wrap line
If Not (GFTextMarkerStructVar.CursorMoveDirectionOld = vbKeyLeft) Then _
If GFTextMarkerStructVar.SpaceKeyPressedFlag = True Then _
Call GFTextMarkerPicture_MouseMove(vbLeftButton, 0, GFTextMarkerPicture.TextWidth(Chr$(32)) * (GFTextMarkerStructVar.CursorPos ‑ 0), 0) 'sub will wrap line
Call GFTextMarker_Refresh(GFTextMarkerStructVar)
GFTextMarkerStructVar.CursorMoveDirectionOld = vbKeyLeft
Case vbKeyUp
Call GFTextMarkerLegendPicture_SetMarkPointer(GFTextMarkerStructVar.MarkPointer ‑ 1)
Case vbKeyDown
Call GFTextMarkerLegendPicture_SetMarkPointer(GFTextMarkerStructVar.MarkPointer + 1)
Case vbKey1
If Not (1 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(1)
Case vbKey2
If Not (2 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(2)
Case vbKey3
If Not (3 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(3)
Case vbKey4
If Not (4 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(4)
Case vbKey5
If Not (5 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(5)
Case vbKey6
If Not (6 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(6)
Case vbKey7
If Not (7 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(7)
Case vbKey8
If Not (8 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(8)
Case vbKey9
If Not (9 > GFTextMarkerStructVar.MarkNumber) Then _
Call GFTextMarkerLegendPicture_SetMarkPointer(9)
End Select
End Sub
Private Sub GFTextMarkerPicture_KeyUp(KeyCode As Integer, Shift As Integer)
'on error resume next
Select Case KeyCode
Case vbKeySpace
GFTextMarkerStructVar.SpaceKeyPressedFlag = False 'reset
End Select
End Sub
Private Sub GFTextMarkerPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Dim CurrentLine As Integer 'where user clicked
Dim CurrentRow As Integer 'where user clicked
Dim MarkTextCharIndex As Integer 'clicked char in MarkText
Select Case Button
Case vbLeftButton, vbRightButton
CurrentRow = Int(X / GFTextMarkerPicture.TextWidth(Chr$(32))) + 1
CurrentLine = Int(Y / GFTextMarkerPicture.TextHeight(Chr$(32))) + 1
MarkTextCharIndex = (CurrentLine ‑ 1) * Int(GFTextMarkerPicture.ScaleWidth / GFTextMarkerPicture.TextWidth(Chr$(32))) + CurrentRow
GFTextMarkerStructVar.CursorPos = MarkTextCharIndex
If (MarkTextCharIndex < 1) Or (MarkTextCharIndex > GFTextMarkerStructVar.MarkTextLength) Then Exit Sub 'verify (important)
If Shift = 0 Then 'allows using this sub by [...]_MouseMove()
If (GFTextMarkerStructVar.MarkSelectionArray(MarkTextCharIndex) = 0) Or _
Not (GFTextMarkerStructVar.MarkSelectionArray(MarkTextCharIndex) = GFTextMarkerStructVar.MarkPointer) Then
GFTextMarkerStructVar.UseMarkPointerFlag = True
Else
GFTextMarkerStructVar.UseMarkPointerFlag = False
End If
End If
If Button = vbRightButton Then
'right mouse button always deletes mark
GFTextMarkerStructVar.UseMarkPointerFlag = False
End If
If GFTextMarkerStructVar.UseMarkPointerFlag = True Then
If Not (GFTextMarkerStructVar.MarkSelectionArray(MarkTextCharIndex) = GFTextMarkerStructVar.MarkPointer) Then
'check if changes must be made to avoid flickering
GFTextMarkerStructVar.MarkSelectionArray(MarkTextCharIndex) = GFTextMarkerStructVar.MarkPointer
'Call GFTextMarker_Refresh(GFTextMarkerStructVar) 'display changes
End If
Else
If Not (GFTextMarkerStructVar.MarkSelectionArray(MarkTextCharIndex) = 0) Then
'check if changes must be made to avoid flickering
GFTextMarkerStructVar.MarkSelectionArray(MarkTextCharIndex) = 0 'reset
'Call GFTextMarker_Refresh(GFTextMarkerStructVar) 'display changes
End If
End If
Call GFTextMarker_Refresh(GFTextMarkerStructVar) 'redraw in any case to update cursor
End Select
End Sub
Private Sub GFTextMarkerPicture_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Select Case Button
Case vbLeftButton, vbRightButton
Call GFTextMarkerPicture_MouseDown(Button, 1, X, Y) 'Shift = 1
End Select
End Sub
Private Function GFTextMarker_RemoveSpace(ByVal SpaceString As String) As String
'on error resume next 'removes all (!) space chars in passed string 'no!
'Dim Temp As Long
'For Temp = 1 To Len(SpaceString)
' If Not (Asc(Mid$(SpaceString, Temp, 1)) = 32) Then
' GFTextMarker_RemoveSpace = GFTextMarker_RemoveSpace + Mid$(SpaceString, Temp, 1)
' End If
'Next Temp
GFTextMarker_RemoveSpace = Trim$(SpaceString)
End Function
'**********************************END OF GFTEXTMARKER**********************************
Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'On Error Resume Next
If Value1 < Value2 Then
MIN = Value1
Else
MIN = Value2
End If
End Function
[END OF FILE]