VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsRTBManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl
'                {\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\fswiss Tahoma;}{\f3\fswiss Tahoma;}{\f4\fswiss MS Sans Serif;}{\f5\fswiss Times New Roman;}{\f6\fswiss\fcharset2 Webdings;}{\f7\fswiss\fcharset2 Wingdings;}{\f8\fswiss System;}
'                                        }
'{\colortbl\red0\green0\blue0;\red128\green255\blue128;\red0\green64\blue0;\red255\green128\blue128;}
'\deflang1033\horzdoc{\*\fchars }{\*\lchars }
'\plain\f5\fs16\cf0 Dev: Hello \par
'\plain\f5\fs16\cf0 Dev:\plain\f7\fs24\cf2\b  DoneTesting
'\plain\f5\fs16\cf0\ul\strike Dev: \par
'\plain\f6\fs22\cf1  JoeShmoe \par

Option Explicit

'Steping through the graphics
Private nIndex As Long

'Picture swap out array
Private saPicTextRTF() As String

Private Const cRED = 1
Private Const cGREEN = 2
Private Const cBLUE = 3

'Fonts
Private strFonts As String
Private saFontPos() As String
'Colors
Private strColors As String
Private naColPos() As Long
'Messages
Private strTextRTF As String

Public Function Name() As String

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = "clsRTBManager.Name"
    'Call WriteProcStart(sRoutineName)
    
    
    Name = "clsRTBManager"
    
    
    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Function
Public Function FormatForInsert(oFont As StdFont, nFontColor As Long, sMsg As String, bNewLine As Boolean)

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".FormatForInsert"
    Call WriteProcStart(sRoutineName, "OBJECT", nFontColor, sMsg, bNewLine)


    Dim nRed As Long
    Dim nGreen As Long
    Dim nBlue As Long
    Dim sRetVal As String

    nRed = nFontColor And (2 ^ 0 + 2 ^ 1 + 2 ^ 2 + 2 ^ 3 + 2 ^ 4 + 2 ^ 5 + 2 ^ 6 + 2 ^ 7)
    nGreen = (nFontColor And (2 ^ 8 + 2 ^ 9 + 2 ^ 10 + 2 ^ 11 + 2 ^ 12 + 2 ^ 13 + 2 ^ 14 + 2 ^ 15)) / (2 ^ 8)
    nBlue = (nFontColor And (2 ^ 16 + 2 ^ 17 + 2 ^ 18 + 2 ^ 19 + 2 ^ 20 + 2 ^ 21 + 2 ^ 22 + 2 ^ 23)) / (2 ^ 16)

    'This checks to see if it is a valid font

    'Formulate the string
    sRetVal = "{" & _
                "{\fonttbl{\f0\fcharset2 " & oFont.Name & ";}}" & _
                "{\colortbl\red" & nRed & "\green" & nGreen & "\blue" & nBlue & ";}" & _
                "\fs" & CLng(oFont.Size + 9) & "\cf0\f0"

    If oFont.Bold = True Then sRetVal = sRetVal & "\b"  'Bold
    If oFont.Italic = True Then sRetVal = sRetVal & "\i"  'Italic
    If oFont.Strikethrough = True Then sRetVal = sRetVal & "\strike"  'StrikeThru
    If oFont.Underline = True Then sRetVal = sRetVal & "\ul"  'Underline
    If bNewLine = True Then sRetVal = sRetVal & "\par"

    sRetVal = sRetVal & " " & sMsg & "}"

    FormatForInsert = ConvMsgGraphics(sRetVal)


    Call WriteProcStop(sRoutineName, FormatForInsert)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Function

