GFLEDBox/GFLEDBox.frm
VERSION 5.00
Begin VB.Form GFLEDBoxfrm
Caption = "Form2"
ClientHeight = 3195
ClientLeft = 60
ClientTop = 345
ClientWidth = 4650
LinkTopic = "Form2"
ScaleHeight = 3195
ScaleWidth = 4650
StartUpPosition = 3 'Windows‑Standard
Begin VB.PictureBox GFGetLineArrayThroughLineWidthPicture
Height = 315
Left = 300
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 3
Top = 1560
Width = 195
End
Begin VB.PictureBox LEDMaskImagePicture
Height = 315
Left = 0
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 2
Top = 1560
Width = 195
End
Begin VB.PictureBox LEDTextPicture
Height = 555
Left = 0
ScaleHeight = 495
ScaleWidth = 4095
TabIndex = 1
Top = 0
Width = 4155
End
Begin VB.PictureBox LEDMaskPicture
Height = 615
Left = 0
ScaleHeight = 555
ScaleWidth = 4095
TabIndex = 0
Top = 780
Width = 4155
End
End
Attribute VB_Name = "GFLEDBoxfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
'
'NOTE: THIS FORM IS PLUG‑IN CODE, DO NOT CHANGE!
'
'Not finished, in test run only.
'
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'GFMaskPrint
Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'LEDStruct ‑ general program data/settings
Private Type LEDStruct
SystemInitializedFlag As Boolean
LEDForeColor As Long
LEDBackColor As Long
LEDBoxPicture As PictureBox
LEDBoxWidth As Long 'format: twips
LEDBoxHeight As Long 'format: twips
LEDSize As Long
LEDDistance As Long
LEDAnimationEnabledFlag As Boolean 'if text is moved around
End Type
Dim LEDStructVar As LEDStruct
'TestStruct ‑ information about text to display
Private Type TextStruct
TextEnabledFlag As Boolean 'if anything is to be displayed in LED box
TEXT As String 'what is to be displayed
TextWidth As Long
TextHeight As Long
TextXPos As Long 'where it is to be displayed, format: pixels
TextYPos As Long 'format: pixels
TextSpeed As Single
TextStyleEx As Long
TextBlinkString As String 'display blinks 3 times when a stop point and this string is visible
TextBlinkNumber As Integer 'how many times display blinked at current stop
StopPointNumber As Integer
StopPointPosArray() As Long 'x or y pos, depending on scroll program
StopPosIndexCurrent As Integer
StopPointDisplayTime As Single 'number of frames text id to be displayed
DropFrameNumber As Integer
End Type
Dim TextStructVar As TextStruct
'DrawStruct
Private Type DrawStruct
StopPointEnabledFlag As Boolean 'if drawing rests at a stop point
StopPointTimer As Single 'how many frames drawing stopped at a stop point until now
End Type
Dim DrawStructVar As DrawStruct
Const TEXTSTYLEEX_SPEEDITALIC As Long = 1 'font is set to italic when moving only
Const TEXTSTYLEEX_USEBLINKSTRING As Long = 2 'display blinks when resting at a stop point and this string is visible
Const TEXTSTYLEEX_JERKING As Long = 4 'no smooth scrolling (can be read better)
Public Sub LED_Initialize(ByVal LEDBoxPicture As PictureBox, ByVal LEDForeColor As Long, ByVal LEDBackColor As Long, ByVal LEDSize As Long, ByVal LEDDistance As Long)
On Error Resume Next 'call first of all
'
'NOTE: if LEDSize is 0 the value of LEDDistance will be ignored and the
'scroll text will later be (indirectly) printed to the target picture box
'without any grid effects.
'
LEDStructVar.SystemInitializedFlag = True
Set LEDStructVar.LEDBoxPicture = LEDBoxPicture
LEDStructVar.LEDBoxPicture.AutoRedraw = True
If LEDBoxPicture.ScaleMode = vbTwips Then
LEDStructVar.LEDBoxWidth = LEDBoxPicture.ScaleWidth
LEDStructVar.LEDBoxHeight = LEDBoxPicture.ScaleHeight
End If
If LEDBoxPicture.ScaleMode = vbPixels Then
LEDStructVar.LEDBoxWidth = LEDBoxPicture.ScaleWidth * Screen.TwipsPerPixelX
LEDStructVar.LEDBoxHeight = LEDBoxPicture.ScaleHeight * Screen.TwipsPerPixelY
End If
LEDStructVar.LEDForeColor = LEDForeColor
LEDStructVar.LEDBackColor = LEDBackColor 'ignored (no effect when mask printing)
LEDStructVar.LEDSize = LEDSize
LEDStructVar.LEDDistance = LEDDistance
LEDStructVar.LEDAnimationEnabledFlag = False 'reset
'LEDTextPicture
Set LEDTextPicture.Font = LEDBoxPicture.Font
LEDTextPicture.AutoRedraw = True
LEDTextPicture.ForeColor = LEDForeColor
LEDTextPicture.BackColor = 0
LEDTextPicture.Width = LEDBoxPicture.Width
LEDTextPicture.Height = LEDBoxPicture.Height
'LEDMaskPicture
Set LEDMaskPicture.Font = LEDBoxPicture.Font
LEDMaskPicture.AutoRedraw = True
LEDMaskPicture.ForeColor = RGB(255, 255, 255)
LEDMaskPicture.BackColor = 0
LEDMaskPicture.Width = LEDBoxPicture.Width
LEDMaskPicture.Height = LEDBoxPicture.Height
'LEDMaskImagePicture
'see LEDMaskImage_Create()
'GFGetLineArrayThroughLineWidthPicture
Set GFGetLineArrayThroughLineWidthPicture.Font = LEDBoxPicture.Font
'
Call LEDMaskImage_Create(LEDSize, LEDDistance, LEDStructVar.LEDBoxPicture.Width, LEDStructVar.LEDBoxPicture.Height)
End Sub
Public Sub LEDAnimation_Enable()
On Error Resume Next
LEDStructVar.LEDAnimationEnabledFlag = True
Call Animation_Start
End Sub
Public Sub LEDAnimation_Disable()
On Error Resume Next
LEDStructVar.LEDAnimationEnabledFlag = False
End Sub
Public Sub LEDAnimation_MoveX(ByVal MoveAmount As Long) 'y move not supported yet
On Error Resume Next 'MoveAmount must have the format pixels and can be positive or negative
TextStructVar.TextXPos = TextStructVar.TextXPos + MoveAmount
Call LEDAnimation_Redraw(True)
End Sub
Public Function IsAnimationEnabled() As Boolean
On Error Resume Next
IsAnimationEnabled = LEDStructVar.LEDAnimationEnabledFlag
End Function
Private Sub LEDMaskImage_Create(ByVal LEDSize As Long, ByVal LEDDistance As Long, ByVal LEDBoxPictureWidth As Long, ByVal LEDBoxPictureHeight As Long)
On Error Resume Next
Dim DrawXLoop As Integer
Dim DrawYLoop As Integer
'preset
With LEDMaskImagePicture
.AutoRedraw = True 'important
.ScaleMode = vbTwips
.Width = LEDBoxPictureWidth
.Height = LEDBoxPictureHeight
If Not (LEDSize = 0) Then
.ForeColor = RGB(255, 255, 255)
.BackColor = 0
.FillStyle = 0 'solid
.FillColor = RGB(255, 255, 255)
'begin
For DrawXLoop = 1 To .ScaleWidth Step (LEDDistance * Screen.TwipsPerPixelX)
For DrawYLoop = 1 To .ScaleHeight Step (LEDDistance * Screen.TwipsPerPixelY)
LEDMaskImagePicture.Line (DrawXLoop, DrawYLoop)‑(DrawXLoop + (LEDSize ‑ 1) * Screen.TwipsPerPixelX, DrawYLoop + (LEDSize ‑ 1) * Screen.TwipsPerPixelY), LEDMaskImagePicture.ForeColor, BF
Next DrawYLoop
Next DrawXLoop
Else
.ForeColor = RGB(255, 255, 255)
.BackColor = RGB(255, 255, 255)
.FillStyle = 1 'transparent (default)
.FillColor = RGB(255, 255, 255)
End If
.Refresh
End With
End Sub
Public Function LED_GetTextBlockWidth(ByVal TEXT As String) As Long
On Error Resume Next 'Text may contain Chr$(13)
'
'NOTE: the .TextWidth() function returns the width of the longest line
'in the passed string automatically (bless it!).
'Use this function to check if it makes sense to display a text running
'in the LED box.
'
LED_GetTextBlockWidth = LEDStructVar.LEDBoxPicture.TextWidth(TEXT)
End Function
Public Sub LED_Program_HScroll(ByVal ScrollText As String, ByVal ScrollSpeed As Single, ByVal ScrollDisplayTime As Single, ByVal ScrollStyleEx As Long, ByVal lParam As String)
On Error Resume Next
Dim LineNumber As Integer
Dim LineArray() As String 'split‑up ScrollText
Dim LineLoop As Integer
Dim Pos As Long
Dim PosLoop As Integer
'
'NOTE: call this sub to display text that runs from right to left,
'moving ScrollSpeed pixels per frame. This sub will split up the ScrollText
'into lines, every line will rest ScrollDisplayTime frames when it is centered.
'
'preset
Call GFGetLineArrayThroughLineWidth(ScrollText, LEDStructVar.LEDBoxWidth, 750, " ", LineArray(), LineNumber, GFGetLineArrayThroughLineWidthPicture)
'begin
Call LEDAnimation_Reset
With TextStructVar
.TextEnabledFlag = True
.TEXT = ScrollText
.TextWidth = LEDStructVar.LEDBoxPicture.TextWidth(ScrollText)
.TextHeight = LEDStructVar.LEDBoxPicture.TextHeight(ScrollText)
.TextXPos = (LEDStructVar.LEDBoxPicture.Width) / Screen.TwipsPerPixelX 'preset
.TextYPos = 0 'reset
.TextSpeed = ScrollSpeed
.TextStyleEx = ScrollStyleEx
.TextBlinkString = lParam
If Not (ScrollDisplayTime = 0) Then
.StopPointNumber = LineNumber
ReDim .StopPointPosArray(1 To LineNumber) As Long 'reset
For LineLoop = 1 To LineNumber
Pos = 0 'reset
For PosLoop = 1 To (LineLoop ‑ 1)
Pos = Pos ‑ (LEDStructVar.LEDBoxPicture.TextWidth(LineArray(PosLoop)) / Screen.TwipsPerPixelX)
Next PosLoop
.StopPointPosArray(LineLoop) = Pos
Next LineLoop
.StopPointDisplayTime = ScrollDisplayTime
.StopPosIndexCurrent = 1 'reset
.DropFrameNumber = 0 'reset
Else
.StopPointNumber = 0 'reset
ReDim .StopPointPosArray(1 To 1) As Long 'reset
.StopPointPosArray(1) = ‑256& ^ 3& 'something that will never be used
.StopPointDisplayTime = 0 'reset
.StopPosIndexCurrent = 1 'do not set to 0
.DropFrameNumber = 0 'reset
End If
End With
End Sub
Private Function GFGetLineArrayThroughLineWidth(ByVal InputString As String, ByVal LineWidthMax As Long, ByVal LineWidthOverflowMax As Long, ByVal LineBorderChar As String, ByRef LineArray() As String, ByRef LineNumber As Integer, ByRef LineWidthPicture As PictureBox) As Boolean
On Error Resume Next 'format: twips; use as general function to create a text block with defined width; function returns True for success or False for error
Dim Temp As Long
'preset
LineNumber = 0
ReDim LineArray(1 To 1) As String
'verify
If Not (Len(LineBorderChar) = 1) Then
GoTo Error:
End If
If InputString = "" Then
GFGetLineArrayThroughLineWidth = True 'ok
Exit Function
End If
'begin
Temp = 0 'reset
Do
Temp = Temp + 1
If Mid$(InputString, Temp, 2) = Chr$(13) + Chr$(10) Then
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ Temp ‑ 1)
Temp = 0 'reset
Else
If Mid$(InputString, Temp, 1) = LineBorderChar Then
Select Case LineWidthPicture.TextWidth(Left$(InputString, Temp ‑ 1))
Case Is < LineWidthMax
'do nothing
Case Is >= LineWidthMax
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ Temp + 0)
Temp = 0 'reset
End Select
Else
Select Case LineWidthPicture.TextWidth(Left$(InputString, Temp ‑ 1))
Case Is < LineWidthMax
'do nothing
Case Is >= (LineWidthMax + LineWidthOverflowMax)
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ Temp + 1)
Temp = 0 'reset
End Select
End If
End If
If Temp = Len(InputString) Then
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = InputString
Exit Do
End If
Loop
GFGetLineArrayThroughLineWidth = True 'ok
Exit Function
Error:
MsgBox "internal error in GFGetLineArrayThroughLineWidth() !", vbOKOnly + vbExclamation
GFGetLineArrayThroughLineWidth = False 'error
Exit Function
End Function
Private Function GFMaskPrint(ByVal PrintTargetPictureBox As Object, ByVal PrintTargetPictureXPos As Long, ByVal PrintTargetPictureYPos As Long, ByVal PrintSourcePictureBox As PictureBox, ByVal PrintMaskPictureBox As PictureBox) As Boolean
On Error GoTo Error: 'function returns True if printing was successful, False if not
Dim PrintMaskPictureScaleModeUnchanged As Integer
'
'NOTE: use this function to print transparent text, non‑rectangular pictures, etc.
'The mask must consist of two colors only (black and white), everything that's white will be printed.
'Print[Source/Mask] must have the picture to print placed at (0|0), and must have been made fit to
'the picture's size.
'
PrintMaskPictureScaleModeUnchanged = PrintMaskPictureBox.ScaleMode
PrintMaskPictureBox.ScaleMode = vbPixels 'important
Call BitBlt(PrintTargetPictureBox.hDC, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hDC, 0, 0, vbSrcPaint)
Call BitBlt(PrintSourcePictureBox.hDC, 0, 0, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hDC, 0, 0, vbMergePaint)
Call BitBlt(PrintTargetPictureBox.hDC, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintSourcePictureBox.hDC, 0, 0, vbSrcAnd)
PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
GFMaskPrint = True 'ok
Exit Function
Error:
If Not (PrintMaskPictureScaleModeUnchanged = 0) Then 'verify
PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
End If
GFMaskPrint = False 'error
Exit Function
End Function
Private Sub Form_Load()
On Error Resume Next
'do nothing
End Sub
Public Sub Animation_Loop()
On Error Resume Next
Dim DrawFrameNumber As Integer
Do
DrawFrameNumber = DrawFrameNumber + 1
Call Sleep(20)
If LEDAnimation_Redraw(False) = False Then Exit Do
If Animation_StopFlag = True Then Exit Do
Loop
End Sub
Private Sub LEDAnimation_Reset()
On Error Resume Next
DrawStructVar.StopPointEnabledFlag = False 'reset
DrawStructVar.StopPointTimer = 0 'reset
End Sub
Public Function LEDAnimation_Redraw(ByVal SingleRedrawFlag As Boolean) As Boolean
On Error Resume Next 'returns False if drawing loop must be left; set SingleRedrawFlag to False only if this sub is called out of the drawing loop
Dim ForeColorOld As Long
Dim BackColorOld As Long
'preset
LEDAnimation_Redraw = True 'preset
'verify
If (SingleRedrawFlag = False) And (LEDStructVar.LEDAnimationEnabledFlag = False) Then Exit Function
If LEDStructVar.SystemInitializedFlag = False Then Exit Function 'this sub could be called if mouse is moved over target picture box
'begin
If SingleRedrawFlag = False Then
If (Abs(TextStructVar.TextXPos ‑ TextStructVar.StopPointPosArray(TextStructVar.StopPosIndexCurrent)) < TextStructVar.TextSpeed) And _
(TextStructVar.TextXPos ‑ TextStructVar.StopPointPosArray(TextStructVar.StopPosIndexCurrent) > 0) Then
If DrawStructVar.StopPointEnabledFlag = False Then
DrawStructVar.StopPointEnabledFlag = True
DrawStructVar.StopPointTimer = 0
If (TextStructVar.TextStyleEx And TEXTSTYLEEX_SPEEDITALIC) Then
LEDStructVar.LEDBoxPicture.Font.Italic = False
LEDTextPicture.Font.Italic = False
LEDMaskPicture.Font.Italic = False
End If
TextStructVar.StopPosIndexCurrent = TextStructVar.StopPosIndexCurrent + 1
If TextStructVar.StopPosIndexCurrent > TextStructVar.StopPointNumber Then TextStructVar.StopPosIndexCurrent = 1 'reset (position 1 will not appear anymore)
GoTo Draw: 'done once per stop only
End If
End If
'stop?
If DrawStructVar.StopPointEnabledFlag = True Then
'DrawStructVar.StopPointTimer = DrawStructVar.StopPointTimer + 1
'If DrawStructVar.StopPointTimer > TextStructVar.StopPointDisplayTime Then
DrawStructVar.StopPointEnabledFlag = False 'reset
DrawStructVar.StopPointTimer = 0 'reset
If (TextStructVar.TextStyleEx And TEXTSTYLEEX_SPEEDITALIC) Then
LEDStructVar.LEDBoxPicture.Font.Italic = True
LEDTextPicture.Font.Italic = True
LEDMaskPicture.Font.Italic = True
End If
LEDAnimation_Redraw = False
TextStructVar.TextXPos = TextStructVar.TextXPos ‑ TextStructVar.TextSpeed
Exit Function
End If
TextStructVar.TextXPos = TextStructVar.TextXPos ‑ TextStructVar.TextSpeed
If (TextStructVar.TextStyleEx And TEXTSTYLEEX_JERKING) Then
TextStructVar.DropFrameNumber = TextStructVar.DropFrameNumber + 1
If TextStructVar.DropFrameNumber > 8 Then
TextStructVar.DropFrameNumber = 0 'reset
Else
Exit Function
End If
End If
'finished?
If TextStructVar.TextXPos < ‑(TextStructVar.TextWidth / Screen.TwipsPerPixelX) Then
TextStructVar.TextXPos = (LEDStructVar.LEDBoxPicture.Width) / Screen.TwipsPerPixelX 'redo
TextStructVar.StopPosIndexCurrent = 1 'reset
Exit Function
End If
GoTo Draw:
Else
GoTo Draw:
End If
Draw:
'create mask text
With LEDTextPicture
.Cls 'reset
ForeColorOld = .ForeColor
BackColorOld = .BackColor
.ForeColor = RGB(255, 255, 255)
.BackColor = 0
.CurrentX = TextStructVar.TextXPos * Screen.TwipsPerPixelX
.CurrentY = TextStructVar.TextYPos * Screen.TwipsPerPixelY
LEDTextPicture.Print TextStructVar.TEXT
LEDTextPicture.Refresh
End With
LEDMaskPicture.Cls
Call GFMaskPrint(LEDMaskPicture, 0, 0, LEDTextPicture, LEDMaskImagePicture)
LEDTextPicture.ForeColor = ForeColorOld 'set after drawing
LEDTextPicture.BackColor = BackColorOld 'set after drawing
'create text
With LEDTextPicture
.Cls 'reset
.CurrentX = TextStructVar.TextXPos * Screen.TwipsPerPixelX
.CurrentY = TextStructVar.TextYPos * Screen.TwipsPerPixelY
LEDTextPicture.Print TextStructVar.TEXT
LEDTextPicture.Refresh
End With
LEDStructVar.LEDBoxPicture.Cls
Call GFMaskPrint(LEDStructVar.LEDBoxPicture, 0, 0, Me.LEDTextPicture, Me.LEDMaskPicture)
LEDStructVar.LEDBoxPicture.Refresh 'important
Exit Function
Clear:
LEDStructVar.LEDBoxPicture.Cls 'reset
Exit Function
End Function
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Call Animation_Stop
Unload Me
End Sub
[END OF FILE]