VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cS2DMessageBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type Message
    x As Double
    y As Double
    Width As Double
    Height As Double
    Color As Long
    Alpha As Integer
    Text As String
    UnformattedText As String
    CurrentPage As Integer
    CurrentCharacter As Integer
    Visible As Boolean
    Automatic As Boolean
    OnWait As Integer
End Type

Private Messages() As Message
Private MessageNames() As String
Private MessageCount As Integer
Private CurrentFocus As Integer
Private Const CornerWidth As Integer = 8
Private Const CornerHeight As Integer = 8
Private CFm_S2D As cS2D_i
Private CFm_Text As cS2DText
Private textureID As Integer
Private Loaded As Boolean

'dokumentieren: NEIN
Public Property Get S2D() As cS2D_i
    Set S2D = CFm_S2D
End Property

Public Property Set S2D(PropVal As cS2D_i)
    Set CFm_S2D = PropVal
End Property

'dokumentieren: NEIN
Public Property Get Text() As cS2DText
    Set Text = CFm_Text
End Property

Public Property Set Text(PropVal As cS2DText)
    Set CFm_Text = PropVal
End Property


Private Sub DrawBorder(ByVal x As Double, ByVal y As Double, ByVal dblWidth As Double, ByVal dblHeight As Double, ByVal Alpha As Integer)

    With CFm_S2D
        .TexturePool.RenderTexture textureID, x, y, CornerWidth, CornerHeight, CornerWidth, CornerHeight, , , Alpha
        .TexturePool.RenderTexture textureID, x, y + dblHeight - CornerHeight, CornerWidth, CornerHeight, CornerWidth, CornerHeight, , CornerHeight * 2, Alpha
        .TexturePool.RenderTexture textureID, x + dblWidth - CornerWidth, y + dblHeight - CornerHeight, CornerWidth, CornerHeight, CornerWidth, CornerHeight, CornerWidth * 2, CornerHeight * 2, Alpha
        .TexturePool.RenderTexture textureID, x + dblWidth - CornerWidth, y, CornerWidth, CornerHeight, CornerWidth, CornerHeight, CornerWidth * 2, , Alpha
        .TexturePool.RenderTexture textureID, x + CornerWidth, y, dblWidth - CornerWidth * 2, CornerHeight, CornerWidth, CornerHeight, CornerWidth, , Alpha
        .TexturePool.RenderTexture textureID, x + CornerWidth, y + dblHeight - CornerHeight, dblWidth - CornerWidth * 2, CornerHeight, CornerWidth, CornerHeight, CornerWidth, CornerHeight * 2, Alpha
        .TexturePool.RenderTexture textureID, x, y + CornerHeight, CornerWidth, dblHeight - CornerHeight * 2, CornerWidth, CornerHeight, , CornerHeight, Alpha
        .TexturePool.RenderTexture textureID, x + dblWidth - CornerWidth, y + CornerHeight, CornerWidth, dblHeight - CornerHeight * 2, CornerWidth, CornerHeight, CornerWidth * 2, CornerHeight, Alpha
    End With

End Sub

Private Function FormatTextToRectSimple(srcRect As RECT, strText As String, ByVal intPage As Integer, ByVal tID As Integer) As String
  
    Dim a()         As String
    Dim b()         As String
    Dim RealText    As String
    Dim tCount      As Integer
    Dim LastStart   As Integer
    Dim Pages()     As String
    Dim CurrentPage As Integer
    Dim StartLoop   As Integer
  
    CurrentPage = 1
    LastStart = 1
    StartLoop = 1
    
    strText = Replace(strText, "<br>", vbCrLf)
    strText = Replace(strText, "<shake>", vbNullString)
    strText = Replace(strText, "</shake>", vbNullString)
    strText = Replace(strText, "<dance>", vbNullString)
    strText = Replace(strText, "</dance>", vbNullString)
    strText = Replace(strText, "<i>", vbNullString)
    strText = Replace(strText, "</i>", vbNullString)
    
    Dim i As Integer
    
    For i = 1 To Len(strText)
        If Mid$(strText, i, 6) = "<color" Then
            b = Split(Mid$(strText, i + 7), ")", 2)
            a = Split(b(0), ",", 3)
            strText = Replace(strText, "<color(" & a(0) & "," & a(1) & "," & a(2) & ")>", vbNullString)
        End If
    Next i
    
    For tCount = StartLoop To Len(strText)
