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 LongByVal X As LongByVal Y As LongByVal nWidth As LongByVal nHeight As LongByVal hSrcDC As LongByVal xSrc As LongByVal ySrc As LongByVal 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 LongByVal LEDBackColor As LongByVal LEDSize As LongByVal 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 LongByVal LEDDistance As LongByVal LEDBoxPictureWidth As LongByVal 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 StringByVal ScrollSpeed As SingleByVal ScrollDisplayTime As SingleByVal ScrollStyleEx As LongByVal 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 StringByVal LineWidthMax As LongByVal LineWidthOverflowMax As LongByVal LineBorderChar As StringByRef LineArray() As StringByRef LineNumber As IntegerByRef 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 ObjectByVal PrintTargetPictureXPos As LongByVal PrintTargetPictureYPos As LongByVal 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]