Public feed
#889732
Option Explicit
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessageSTRING Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SendMessageLONG Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const WM_SETTEXT = &HC
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
'Private Const EM_GETSELTEXT = (WM_USER + 62)
Private Const WM_USER = &H400
Private Const VK_SPACE = &H20
Private Const BM_CLICK = &HF5
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const HWND_TOPMOST = -1
Dim message_old As String
Dim qCaption As String
Public Sub SendMess(str As String)
Dim OurParent As Long, OurHandle As Long, OurButton As Long, OurSettsz As Long, OurSettzz As Long
OurParent = FindWindowWild("*Video Chat Room*", False)
OurParent = FindWindowWild("*Topic:*", False)
OurHandle& = FindWindowEx(OurParent&, 0, "RichEdit20A", vbNullString)
OurSettzz& = FindWindowEx(OurParent&, OurHandle&, "RichEdit20A", vbNullString)
OurHandle& = OurSettzz&
OurButton& = FindWindowEx(OurParent&, 0, "Button", vbNullString)
SendMessageSTRING OurHandle, WM_SETTEXT, 256, str
SendMessageSTRING OurButton, BM_CLICK, 0, 0
frmChat.txtSendMess.Text = ""
frmChat.txtSendMess.SetFocus
End Sub
Public Sub SendMSG(sCaption As String, sWayz As String, sReason As String)
Dim OurParent As Long, OurHandle As Long, OurButton As Long, OurSettsz As Long, OurSettzz As Long
OurParent = FindWindowWild("*Video Chat Room*", False)
OurParent = FindWindowWild("*Topic:*", False)
OurHandle& = FindWindowEx(OurParent&, 0, "RichEdit20A", vbNullString)
OurSettzz& = FindWindowEx(OurParent&, OurHandle&, "RichEdit20A", vbNullString)
OurHandle& = OurSettzz&
OurButton& = FindWindowEx(OurParent&, 0, "Button", vbNullString)
SendMessageSTRING OurHandle, WM_SETTEXT, 256, sCaption & Chr$(32) & sWayz & Chr$(32) & sReason
SendMessageSTRING OurButton, BM_CLICK, 0, 0
'txtSend.SetFocus
End Sub
Private Sub GetMSG()
On Error Resume Next
Dim OurParent As Long, OurHandle As Long, OurButton As Long, OurSettsz As Long, OurSettzz As Long
Dim length As Long, strtmp As String, result As Long, ihEdit As Long, strtmp2 As String
Dim lTemp As String
Dim aTmp As String, bTmp As String, cTmp As String
result = 0
length = 0
ihEdit = 0
OurParent = FindWindowWild("*Video Chat Room*", False)
OurParent = FindWindowWild("*Topic:*", False)
OurHandle& = FindWindowEx(OurParent&, 0, "RichEdit20A", vbNullString)
length = SendMessage(OurHandle, WM_GETTEXTLENGTH, 0, 0) + 1
strtmp = Space(length - 1)
result = SendMessage(OurHandle, WM_GETTEXT, length, strtmp)
'message_old
'MsgBox result
strtmp2 = strtmp
If strtmp <> message_old Then
strtmp = Replace$(strtmp, message_old, "")
'strtmp = Right$(strtmp, strtmp - Len(message_old))
'lTemp = Split(strtmp, Chr$(13))(1)
'MsgBox lTemp
'MsgBox strtmp
If frmRoom.rdRoom.Value = 1 Then
frmChat.txtMain.SelStart = Len(frmChat.txtMain.Text)
frmChat.txtMain.SelText = strtmp
End If
If (frmRoom.chkLogIt.Value = 1) Then
WriteToLog strtmp
End If
'Welcome Join msg
ReadJoins (strtmp)
TriviaOpt (strtmp)
'return msg_old
message_old = strtmp2
End If
End Sub
Private Sub ReadJoins(Users As String)
Dim asUsers() As String
Dim strName As String
Dim i As Integer
asUsers = Split(Users, vbCrLf)
For i = 0 To UBound(asUsers)
'MsgBox Left$(asUsers(I), 5)
If (Left$(asUsers(i), 5) = "Join:") Then
strName = Split(asUsers(i), "Join:")(1)
UserJoined (strName)
Exit Sub
End If
Next
End Sub
Private Sub TriviaOpt(Users As String)
Dim asUsers() As String
Dim strName As String
Dim strTempA As String
Dim strTempB As String
Dim strTempC As String
Dim strTempD As String
Dim strTempE As Integer
Dim strTempF As String
Dim i As Integer
asUsers = Split(Users, vbCrLf)
For i = 0 To UBound(asUsers)
'MsgBox asUsers(I)
strTempC = UCase$(asUsers(i))
'MsgBox strTempC
If InStr(strTempC, "!TRIVIA") Then
'MsgBox strTempC
strName = Split(strTempC, "!TRIVIA ")(1)
'MsgBox strName
If (UCase$(strName) = "ON") Then
If frmTrivia.chkTrivia.Value = 1 Then Exit Sub
frmTrivia.TriviaStart
Exit Sub
ElseIf (UCase$(strName) = "OFF") Then
If frmTrivia.chkTrivia.Value = 0 Then Exit Sub
frmTrivia.TriviaStop
Exit Sub
Else
Exit Sub
End If
End If
If frmTrivia.chkTrivia.Value = 0 Then Exit Sub
strTempA = Split(asUsers(i), " : ")(0)
strTempA = Replace(strTempA, Chr$(32), "")
strTempB = Split(asUsers(i), " : ")(1)
'MsgBox strTempB
If UCase$(strTempB) = UCase$(frmTrivia.txtAnswer.Text) Then
'MsgBox strTempB
strTempD = INI_Read("scores", strTempA, App.Path & "\trivia\scores.ini")
If strTempD = "" Then strTempD = 0
'If strTempD <> "" Then
strTempE = strTempD + 1
strTempF = ":scr:" & strTempE
strTempF = Replace$(strTempF, ":scr:", "")
frmTrivia.CorrectAnswer strTempA, strTempF
'ClearScreen
Exit Sub
'MsgBox strTempE
'MsgBox "scores" & vbCrLf & strTempA & vbCrLf & strTempF & vbCrLf & App.Path & "\data\scores.ini"
End If
'UserJoined (strName)
Exit Sub
Next
End Sub
Private Sub UserJoined(user As String)
If (frmRoom.chkOnjoin.Value = 1) Then
user = Replace$(user, Chr$(32), "")
SendMSG "Welcome (C) " & user & " (C)", "", ""
End If
End Sub
Private Sub ClearScreen()
On Error Resume Next
Dim OurParent As Long, OurHandle As Long, OurButton As Long, OurSettsz As Long, OurSettzz As Long
OurParent = FindWindowWild("*Video Chat Room*", False)
OurParent = FindWindowWild("*Topic:*", False)
OurHandle& = FindWindowEx(OurParent&, 0, "RichEdit20A", vbNullString)
' OurSettzz& = FindWindowEx(OurParent&, OurHandle&, "RichEdit20A", vbNullString)
' OurHandle& = OurSettzz&
' OurButton& = FindWindowEx(OurParent&, 0, "Button", vbNullString)
SendMessageSTRING OurHandle, WM_SETTEXT, 256, ""
' SendMessageSTRING OurButton, BM_CLICK, 0, 0
SendMSG "(C) RataTux Operator Tool Loaded... (C)", "", ""
txtSend.SetFocus
End Sub
Private Sub cmdClear_Click()
Call ClearScreen
End Sub
Private Sub cmdCommand_Click(Index As Integer)
Dim sResult As VbMsgBoxResult
Select Case Index
Case 0
SendMSG "/punish", Me.txtSend.Text, Me.cmbReason.Text
Exit Sub
Case 1
SendMSG "/unpunish", Me.txtSend.Text, Me.cmbReason.Text
Exit Sub
Case 2
SendMSG "/blockmic", Me.txtSend.Text, Me.cmbReason.Text
Exit Sub
Case 3
SendMSG "/unblockmic", Me.txtSend.Text, Me.cmbReason.Text
Exit Sub
Case 4
SendMSG "(ST)", Me.txtSend.Text & Chr$(32) & "(ST) This is a warning: ", Me.cmbReason.Text
Exit Sub
Case 5
SendMSG "/kick", Me.txtSend.Text, Me.cmbReason.Text
Exit Sub
Case 6
sResult = MsgBox("Are you sure you want to Ban '" & txtSend.Text & "'", vbInformation + vbYesNo, Me.Caption)
If sResult = 6 Then
SendMSG "/ban", Me.txtSend.Text, Me.cmbReason.Text
Exit Sub
End If
Case 7
sResult = MsgBox("Are you sure you want to Ban '" & txtSend.Text & "' on IP.", vbInformation + vbYesNo, Me.Caption)
If sResult = 6 Then
SendMSG "/banip", Me.txtSend.Text, Me.cmbReason.Text
Exit Sub
End If
End Select
'.cmdCommand(0).Caption = "Punish"
'.cmdCommand(1).Caption = "Un-Punish"
'.cmdCommand(2).Caption = "Block Mic"
'.cmdCommand(3).Caption = "Un-Block Mic"
'.cmdCommand(4).Caption = "Warn User"
'.cmdCommand(5).Caption = "Kick User"
'.cmdCommand(6).Caption = "Ban User"
'.cmdCommand(7).Caption = "Ban User IP"
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub cmdTop_Click()
SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub
Public Sub cmdTray_Click()
mdiFrmMain.Hide
End Sub
Private Sub Form_Load()
Me.infoIcon.Picture = frmIcon.p005.Picture
cmdClear_Click
frmRoom.Show
frmChat.Show
frmAdvertisement.Show
frmTrivia.Show
RemoveCloseMenuItem (Me.hWnd)
Dim LogDir As String
Dim TriviaDir As String
LogDir = App.Path & "\Logs"
TriviaDir = App.Path & "\Trivia"
If DirExists(LogDir) = False Then
CreateFolder (LogDir)
End If
If DirExists(TriviaDir) = False Then
CreateFolder (TriviaDir)
End If
With Me
.Label1.ForeColor = RGB(0, 93, 145)
.Label2.ForeColor = RGB(0, 93, 145)
.txtSend.ForeColor = RGB(158, 40, 47)
.cmbReason.ForeColor = RGB(158, 40, 47)
.lblRoomStat.ForeColor = RGB(0, 93, 145)
.cmdCommand(0).Enabled = False
.cmdCommand(1).Enabled = False
.cmdCommand(2).Enabled = False
.cmdCommand(3).Enabled = False
.cmdCommand(4).Enabled = False
.cmdCommand(5).Enabled = False
.cmdCommand(6).Enabled = False
.cmdCommand(7).Enabled = False
.cmdCommand(0).Caption = "Punish"
.cmdCommand(1).Caption = "Un-Punish"
.cmdCommand(2).Caption = "Block Mic"
.cmdCommand(3).Caption = "Un-Block Mic"
.cmdCommand(4).Caption = "Warn User"
.cmdCommand(5).Caption = "Kick User"
.cmdCommand(6).Caption = "Ban User"
.cmdCommand(7).Caption = "Ban User IP"
.Show 'form must be fully visible
.Refresh
'.txtSend.SetFocus
End With
With nid 'with system tray
.cbSize = Len(nid)
.hWnd = Me.hWnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon 'use form's icon in tray
.szTip = App.Title & vbNullChar 'tooltip text
End With
Shell_NotifyIcon NIM_ADD, nid 'add to tray
'SendMessage stAtBar.hWnd, PBM_SETBARCOLOR, 0, ByVal RGB(255, 255, 255)
'SendMessage stAtBar.hWnd, PBM_SETBKCOLOR, 0, ByVal RGB(255, 255, 255)
End Sub
Private Sub Form_Resize()
Picture1.Height = lblRoomStat.Height + 40
lblRoomStat.Move 40, 10, Me.Width
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim result, Action As Long
'there are two display modes and we need to find out
'which one the application is using
If Me.ScaleMode = vbPixels Then
Action = X
Else
Action = X / Screen.TwipsPerPixelX
End If
Select Case Action
Case WM_LBUTTONDBLCLK 'Left Button Double Click
Me.WindowState = vbNormal 'put into taskbar
result = SetForegroundWindow(Me.hWnd)
Me.Show 'show form
Case WM_RBUTTONUP 'Right Button Up
result = SetForegroundWindow(Me.hWnd)
'PopupMenu File 'popup menu, cool eh?
End Select
End Sub
Private Sub Form_Unload(Cancel As Integer) 'on form unload
Shell_NotifyIcon NIM_DELETE, nid 'remove from tray
End Sub
Private Sub mnuExit_Click() 'exit
Unload Me: End
End Sub
Private Sub Frame4_DragDrop(Source As Control, X As Single, Y As Single)
End Sub
Private Sub Timer1_Timer()
Dim OurParent As Long
Dim sCaption As String * 256
Dim lCaption As String
'This Finds any window with "video Chat Room" in the title
OurParent = FindWindowWild("*Video Chat Room*", False)
'This statement is used for when camfrog rooms have topic set
'as that would make the wildcard above void
OurParent = FindWindowWild("*Topic:*", False)
GetWindowText OurParent, sCaption, 256
lCaption = Split(sCaption, Chr$(32))(0)
lCaption = Replace$(lCaption, Chr$(44), "")
If qCaption <> lCaption Then
qCaption = lCaption
'MsgBox qCaption
'frmChat.Caption = Replace$(qCaption, ":", "") & " : Chat Room"
'mdiFrmMain.Caption = Replace$(qCaption, ":", "") & " : Operator Tool"
'frmMain.Caption = Replace$(qCaption, ":", "") & " : Main"
'frmAdvertisement.Caption = Replace$(qCaption, ":", "") & " : Advertisement"
End If
If OurParent Then
lblRoomStat.Caption = sCaption
'lblRoomStat.ToolTipText = "You are currently in: " & sCaption
Else
lblRoomStat.Caption = "Not in a Room"
'lblRoomStat.ToolTipText = "You are currently not connected to any rooms"
End If
GetMSG
End Sub
Private Sub txtSend_Change()
Dim sendFT As Boolean
If txtSend.Text <> "" Then
sendFT = True
Else
sendFT = False
End If
With Me
.cmdCommand(0).Enabled = sendFT
.cmdCommand(1).Enabled = sendFT
.cmdCommand(2).Enabled = sendFT
.cmdCommand(3).Enabled = sendFT
.cmdCommand(4).Enabled = sendFT
.cmdCommand(5).Enabled = sendFT
.cmdCommand(6).Enabled = sendFT
.cmdCommand(7).Enabled = sendFT
End With
End Sub
Private Sub WriteToLog(str As String)
Dim LogDir As String, LogFile As String
LogDir = App.Path & "\Logs"
Dim fs As FileSystemObject
Dim ts As TextStream
If DirExists(LogDir) = False Then
CreateFolder (LogDir)
End If
LogFile = App.Path & "\Logs\" & "Log_" & qCaption & Chr$(32) & Format(Now, "d-m-yyyy") & ".txt"
'MsgBox LogFile
If FileExists(LogFile) = False Then
Open LogFile For Output As #1
Write #1, "LogFile " & qCaption & Chr$(32) & Format(Now, "d-m-yyyy")
Write #1, ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
Close #1
End If
Open LogFile For Append As #1
Write #1, str
Close #1
'Set fs = New FileSystemObject
'Set ts = fs.OpenTextFile(LogFile, ForWriting, True)
'ts.WriteLine str
'ts.Close
End Sub
Private Sub TriviaFiles()
Dim TriviaDir As String, TriviaFile As String, ScoresFile As String
TriviaDir = App.Path & "\Trivia"
Dim fs As FileSystemObject
Dim ts As TextStream
If DirExists(TriviaDir) = False Then
CreateFolder (TriviaDir)
End If
TriviaFile = App.Path & "\Trivia\" & "questions.txt"
ScoresFile = App.Path & "\Trivia\" & "scores.ini"
If FileExists(TriviaFile) = False Then
Open TriviaFile For Output As #1
Write #1, "Example Question 1*Answer 1"
Write #1, "Example Question 2*Answer 2"
Write #1, "Example Question 3*Answer 3"
Write #1, "Example Question 4*Answer 4"
Write #1, "Example Question 5*Answer 5"
Close #1
End If
If FileExists(ScoresFile) = False Then
Open ScoresFile For Output As #1
Write #1, "[scores]"
Close #1
End If
End Sub