RunAgain:
        If GetTextWidthSimple(Mid$(strText, LastStart, tCount - LastStart)) >= (srcRect.Right - 36) Then
            RealText = RealText & Mid$(strText, LastStart, tCount - LastStart) & vbCrLf
            LastStart = tCount
        End If
        
        If Mid$(strText, tCount, 2) = vbCrLf Then
            RealText = RealText & Mid$(strText, LastStart, tCount - LastStart) & vbCrLf
            tCount = tCount + 2
            LastStart = tCount
        End If
        
        If GetTextHeightSimple(RealText) >= srcRect.bottom Then
            If Not CurrentPage = intPage Then
                CurrentPage = CurrentPage + 1
                RealText = ""
             Else
                GoTo CleanUp
            End If
        End If
    Next tCount
    
    If intPage > CurrentPage Then
        Messages(tID).Visible = False
    End If
    
CleanUp:
    RealText = RealText & Mid$(strText, LastStart, tCount - LastStart) & vbCrLf
    FormatTextToRectSimple = RealText

End Function

Private Function GetIDbyName(ByVal strName As String) As Integer
    
    Dim tCount As Integer

    If MessageCount < 1 Then
        GetIDbyName = 0
        Exit Function
    End If
    
    For tCount = 1 To MessageCount
        If MessageNames(tCount) = strName Then
            GetIDbyName = tCount
            Exit Function
        End If
    Next tCount

End Function

Private Function GetTextHeightSimple(strText As String) As Integer
    GetTextHeightSimple = frmMain.TextHeight(strText)
End Function

Private Function GetTextWidthSimple(strText As String) As Integer
    GetTextWidthSimple = frmMain.TextWidth(strText)
End Function

Private Function InsertInString(ByVal CFm_Text As String, TextToInsert As String, ByVal Position As Integer) As String

    Dim TempLeft  As String
    Dim TempRight As String
      
    TempLeft = Left$(CFm_Text, Position)
    TempRight = Right$(CFm_Text, Len(CFm_Text) - Position)
    InsertInString = TempLeft & TextToInsert & TempRight

End Function

Private Sub RenderMessageBox(tID As Integer)
    
    Dim trect As RECT
    trect.Left = Messages(tID).x + 1
    trect.Top = Messages(tID).y + 1
    trect.Right = Messages(tID).Width - 2
    trect.bottom = Messages(tID).Height - 2
    
    Effects.RenderRectangle Messages(tID).x + 1, Messages(tID).y + 1, Messages(tID).Width - 2, Messages(tID).Height - 2, vbBlack, vbBlack, Messages(tID).Color, Messages(tID).Color, Messages(tID).Alpha
    DrawBorder Messages(tID).x, Messages(tID).y, Messages(tID).Width, Messages(tID).Height, 255
    
    If Not Messages(tID).Automatic Then
        If CurrentFocus = tID Then
            If Controller.CheckKey(vbKeySpace, 15) Then
                If Messages(tID).CurrentCharacter < Len(Messages(tID).Text) Then
                    Messages(tID).CurrentCharacter = Len(Messages(tID).Text)
                Else
                    With Messages(tID)
                        .CurrentPage = .CurrentPage + 1
                        .CurrentCharacter = 0
                        .Text = FormatTextToRectSimple(trect, .UnformattedText, .CurrentPage, tID)
                    End With
                End If
            End If
        End If
    Else
    With Messages(tID)
        If .CurrentCharacter >= Len(.Text) Then
            .OnWait = .OnWait + 1
            If .OnWait >= 150 Then
                .OnWait = 0
                .CurrentPage = .CurrentPage + 1
                .CurrentCharacter = 0
                .Text = FormatTextToRectSimple(trect, .UnformattedText, .CurrentPage, tID)
            End If
        End If
    End With
    
    End If
    
    If Messages(tID).CurrentCharacter <= Len(Messages(tID).Text) Then
        Messages(tID).CurrentCharacter = Messages(tID).CurrentCharacter + 1
    End If
    
    Text.DrawTextSimple Messages(tID).x + 8, Messages(tID).y + 8, Mid$(Messages(tID).Text, 1, Messages(tID).CurrentCharacter)
    
End Sub