Public Sub AddMessage(sFontInfo As String, sFontName As String, nFontColor As Long, sMsg As String, bNewLine As Boolean)
    
    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".AddMessage"
    Call WriteProcStart(sRoutineName, sFontInfo, sFontName, nFontColor, sMsg, bNewLine)
        
        
    'This correctly calculates the name of the font... makes sure its in our system.
    Dim oTempFont As New StdFont
    oTempFont.Name = sFontName
        
    strTextRTF = strTextRTF & "\plain\f" & GetFontIndex(oTempFont.Name) & _
                "\fs" & Trim(Mid(sFontInfo, 3, 2)) + 9 & "\cf" & GetColorIndex(nFontColor)
    
    If Mid(sFontInfo, 1, 1) = 1 Then strTextRTF = strTextRTF & "\b" 'Bold
    If Mid(sFontInfo, 2, 1) = 1 Then strTextRTF = strTextRTF & "\i" 'Italic
    If Mid(sFontInfo, 5, 1) = 1 Then strTextRTF = strTextRTF & "\strike" 'StrikeThru
    If Mid(sFontInfo, 6, 1) = 1 Then strTextRTF = strTextRTF & "\ul" 'Underline
    
    strTextRTF = strTextRTF & " " & ConvMsgGraphics(sMsg)
    
    If bNewLine = True Then strTextRTF = strTextRTF & " \par "
           
       
    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Sub
Public Function ConvMsgGraphics(sMsg As String) As String

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".ConvMsgGraphics"
    Call WriteProcStart(sRoutineName, sMsg)
        
        
    Dim nValue As Long
    Dim sL As String
    Dim sR As String
    Dim bDoneSwapping As Boolean
    Dim i As Long
    Dim nStart As Long
    Dim sNewMsg As String
    Dim bLeftOk As Boolean
    Dim bRightOk As Boolean
    
    sNewMsg = sMsg
    'bDoneSwapping = False
    
    'Convert in user loaded macros
    For i = 1 To UBound(saPicTextRTF, 2) - 1
    
        nStart = InStr(1, sNewMsg, saPicTextRTF(1, i), vbTextCompare) - 1
        While nStart > -1
                
            'Find out if the characters to the left or right of the text are characters
            If nStart = 0 Then
                bLeftOk = True
            Else
                nValue = Asc(UCase(Mid(sNewMsg, nStart, 1)))
                bLeftOk = (nValue < Asc("A") Or nValue > Asc("Z"))
            End If
            If nStart + Len(saPicTextRTF(1, i)) = Len(sNewMsg) Then
                bRightOk = True
            Else
                nValue = Asc(UCase(Mid(sNewMsg, nStart + Len(saPicTextRTF(1, i)) + 1, 1)))
                bRightOk = (nValue < Asc("A") Or nValue > Asc("Z"))
            End If
                
            'Do we swap this one out?
            If bLeftOk = True And bRightOk = True Then
                sNewMsg = Left(sNewMsg, InStr(nStart + 1, UCase(sNewMsg), UCase(saPicTextRTF(1, i))) - 1) & _
                    saPicTextRTF(2, i) & _
                    Right(sNewMsg, Len(sNewMsg) - InStr(nStart + 1, UCase(sNewMsg), UCase(saPicTextRTF(1, i))) - Len(saPicTextRTF(1, i)) + 1)
            End If
            'Do we loop again?
            nStart = InStr(nStart + 2, sNewMsg, saPicTextRTF(1, i), vbTextCompare) - 1
            If nStart > Len(sNewMsg) Then nStart = -1
        Wend
        
    Next i
    

    'Convert in system power macros
    bDoneSwapping = False
    While bDoneSwapping = False
        bDoneSwapping = True
    
        'Random generator
        If InStr(1, sNewMsg, "[RANDOM") > 0 Then
            sR = Mid(sNewMsg, InStr(1, sNewMsg, "[RANDOM") + 7)
            If InStr(1, sR, "]") > 0 Then
                sL = Left(sR, InStr(1, sR, "]") - 1)
            End If
            If IsNumeric(sL) = True Then
                nValue = Int((CInt(sL) * Rnd) + 1)
                bDoneSwapping = False
                sNewMsg = Left(sNewMsg, InStr(1, sNewMsg, "[RANDOM") - 1) & _
                            nValue & _
                            Mid(sNewMsg, InStr(1, sNewMsg, "[RANDOM") + 7 + InStr(1, sR, "]"))
            End If
        End If
        
        'Newline insert
        If InStr(1, sNewMsg, "[NEWLINE]") > 0 Then
            bDoneSwapping = False
            sNewMsg = Left(sNewMsg, InStr(1, sNewMsg, "[NEWLINE]") - 1) & _
                        " \par " & _
                        Mid(sNewMsg, InStr(1, sNewMsg, "[NEWLINE]") + 9)
        End If

        'Tab insert
        If InStr(1, sNewMsg, "[TAB]") > 0 Then
            bDoneSwapping = False
            sNewMsg = Left(sNewMsg, InStr(1, sNewMsg, "[TAB]") - 1) & _
                        Chr(9) & _
                        Mid(sNewMsg, InStr(1, sNewMsg, "[TAB]") + 5)
        End If
        
