Attribute VB_Name = "modRichText"
'-----------------------------------------------------
' MirageBot RichTextBox Manipulation Module
' Written by Christopher Nevin (lancergli@gmail.com)
'-----------------------------------------------------

Option Explicit

Private Const WM_PASTE As Long = &H302
Private Type NMHDR
    hWndFrom As Long
    idFrom As Long
    Code As Long
End Type

Private Type CHARRANGE
    cpMin As Long
    cpMax As Long
End Type

Private Type ENLINK
    hdr As NMHDR
    msg As Long
    wParam As Long
    lParam As Long
    chrg As CHARRANGE
End Type

Private Type TEXTRANGE
    chrg As CHARRANGE
    lpstrText As String
End Type

Const EM_GETSCROLLPOS As Long = &H400 + 221
Const EM_SETSCROLLPOS As Long = &H400 + 222
Const EM_CHARFROMPOS As Long = &HD7
Const EM_SETEVENTMASK As Long = &H445
Const EM_GETEVENTMASK As Long = &H43B
Const EM_GETTEXTRANGE As Long = &H44B
Const EM_AUTOURLDETECT As Long = &H45B
Const EN_LINK As Long = &H70B
Const ENM_LINK As Long = &H4000000
Const LF_FACESIZE        As Long = 32
Const SW_SHOWNORMAL      As Long = &H1
Const CFE_LINK As Long = &H20
Const GWL_WNDPROC As Long = (-4)
Const GWL_EXSTYLE As Long = (-20)
Const SW_SHOW As Long = 5
Const WS_EX_TRANSPARENT As Long = &H20&

Const WM_NOTIFY As Long = &H4E
Const WM_LBUTTONDBLCLK As Long = &H203
Const WM_LBUTTONDOWN As Long = &H201
Const WM_LBUTTONUP As Long = &H202
Const WM_MOUSEMOVE As Long = &H200
Const WM_RBUTTONDBLCLK As Long = &H206
Const WM_RBUTTONDOWN As Long = &H204
Const WM_RBUTTONUP As Long = &H205
Const WM_SETCURSOR As Long = &H20