'dokumentieren: JA
Public Sub SetMessage(strName As String, ByVal x As Double, ByVal y As Double, ByVal dblWidth As Double, ByVal dblHeight As Double, Optional lngColor As Long = vbBlue, Optional Alpha As Integer = 255)
    
    Dim tID As Integer
    
    tID = GetIDbyName(strName)
    
    If tID = 0 Then
        MessageCount = MessageCount + 1
        ReDim Preserve Messages(1 To MessageCount)
        ReDim Preserve MessageNames(1 To MessageCount)
        MessageNames(MessageCount) = strName
        tID = GetIDbyName(strName)
    End If
    
    With Messages(tID)
        .Color = lngColor
        .Height = dblHeight
        .Width = dblWidth
        .x = x
        .y = y
        .Alpha = Alpha
    End With 'Messages(tID)
    
    If Not Loaded Then
        textureID = S2D.TexturePool.AddTexture(App.Path & "\system.png", rgb(255, 0, 255))
        Loaded = True
    End If

End Sub

'dokumentieren: JA
Public Sub MessageBox(strName As String, ByVal CFm_Text As String, Optional WaitForInput As Boolean = True, Optional ByVal x As Double, Optional ByVal y As Double, Optional ByVal dblWidth As Double, Optional ByVal dblHeight As Double, Optional ByVal lngColor As Long, Optional ByVal Alpha As Integer)
    
    Dim trect As RECT
    Dim tID   As Integer
    
    tID = GetIDbyName(strName)
    
    With trect
        .Left = Messages(tID).x + 1
        .Top = Messages(tID).y + 1
        .bottom = Messages(tID).Height - 2
        .Right = Messages(tID).Width - 2
    End With 'tRect
    
    If tID < 1 Then
        Exit Sub
    End If
    
    With Messages(tID)
        .CurrentCharacter = 0
        .CurrentPage = 1
        .Visible = True
        .Text = FormatTextToRectSimple(trect, CFm_Text, 1, tID)
        .UnformattedText = CFm_Text
        .Automatic = True
    End With
    
    CurrentFocus = tID
    
    If Not x = 0 Then
        Messages(tID).x = x
    End If
    
    If Not y = 0 Then
        Messages(tID).y = y
    End If
    
    If Not dblWidth = 0 Then
        Messages(tID).Width = dblWidth
    End If
    
    If Not dblHeight = 0 Then
        Messages(tID).Height = dblHeight
    End If
    
    If Not lngColor = 0 Then
        Messages(tID).Color = lngColor
    End If
    
    If WaitForInput Then
        Messages(tID).Automatic = False
        Do
            If GetInputState() <> 0 Then
                DoEvents
            End If
            RenderGame
        Loop Until Messages(tID).Visible = False
    End If

End Sub

'dokumentieren: JA
Public Sub RemoveMessage(strName As String)

    Dim tCount             As Integer
    Dim ResizeArray        As Boolean
    Dim TempMessageNames() As String
    Dim TempMessages()     As Message
    Dim tID                As Integer
    
    tID = GetIDbyName(strName)
    
    If tID < 1 Then
    Exit Sub
    End If
    
    ReDim TempMessageNames(0 To MessageCount - 1)
    ReDim TempMessages(0 To MessageCount - 1)
    
    For tCount = 1 To MessageCount
        If tID = tCount Then
            ResizeArray = True
        End If
        
        If ResizeArray Then
            TempMessageNames(tCount - 1) = MessageNames(tCount)
            TempMessages(tCount - 1) = Messages(tCount)
        Else
            TempMessageNames(tCount) = MessageNames(tCount)
            TempMessages(tCount) = Messages(tCount)
        End If
    Next tCount
    
    MessageCount = MessageCount - 1
    
    If Not MessageCount = 0 Then
        ReDim Preserve Messages(1 To MessageCount)
        ReDim Preserve MessageNames(1 To MessageCount)
        
        For tCount = 1 To MessageCount
            Messages(tCount) = TempMessages(tCount)
            MessageNames(tCount) = TempMessageNames(tCount)
        Next tCount
    End If

End Sub

'dokumentieren: NEIN
Public Sub RenderMessageSystem()

    Dim tCount As Integer
    
    For tCount = 1 To MessageCount
        If Messages(tCount).Visible Then
            RenderMessageBox tCount
        End If
    Next tCount

End Sub