''        'HP insert
''        If InStr(1, sNewMsg, "[MYHP]") > 0 Then
''            bDoneSwapping = False
''            sNewMsg = Left(sNewMsg, InStr(1, sNewMsg, "[MYHP]") - 1) & _
''                        GetPlayer(g_nMyNumber).nHP & _
''                        Mid(sNewMsg, InStr(1, sNewMsg, "[MYHP]") + 6)
''        End If
        
        'Name insert
        If InStr(1, sNewMsg, "[NAME]") > 0 Then
            bDoneSwapping = False
            sNewMsg = Left(sNewMsg, InStr(1, sNewMsg, "[NAME]") - 1) & _
                        GenNewName & _
                        Mid(sNewMsg, InStr(1, sNewMsg, "[NAME]") + 6)
        End If
        
    
    Wend
    
    ConvMsgGraphics = sNewMsg
           
       
    Call WriteProcStop(sRoutineName, ConvMsgGraphics)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Function
Private Function GetFontIndex(sFont As String) As Long

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetFontIndex"
    Call WriteProcStart(sRoutineName, sFont)
        
        
    Dim i As Long
    Dim oTempFont As New StdFont
    oTempFont.Name = sFont

    For i = 1 To UBound(saFontPos, 1)
        If saFontPos(i) = Trim(oTempFont.Name) Then
            GetFontIndex = i - 1 'Zero based index
            GoTo ExitingFunction
            'Exit Function
        End If
    Next i
        
    'The font wasn't in the listing yet so add it
    ReDim Preserve saFontPos(UBound(saFontPos, 1) + 1) As String
        
    GetFontIndex = UBound(saFontPos, 1) - 1 'Zero based index
    
    saFontPos(GetFontIndex + 1) = Trim(oTempFont.Name)
    strFonts = strFonts & "{\f" & GetFontIndex & "\fcharset2 " & Trim(oTempFont.Name) & ";}"
               
       
ExitingFunction:
    Call WriteProcStop(sRoutineName, GetFontIndex)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Function