Dim lOldProc As Long 'Old windowproc
Dim hWndRTB As Long 'hWnd of RTB
Dim hWndParent As Long 'hWnd of parent window
Private Declare Function WriteFile Lib "kernel32.dll" (ByVal iFileHandle As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CreateFileA Lib "kernel32" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   ByVal lpSecurityAttributes As Long, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const OPEN_ALWAYS As Long = 4
Private Const FILE_BEGIN As Long = 0
Private Const FILE_END As Long = 2
Private Const GENERIC_WRITE As Long = &H40000000
Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80

Public Function API_AppendFile(sFile As String, sText As String)
    Dim hFile As Long, lpFileSize As Currency, bText() As Byte, iLength As Long
    hFile = CreateFileA(sFile, _
                GENERIC_WRITE Or GENERIC_READ, 0&, ByVal 0&, _
                OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
    bText = StrToByteArray(sText)
    SetFilePointer hFile, 0, 0, FILE_END
    WriteFile hFile, bText(0), UBound(bText) + 1, 0, 0&
    CloseHandle hFile
End Function

Public Sub LogText(Index As Integer, Text As String, Optional Whisper As Boolean = False)
On Error GoTo hErr
    If LenB(frmBot.Bot(Index).Profile) = 0 Then Exit Sub
    Dim Path As String, FF As Integer
    FF = FreeFile
    Path = AppData & "Profiles\" & frmBot.Bot(Index).Profile
    CreateFolder Path
    Path = Path & "\Logs"
    CreateFolder Path
    Path = Path & "\" & MonthName(Month(Date)) & Space$(1) & Year(Date)
    CreateFolder Path
    Path = Path & "\" & Format$(Day(Date), "00") & " " & WeekdayName(Weekday(Date), False) & IIf(Whisper, "_Whispers", vbNS) & ".log"
    If CreateFile(Path) = True Then
        API_AppendFile Path, frmBot.Bot(Index).Profile & IIf(Whisper, " whisper", vbNS) & " log file for " & Date & vbNewLine & Replace$(Text, vbNewLine, vbNS)
    Else
        API_AppendFile Path, Text
    End If
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "ReadWrite", "LogText", , Index
End Sub

Public Sub LogHTML(Index As Integer, Text As String, Optional Whisper As Boolean = False)
On Error GoTo hErr
    If LenB(frmBot.Bot(Index).Profile) = 0 Then Exit Sub
    Dim Path As String
    Path = AppData & "Profiles\" & frmBot.Bot(Index).Profile
    CreateFolder Path
    Path = Path & "\Logs"
    CreateFolder Path
    Path = Path & "\" & MonthName(Month(Date)) & Space$(1) & Year(Date)
    CreateFolder Path
    Path = Path & "\" & Format$(Day(Date), "00") & " " & WeekdayName(Weekday(Date), False) & IIf(Whisper, "_Whispers", vbNS) & ".html"
    If CreateFile(Path) = True Then
        API_AppendFile Path, "<title>MirageBot [" & frmBot.Bot(Index).Profile & "]" & IIf(Whisper, " whisper", vbNS) & " log for " & Date & "</title>" & _
                "<style type=text/css>font { font-family: Verdana, Arial, sans-serif; font-size: 14px; }</style></head>" & _
                "<body bgcolor=#000000><font color=#FFFFFF><h3>" & _
                frmBot.Bot(Index).Profile & IIf(Whisper, " whisper", vbNS) & " log file for " & Date & "</h3></font>" & Replace$(Text, vbNewLine, "<br/>") & vbNewLine
    Else
        API_AppendFile Path, Replace$(Text, vbNewLine, "<br/>") & vbNewLine
    End If
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "ReadWrite", "LogHTML", , Index
End Sub

Public Function HTMLFormat(ByVal lngColor As Long, ByVal strLine As String) As String
    If strLine = vbNewLine Then
        HTMLFormat = strLine
        Exit Function
    End If
    
    Dim strColorCode As String
    strColorCode = Right$("000000" & Hex$(lngColor), 6)
    strColorCode = Right$(strColorCode, 2) & Mid$(strColorCode, 3, 2) & Left$(strColorCode, 2)
    
    strLine = Replace(strLine, "&", "&amp;")
    strLine = Replace(strLine, "<", "&lt;")
    strLine = Replace(strLine, ">", "&gt;")
    strLine = Replace(strLine, "&lt;b&gt;", vbNS)
    strLine = Replace(strLine, "&lt;i&gt;", vbNS)
    strLine = Replace(strLine, "&lt;s&gt;", vbNS)
    strLine = Replace(strLine, "&lt;u&gt;", vbNS)
    strLine = Replace(strLine, "&lt;/b&gt;", vbNS)
    strLine = Replace(strLine, "&lt;/i&gt;", vbNS)
    strLine = Replace(strLine, "&lt;/s&gt;", vbNS)
    strLine = Replace(strLine, "&lt;/u&gt;", vbNS)
    
    HTMLFormat = "<font color=#" & strColorCode & ">" & strLine & "</font>"
End Function

Public Sub EnableURLDetect(ByVal hWndTextbox As Long, ByVal hWndOwner As Long)
    If lOldProc = 0 Then
    lOldProc = SetWindowLong(hWndOwner, GWL_WNDPROC, AddressOf WndProc)
    SendMessage hWndTextbox, EM_SETEVENTMASK, 0, ByVal ENM_LINK Or SendMessage(hWndTextbox, EM_GETEVENTMASK, 0, 0)
    SendMessage hWndTextbox, EM_AUTOURLDETECT, 1, ByVal 0
    hWndParent = hWndOwner
    hWndRTB = hWndTextbox
    End If
End Sub

Public Sub URLViewing(B As Boolean, ByVal hWndRTB As Long)
    If B Then
        SendMessage hWndRTB, EM_AUTOURLDETECT, 1, ByVal 0
    Else
        SendMessage hWndRTB, EM_AUTOURLDETECT, 0, ByVal 0
    End If
End Sub

Public Sub DisableURLDetect()
    If lOldProc Then
    SendMessage hWndRTB, EM_AUTOURLDETECT, 1, ByVal 0
    SetWindowLong hWndParent, GWL_WNDPROC, lOldProc
    lOldProc = 0
    End If
End Sub

Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim uHead As NMHDR, eLink As ENLINK, eText As TEXTRANGE, sText As String, lLen As Long
    Select Case uMsg
    Case WM_NOTIFY
        CopyMemory uHead, ByVal lParam, Len(uHead)
        If (uHead.hWndFrom = hWndRTB) And (uHead.Code = EN_LINK) Then
            CopyMemory eLink, ByVal lParam, Len(eLink)
            Select Case eLink.msg
                Case WM_LBUTTONDBLCLK
                    eText.chrg.cpMin = eLink.chrg.cpMin
                    eText.chrg.cpMax = eLink.chrg.cpMax
                    eText.lpstrText = Space$(1024)
                    lLen = SendMessage(hWndRTB, EM_GETTEXTRANGE, 0, eText)
                    sText = Left$(eText.lpstrText, lLen)
                    ShellExecute hWndParent, vbNS, sText, vbNS, vbNS, SW_SHOW
                Case WM_LBUTTONDOWN
                Case WM_LBUTTONUP
                Case WM_RBUTTONDBLCLK
                Case WM_RBUTTONDOWN
                Case WM_RBUTTONUP
                Case WM_SETCURSOR
            End Select
        End If
    End Select
    WndProc = CallWindowProc(lOldProc, hwnd, uMsg, wParam, lParam)
End Function

Public Sub ReplaceStyles(rtb As RichTextBox, dblStart As Double)
On Error GoTo hErr
    Dim Pos As Double, colour As Long
    Do
        Pos = rtb.Find("<b>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 3
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelBold = True
        End If
    Loop Until Pos = -1 Or (Err)
    Do
        Pos = rtb.Find("</b>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 4
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelBold = False
        End If
    Loop Until Pos = -1 Or (Err)
    Do
        Pos = rtb.Find("<i>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 3
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelItalic = True
        End If
    Loop Until Pos = -1 Or (Err)
    Do
        Pos = rtb.Find("</i>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 4
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelItalic = False
        End If
    Loop Until Pos = -1 Or (Err)
    Do
        Pos = rtb.Find("<s>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 3
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelStrikeThru = True
        End If
    Loop Until Pos = -1 Or (Err)
    Do
        Pos = rtb.Find("<s>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 4
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelStrikeThru = False
        End If
    Loop Until Pos = -1 Or (Err)
    Do
        Pos = rtb.Find("<u>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 3
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelUnderline = True
        End If
    Loop Until Pos = -1 Or (Err)
    Do
        Pos = rtb.Find("</u>", dblStart)
        If (Pos <> -1) Then
            rtb.SelStart = Pos
            rtb.SelLength = 4
            rtb.SelText = vbNS
            rtb.SelStart = Pos
            rtb.SelLength = 200000000
            rtb.SelUnderline = False
        End If
    Loop Until Pos = -1 Or (Err)
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "RichTextBox", "ReplaceStyles"
End Sub

Public Sub ReplaceColours(rtb As RichTextBox, dblStart As Double)
On Error GoTo hErr
1   Dim Pos As Double, colour As Long
2   If options.DisableChatColors Then Exit Sub
3   Do
4       Pos = rtb.Find("Á", dblStart)
5       If (Pos > 0) Then
6           rtb.SelStart = Pos
7           rtb.SelLength = 2
8           If Len(rtb.SelText) = 2 Then
                Select Case Mid$(rtb.SelText, 2)
                    Case "P", "W": colour = SCWhite
                    Case "Q": colour = SCGray
                    Case "R": colour = SCGreen
                    Case "S", "X", "Z": colour = SCYellow
                    Case "T", "U", "V": colour = SCCyan
                    Case "Y", "[": colour = SCRed
                    Case Else: colour = SCWhite
                End Select
18          End If
19          rtb.SelText = vbNS
20          rtb.SelStart = Pos
21          rtb.SelLength = 200000000
22          rtb.SelColor = colour
23      End If
24  Loop Until (Pos < 1) Or (Err)
25  Do
26      Pos = rtb.Find("ÿc", dblStart)
27      If (Pos > 0) Then
28          Dim Bold As Boolean, Italic As Boolean, Underline As Boolean, Strike As Boolean
29          Strike = False
30          Bold = False
31          Italic = False
32          Underline = False
33          rtb.SelStart = Pos
34          rtb.SelLength = 3
35          If Len(rtb.SelText) = 3 Then
                Select Case Mid$(rtb.SelText, 3)
                    Case "0": colour = D2White
                    Case "1": colour = D2Red
                    Case "2": colour = D2Green
                    Case "3": colour = D2Blue
                    Case "4": colour = D2Beige
                    Case "5": colour = D2Gray
                    Case "6": colour = D2Black
                    Case "7": colour = D2Beige2
                    Case "8": colour = D2Orange
                    Case "9": colour = D2LtYellow
                    Case ":": colour = D2MdGreen
                    Case ";": colour = D2Purple
                    Case "<": colour = D2DkGreen
                    Case "B": Bold = True
                    Case "I": Italic = True
                    Case "S": Strike = True
                    Case "U": Underline = True
                    Case Else: colour = D2White
                End Select
56          End If
57          rtb.SelText = vbNS
58          rtb.SelStart = Pos
59          rtb.SelLength = 200000000
60          If Bold Then rtb.SelBold = Not rtb.SelBold
61          If Italic Then rtb.SelItalic = Not rtb.SelItalic
62          If Underline Then rtb.SelUnderline = Not rtb.SelUnderline
63          If Strike Then rtb.SelStrikeThru = Not rtb.SelStrikeThru
64          If colour <> &H0 Then rtb.SelColor = colour
65      End If
66  Loop Until (Pos < 1) Or (Err)
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "RichTextBox", "ReplaceColours"
End Sub

Public Function FormatSmilies(ByVal Message As String) As String
    If options.Emoticons = False Then FormatSmilies = Message: Exit Function
    With frmBot.imlSmiley.ListImages
        Dim I As Integer
        For I = 1 To .Count
            Dim S() As String, X As Integer
            S = Split(.Item(I).Tag, "#")
            For X = 0 To UBound(S)
                If InStrB(Message, S(X)) <> 0 Then Message = Replace$(Message, S(X), "¨" & S(X) & "¨")
            Next X
        Next I
    End With
    FormatSmilies = Message
End Function

Private Function ValidExtensions(Folder As String, A As String, B As String, C As String) As Boolean
    Dim F As New FileSystemObject, List() As String, I As Integer
    If F.FolderExists(Folder) Then
        List = FileList(Folder & "*.*")
        For I = 0 To UBound(List)
            Select Case LCase$(Right$(List(I), 3))
            Case A, B, C: ValidExtensions = True: Exit Function
            End Select
        Next
    End If
End Function

Public Sub ImportEmoticons()
    Dim Emoticons() As String, I As Integer
    Emoticons = FileList(AppData & "Emoticons\*.ini")
    For I = frmBot.mnuEmoIcon.ubound To 1 Step -1
        Unload frmBot.mnuEmoIcon(I)
    Next I
    frmBot.mnuEmoIcon(0).Caption = vbNS
    For I = 0 To UBound(Emoticons)
        If Len(Emoticons(I)) > 4 Then
            Dim Name As String
            Name = Left$(Emoticons(I), Len(Emoticons(I)) - 4)
            If ValidExtensions(AppData & "Emoticons\" & Name & "\", "jpg", "gif", "bmp") Then
                If LenB(frmBot.mnuEmoIcon(0).Caption) > 0 Then Load frmBot.mnuEmoIcon(frmBot.mnuEmoIcon.Count)
                frmBot.mnuEmoIcon(frmBot.mnuEmoIcon.ubound).Caption = Name
                frmBot.mnuEmoIcon(frmBot.mnuEmoIcon.ubound).Checked = (LCase$(Name) = LCase$(options.EmoticonSet))
            End If
        End If
    Next I
End Sub

Public Sub ReplaceEmoticons(rtb As RichTextBox, StartPos As Double)
    rtb.Locked = False
    With frmBot.imlSmiley.ListImages
        Dim I As Integer
        For I = 1 To .Count
            Dim S() As String, X As Integer
            S = Split(.Item(I).Tag, "#")
            For X = 0 To UBound(S)
                ReplaceEmoticon rtb, StartPos, "¨" & S(X) & "¨", I
            Next X
        Next
    End With
    rtb.Locked = True
End Sub

Private Sub ReplaceEmoticon(rtb As RichTextBox, dblStart As Double, strCompare As String, intPicture As Integer)
On Error GoTo hErr
    Dim Pos As Double
    Do
        Pos = rtb.Find(strCompare, dblStart)
        If (Pos > 0) Then
            rtb.SelStart = Pos
            rtb.SelLength = Len(strCompare)
            rtb.SelText = vbNS
            InsertPicture rtb, frmBot.imlSmiley.ListImages(intPicture).Picture
        End If
    Loop Until (Pos < 1) Or (Err)
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "RichTextBox", "ReplaceEmoticon"
End Sub

Private Sub InsertPicture(rtb As RichTextBox, pic As StdPicture)
    On Error Resume Next
    Clipboard.Clear
    Clipboard.SetData pic
    SendMessage rtb.hwnd, WM_PASTE, 0&, 0&
End Sub