Private Function GetColorIndex(nCol As Long) As Long

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetColorIndex"
    Call WriteProcStart(sRoutineName, nCol)
        
        
    Dim i As Long
    Dim nRed As Long
    Dim nGreen As Long
    Dim nBlue As Long
    
    nRed = nCol And (2 ^ 0 + 2 ^ 1 + 2 ^ 2 + 2 ^ 3 + 2 ^ 4 + 2 ^ 5 + 2 ^ 6 + 2 ^ 7)
    nGreen = (nCol And (2 ^ 8 + 2 ^ 9 + 2 ^ 10 + 2 ^ 11 + 2 ^ 12 + 2 ^ 13 + 2 ^ 14 + 2 ^ 15)) / (2 ^ 8)
    nBlue = (nCol And (2 ^ 16 + 2 ^ 17 + 2 ^ 18 + 2 ^ 19 + 2 ^ 20 + 2 ^ 21 + 2 ^ 22 + 2 ^ 23)) / (2 ^ 16)

    For i = 1 To UBound(naColPos, 2)
        If naColPos(cRED, i) = nRed And naColPos(cGREEN, i) = nGreen And naColPos(cBLUE, i) = nBlue Then
            GetColorIndex = i - 1 'Zero based index
            GoTo ExitingFunction
            'Exit Function
        End If
    Next i
    
    'The color wasn't in the listing yet so add it
        ReDim Preserve naColPos(0 To 4, UBound(naColPos, 2) + 1) As Long
        
    GetColorIndex = UBound(naColPos, 2) - 1 'Zero based index
    
    naColPos(cRED, GetColorIndex + 1) = nRed
    naColPos(cGREEN, GetColorIndex + 1) = nGreen
    naColPos(cBLUE, GetColorIndex + 1) = nBlue
                    
    strColors = strColors & "\red" & nRed & "\green" & nGreen & "\blue" & nBlue & ";"
               
       
ExitingFunction:
    Call WriteProcStop(sRoutineName, GetColorIndex)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Function
Private Sub Class_Initialize()

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".Class_Initialize"
    Call WriteProcStart(sRoutineName)
        
        
    Call LoadEmotes
               
       
    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Sub
Public Sub LoadEmotes()

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".LoadEmotes"
    Call WriteProcStart(sRoutineName)
        
        
    ReDim Preserve naColPos(0 To 4, 0 To 0) As Long
    ReDim Preserve saFontPos(0) As String
    ReDim saPicTextRTF(1 To 3, 1 To 1) As String

    Dim nFreeFIni As Long
    Dim nFreeF As Long
    Dim sEmote As String
    Dim sFileName As String
    Dim sLineIn As String
    Dim sComment
    Dim sChar
    Dim nBrackets As Long

    If Dir(App.Path & "\Emotes.ini") <> "" Then
        nFreeFIni = FreeFile
        Open App.Path & "\Emotes.ini" For Input As nFreeFIni
    
        While Not EOF(nFreeFIni)
            Input #nFreeFIni, sEmote, sFileName, sComment
                                            
            'Reset then add the emote
            sLineIn = ""
            sChar = ""
            'Record their comment & conv text
            saPicTextRTF(3, UBound(saPicTextRTF, 2)) = sComment
            saPicTextRTF(1, UBound(saPicTextRTF, 2)) = sEmote
                        
            If UCase(Right(sFileName, 4)) = ".TXT" Then
                        'Did we find the graphic file?
                        If Dir(App.Path & "\Graphics\" & sFileName) <> "" Then
                           
                            nFreeF = FreeFile
                            Open App.Path & "\Graphics\" & sFileName For Input As #nFreeF
                                While EOF(nFreeF) = False
                                    Input #nFreeF, sLineIn
                                    saPicTextRTF(2, UBound(saPicTextRTF, 2)) = saPicTextRTF(2, UBound(saPicTextRTF, 2)) & sLineIn
                                Wend
                            Close #nFreeF
                            
                        End If
            
            ElseIf UCase(Right(sFileName, 4)) = ".RTF" Then
                        'Did we find the graphic file?
                        If Dir(App.Path & "\Graphics\" & sFileName) <> "" Then
                        
                            nFreeF = FreeFile
                            Open App.Path & "\Graphics\" & sFileName For Input As #nFreeF
                              
                                While EOF(nFreeF) = False And InStr(1, saPicTextRTF(2, UBound(saPicTextRTF, 2)), "\wmetafile") = 0
                                    sChar = ""
                                    sLineIn = ""
                                    nBrackets = 0
                                    
                                    'Read all the header info in
                                    While EOF(nFreeF) = False And InStr(1, sLineIn, "\pict") = 0 'Or InStr(1, sLineIn, "\wmetafile") = 0)
                                        Input #nFreeF, sLineIn
                                    Wend
                                    saPicTextRTF(2, UBound(saPicTextRTF, 2)) = Right(sLineIn, Len(sLineIn) - InStr(1, sLineIn, "{\pict") + 1) & Chr(13) & Chr(10)
                                    
                                    nBrackets = GetBracketCount(saPicTextRTF(2, UBound(saPicTextRTF, 2)))
                                    
                                    'Load in the actual graphic
                                    While EOF(nFreeF) = False And nBrackets > 0 'sChar <> "}"
                                        sChar = StrConv(InputB$(1, nFreeF), vbUnicode)
                                        If sChar = "{" Then
                                            nBrackets = nBrackets + 1
                                        End If
                                        If sChar = "}" Then
                                            nBrackets = nBrackets - 1
                                        End If
                                        
                                        'Finish writting down their picture
                                        saPicTextRTF(2, UBound(saPicTextRTF, 2)) = saPicTextRTF(2, UBound(saPicTextRTF, 2)) & sChar
                                    Wend
                                
                                    saPicTextRTF(2, UBound(saPicTextRTF, 2)) = "{" & saPicTextRTF(2, UBound(saPicTextRTF, 2)) & "}"
                                
                                'End If
                                Wend
                                
                            Close #nFreeF
                            
                        End If
            Else
                saPicTextRTF(2, UBound(saPicTextRTF, 2)) = sFileName
            End If
                                    
            'Check to make sure this is a valid replacement
            If InStr(1, saPicTextRTF(1, UBound(saPicTextRTF, 2)), saPicTextRTF(2, UBound(saPicTextRTF, 2))) > 0 Then
                'They have the search string in the replace string... infinite loop
                Call MsgBox("Emote " & sEmote & " is not valid.  The search text is in the replacement text.", vbExclamation, "Emote Load Error")
                saPicTextRTF(2, UBound(saPicTextRTF, 2)) = "{\b [INVALID]}"
                
            End If
            
            'Make room in the array for the next element
            ReDim Preserve saPicTextRTF(1 To 3, 1 To UBound(saPicTextRTF, 2) + 1) As String
        
        Wend
        
        Close nFreeFIni
        
    Else
        Call MsgBox("I'm sorry, the Emotes.ini file is not located in your DNDOnline" & _
                      "directory.  No Emotes will be available during this DNDOnline session.", vbCritical + vbOKOnly, "Error Loading Emotes!")
    End If
               
       
    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Sub
Public Function GetBracketCount(sMsg As String) As Long

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetBracketCount"
    Call WriteProcStart(sRoutineName, sMsg)
    
    
    Dim i As Long
    Dim nBCount As Long
    nBCount = 0
    
    For i = 1 To Len(sMsg)
        If Mid(sMsg, i, 1) = "{" Then
            nBCount = nBCount + 1
        ElseIf Mid(sMsg, i, 1) = "}" Then
            nBCount = nBCount - 1
        End If
    Next i
    
    GetBracketCount = nBCount
    

    Call WriteProcStop(sRoutineName, GetBracketCount)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Function
Public Sub MoveFirstEmote()

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".MoveFirstEmote"
    Call WriteProcStart(sRoutineName)
    
    
    nIndex = 1
    
    
    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
    
End Sub
Public Function GetEmoteIndex() As Long

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetEmoteIndex"
    Call WriteProcStart(sRoutineName)
    
    
    GetEmoteIndex = nIndex
    
    
    Call WriteProcStop(sRoutineName, GetEmoteIndex)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
        
End Function
Public Function EmoteEOF() As Boolean

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".EmoteEOF"
    Call WriteProcStart(sRoutineName)
    
    
    EmoteEOF = (nIndex < 1 Or nIndex > UBound(saPicTextRTF, 2) - 1)
    
    
    Call WriteProcStop(sRoutineName, EmoteEOF)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Function
Public Sub MoveNextEmote()

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".MoveNextEmote"
    Call WriteProcStart(sRoutineName)
    
    
    nIndex = nIndex + 1
        
    
    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Sub
Public Function GetEmoteText() As String

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetEmoteText"
    Call WriteProcStart(sRoutineName)
    
    
    If EmoteEOF = True Then
        GetEmoteText = "Invalid"
    Else
        GetEmoteText = saPicTextRTF(1, nIndex)
    End If
        
    
    Call WriteProcStop(sRoutineName, GetEmoteText)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Function
Public Function GetEmoteName() As String

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetEmoteName"
    Call WriteProcStart(sRoutineName)
    

    If EmoteEOF = True Then
        GetEmoteName = "Invalid"
    Else
        GetEmoteName = saPicTextRTF(3, nIndex)
    End If
        
    
    Call WriteProcStop(sRoutineName, GetEmoteName)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Function
Public Function GetItemEmoteText(nInd As Long) As String

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetItemEmoteText"
    Call WriteProcStart(sRoutineName, nInd)
    
    
    GetItemEmoteText = saPicTextRTF(1, nInd)
        
    
    Call WriteProcStop(sRoutineName, GetItemEmoteText)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Function
Public Function GetItemEmoteName(nInd As Long) As String

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = Me.Name & ".GetItemEmoteName"
    Call WriteProcStart(sRoutineName, nInd)
    
    
    GetItemEmoteName = saPicTextRTF(3, nInd)
        
    
    Call WriteProcStop(sRoutineName, GetItemEmoteName)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Function
'This is a central point for adding messages.  All font interpretation
'and scroll changes are handled here
Public Sub RTBAddMessage(RTB As RichTextBox, oFont As StdFont, nFontColor As Long, sMsg As String)

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = cFRMNAME & ".RTBAddMessage"
    Call WriteProcStart(sRoutineName, RTB.Name, "OBJECT", nFontColor, sMsg)
    

    Dim bWasAtEnd As Boolean
    Dim nStartSel As Long
    Dim nNewStartSel As Long
    Dim strMsg As String
    'Dim sFinalFontOpt As String
    'Dim sFinalFontName As String
    Dim oFinalFont As StdFont
    Dim nFinalFontColor As Long
    Dim oTempFont As New StdFont
    Dim sName As String
    Dim sRestMsg As String

    'Mark down the status BEFORE adding things
    bWasAtEnd = (RTB.SelStart = Len(RTB.Text))
    nStartSel = RTB.SelStart

    If InStr(1, sMsg, ":") > 0 Then
        sName = Left(sMsg, InStr(1, sMsg, ":") + 1)
        Set oFinalFont = g_oFontName

        'Call g_oRTBMessages.AddMessage(sFOptions, g_sNameFontName, g_nFontNameColor, sName, False)
        sRestMsg = Right(sMsg, Len(sMsg) - InStr(1, sMsg, ":") - 1)
    Else
        sRestMsg = sMsg
        Set oFinalFont = g_oFontDefault
    End If

    RTB.SelStart = Len(RTB.Text)
    RTB.SelRTF = g_oRTBMessages.FormatForInsert(oFinalFont, g_nFontNameColor, sName, True)

    RTB.SelStart = Len(RTB.Text)

    If g_bSupressColors = True Then
        nFinalFontColor = g_nFontDefaultColor
    Else
        nFinalFontColor = nFontColor
    End If
    If g_bSupressFonts = True Then
        Set oFinalFont = g_oFontDefault
    Else
        Set oFinalFont = oFont
    End If
    RTB.SelRTF = g_oRTBMessages.FormatForInsert(oFinalFont, nFinalFontColor, sRestMsg, (Not (Len(sName) > 0)))


    While RTBNumberOfLines(RTB) > g_nLinesInChat
        Call g_oRTBMessages.RTBEraseFirstLine(RTB)
    Wend


    'Were they at the bottom of the list?
    If bWasAtEnd = True Then
        'Keep them there!
        RTB.SelStart = Len(RTB.Text)
    'Otherwise put them back where they were
    Else
        'Keep their selected text where it was
        RTB.SelStart = nStartSel
    End If


    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Sub

Public Function RTBNumberOfLines(RTB As RichTextBox) As Long

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = cFRMNAME & ".RTBNumberOfLines"
    Call WriteProcStart(sRoutineName, RTB.Name)


    Dim sText As String
    Dim nCount As Long
    Dim i As Long
    sText = RTB.Text
    i = 1

    While InStr(i, sText, Chr(13)) > 0
        i = InStr(i, sText, Chr(13)) + 1
        nCount = nCount + 1
    Wend

    RTBNumberOfLines = nCount + 1


    Call WriteProcStop(sRoutineName, RTBNumberOfLines)
    'Exit the sub... on an error we will jump over this function
    Exit Function
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Function
Public Sub RTBSetColorItalicised(RTB As RichTextBox, bItalicised As Boolean, nFontColor As Long, sSearch As String, sMsg As String)

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = cFRMNAME & ".RTBSetColorItalicised"
    Call WriteProcStart(sRoutineName, RTB.Name, bItalicised, nFontColor, sSearch, sMsg)


    Dim nSelStart As Long
    Dim nSelLen As Long
    Dim nWhereIn As Long

    nWhereIn = InStr(1, RTB.Text, sMsg) - 1

    'Is this name italisized already?
    If nWhereIn >= 0 Then
        nSelStart = RTB.SelStart
        nSelLen = RTB.SelLength

        RTB.SelStart = nWhereIn
        RTB.SelLength = Len(sSearch)

        RTB.SelItalic = bItalicised
        RTB.SelColor = nFontColor

        RTB.SelStart = nSelStart
        RTB.SelLength = nSelLen
    End If


    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Sub
Public Sub RTBAddNewMessage(RTB As RichTextBox, sMsg As String)

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = cFRMNAME & ".RTBAddNewMessage"
    Call WriteProcStart(sRoutineName, RTB.Name, sMsg)
    
    
    RTB.TextRTF = Left(RTB.TextRTF, Len(RTB.TextRTF) - 9) & _
                    sMsg & " \par " & Right(RTB.TextRTF, 9)
   

    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)
           
End Sub
Public Sub RTBRemoveMessage(RTB As RichTextBox, sMsg As String)

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = cFRMNAME & ".RTBRemoveMessage"
    Call WriteProcStart(sRoutineName, RTB.Name, sMsg)


    Dim nSelStart As Long
    Dim nSelLen As Long
    Dim nWhereIn As Long

    'Save where their name is
    nWhereIn = InStr(1, RTB.Text, sMsg)

    If nWhereIn > 0 Then
        nSelStart = RTB.SelStart
        nSelLen = RTB.SelLength

        RTB.SelStart = nWhereIn - 1
        RTB.SelLength = Len(sMsg)
        RTB.SelText = ""

        RTB.SelStart = nSelStart
        RTB.SelLength = nSelLen
    End If


    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Sub
Public Sub RTBEraseFirstLine(RTB As RichTextBox)

    '''''On Error GoTo ErrorHandler
    Dim sRoutineName As String
    sRoutineName = cFRMNAME & ".RTBEraseFirstLine"
    Call WriteProcStart(sRoutineName, RTB.Name)


    RTB.SelStart = 0
    RTB.SelLength = InStr(1, RTB.Text, Chr(10)) + 2
    RTB.SelText = ""


    Call WriteProcStop(sRoutineName)
    'Exit the sub... on an error we will jump over this function
    Exit Sub
ErrorHandler:
    Call ErrorTrapper(sRoutineName)

End Sub
