'Für Sound
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'Für OnTop?
Private Declare Function GetActiveWindow Lib "user32" () As Long
'Für Titelleisten Blink
Private Declare Function FlashWindow Lib "user32.dll" (ByVal hwnd As Long, _
bInvert As Long) As Long
Dim counter As Integer
Dim myname As String
Dim namelist As String
Dim fserver As Boolean
Dim cname(100) As String
Dim PlayThis As Integer
Dim signal2timer2 As Integer
Private Sub client_Click()
Form2.Visible = True
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub programminfo_Click()
frmAbout.Show
End Sub
Private Sub cmdMinimieren_Click()
Me.WindowState = vbMinimized
End Sub
Private Sub exit_Click()
If fserver = True Then
serversend ("m-------------------------------------------Server disconnected!-------------------------------------------")
End If
Unload Form1
Unload Form2
Unload Form3
End Sub
Private Sub features_Click()
Form4.Show
End Sub
Private Sub Form_Unload(Cancel As Integer)
If fserver = True Then
serversend ("mS-------------------------------------------Server disconnected!-------------------------------------------")
End If
DoEvents
Unload Form1
Unload Form2
Unload Form3
End Sub
Private Sub hostname_Click()
Form3.Visible = True
DoEvents
If fserver = True Then
refreshlist
End If
End Sub
'-------------------------------Was geht wenn nachricht kommt?----------------------
Public Function FensterImVordergrund(ByVal hwnd As Long) As Boolean
If GetActiveWindow() = hwnd Then
FensterImVordergrund = True
Else
FensterImVordergrund = False
End If
End Function
Private Sub sounds_Click()
Form5.Show
End Sub
Private Sub tmrBlink_Timer()
'Wenn Window minimiert, dann Titelleiste und Taskbar blinken lassen
If PlayThis = True Then
FlashWindow Me.hwnd, 1
Else
FlashWindow Me.hwnd, 0
End If
End Sub
Private Sub Timer2_Timer()
'Wenn Fenster im Hintergrund dann abspielen möglich + blinken
If FensterImVordergrund(Me.hwnd) = False Then
PlayThis = True
If signal2timer2 = True Then
tmrBlink.Enabled = True
End If
'Wenn Fenster im Vordergrund dann abspielen NICHT möglich + KEIN blinken
Else
PlayThis = False
signal2timer2 = False
tmrBlink.Enabled = False
End If
End Sub
Private Sub RichTextBox1_Change()
'Wenn Window minimiert, dann Sound abspielen
If PlayThis = True Then
'Nur Sound spielen, wenn in Form5 das entsprechende Häkchen gesetzt ist
If Form5.checkMsgHinweis.Value = 1 Then
sound (Int((Rnd * 3) + 1))
End If
signal2timer2 = True
End If
End Sub
Private Function sound(Zahl As Byte) As String
'Rnd Funktion für die Soundausgabe wenn nicht im Vordergrund
Select Case Zahl
Case 1
Call sndPlaySound("sound/54a.wav", 1)
Case 2
Call sndPlaySound("sound/54b.wav", 1)
Case 3
Call sndPlaySound("sound/54c.wav", 1)
End Select
End Function
'-------------------------------Was geht wenn nachricht kommt?----------------------
Private Sub sclient_Close()
server.Enabled = True
client.Enabled = True
disconnect.Enabled = False
sclient.Close
Text1.Enabled = False
List1.Clear
End Sub
Private Sub sclient_Connect()
disconnect.Enabled = True
server.Enabled = False
client.Enabled = False
Text1.Enabled = True
Form1.Caption = myname
fserver = False
RichTextBox1.Text = ""
Form1.sclient.SendData "n" & myname
Timer1.Enabled = False
Form2.ComboIP.AddItem Form2.ComboIP.Text
Open App.Path & "/ip" For Output As #1
If Form2.ComboIP.ListCount = 1 Then
Write #1, Form2.ComboIP.Text
Else
For i = 1 To Form2.ComboIP.ListCount - 1
If Form2.ComboIP.Text = Form2.ComboIP.List(i) Then
Form2.ComboIP.Text = ""
End If
Write #1, Form2.ComboIP.List(i)
Next
If Form2.ComboIP.Text <> "" Then
Write #1, Form2.ComboIP.Text
End If
End If
Close #1
End Sub
Private Sub sclient_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Fehler in der Verbindung:" + vbCrLf + vbCrLf + Description + vbCrLf + vbCrLf + " --> Server aktiv", vbExclamation, "Verbindungsfehler"
End Sub
Private Sub sserver_Close(Index As Integer)
sserver(Index).Close
sserver(Index).Tag = 0
cname(Index) = ""
End Sub
Private Sub sserver_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Fehler in der Verbindung:" + vbCrLf + vbCrLf + Description + vbCrLf + vbCrLf + " --> Server aktiv", vbExclamation, "Verbindungsfehler"
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
If fserver = False Then
sclient.SendData "m" & myname & " : " & Text1.Text
Else
'Namen mit Text senden
serversend ("m" & myname & " : " & Text1.Text)
'Eigene Nachricht adden + Rest dranhängen
'***** Nickname fett drucken
RichTextBox1.SelBold = True
RichTextBox1.SelText = myname
RichTextBox1.SelBold = False
RichTextBox1.SelText = " : " & Text1.Text & vbCrLf
RichTextBox1.SelLength = 0
RichTextBox1.SelStart = Len(RichTextBox1.Text)
'***** Nickname fett drucken
End If
Text1.Text = ""
KeyAscii = 0 'Unterdrückt das Beep beim Enterdrücken
End If
End Sub
Private Sub disconnect_Click()
If fserver = True Then
Dim a As Integer
serversend ("mServer disconnected")
For a = 0 To counter Step 1
'If sserver(a).State = sckConnected Then
sserver(a).Close
'End If
Next a
End If
server.Enabled = True
client.Enabled = True
disconnect.Enabled = False
sclient.Close
Text1.Enabled = False
counter = 0
Timer1.Enabled = False
List1.Clear
RichTextBox1.Text = "-------------------------------------------Server disconnected!-------------------------------------------"
End Sub
Private Sub Form_Load()
disconnect.Enabled = False
myname = sclient.LocalHostName
counter = 0
txtIP.Text = sserver(0).LocalIP
Timer1.Enabled = False
lblInfo.Caption = "LANChat Version " & App.Major & "." & App.Minor & "." & App.Revision _
& vbCrLf & "powered by screen-style.de"
PlayThis = False
signal2timer2 = False
End Sub
Private Sub sclient_DataArrival(ByVal bytesTotal As Long)
Dim revmessage As String
sclient.GetData revmessage
If Left(revmessage, 1) = "m" Then
'***** Nickname fett drucken
revmessage = Mid(revmessage, 2)
If InStr(1, revmessage, " : ") > 0 Then
RichTextBox1.SelBold = True
RichTextBox1.SelText = Mid$(revmessage, 1, InStr(1, revmessage, " : ") - 1)
RichTextBox1.SelBold = False
RichTextBox1.SelText = Mid$(revmessage, InStr(1, revmessage, " : ") + 1, Len(revmessage)) & vbCrLf
End If
'***** Nickname fett drucken
End If
If Left(revmessage, 1) = "n" Then
revmessage = Mid(revmessage, 2)
List1.Clear
Dim pstart, pend, a As String
Dim ffinish As Boolean
pstart = 1
a = 0
ffinish = False
While ffinish = False
pend = InStr(pstart, revmessage, " ", 1)
cname(a) = Trim(Mid(revmessage, pstart, pend))
pstart = pend + 1
List1.AddItem (cname(a))
a = a + 1
If pend >= Len(revmessage) Then
ffinish = True
End If
Wend
End If
'Auch beim Empfangen und senden desClienten den Text mitscrollen!
RichTextBox1.SelLength = 0
RichTextBox1.SelStart = Len(RichTextBox1.Text)
End Sub
Private Sub server_Click()
cname(0) = myname
sserver(0).LocalPort = 789
sserver(0).Listen
server.Enabled = False
client.Enabled = False
disconnect.Enabled = True
Form1.Caption = sserver(0).LocalIP
Text1.Enabled = True
fserver = True
'RichTextBox1.Text = "Server online!"
Timer1.Interval = 5000
Timer1.Enabled = True
refreshlist
End Sub
Private Sub sserver_ConnectionRequest(Index As Integer, ByVal requestID As Long)
If Index = 0 Then
counter = counter + 1
Load sserver(counter)
sserver(counter).LocalPort = 0
sserver(counter).Accept requestID
sserver(counter).SendData "mWillkommen im chat"
sserver(counter).Tag = 1
End If
End Sub
Private Sub sserver_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim revmessage As String
sserver(Index).GetData revmessage
If Left(revmessage, 1) = "m" Then
revmessage = Mid(revmessage, 2)
'***** neu
RichTextBox1.SelBold = True
RichTextBox1.SelText = Mid$(revmessage, 1, InStr(1, revmessage, " : ") - 1)
RichTextBox1.SelBold = False
RichTextBox1.SelText = Mid$(revmessage, InStr(1, revmessage, " : ") + 1, Len(revmessage)) & vbCrLf
'***** neu
serversend ("m" & revmessage)
End If
If Left(revmessage, 1) = "n" Then
cname(Index) = Mid(revmessage, 2)
End If
RichTextBox1.SelLength = 0
RichTextBox1.SelStart = Len(RichTextBox1.Text)
End Sub
Public Sub changename(a As String)
myname = a
If fserver = False Then
Form1.Caption = myname
If disconnect.Enabled = True Then
sclient.SendData "n" & myname
End If
Else
cname(0) = a
refreshlist
End If
End Sub
Public Sub serversend(message As String)
Dim a As Integer
For a = 0 To counter Step 1
If sserver(a).Tag = "1" Then
sserver(a).SendData message
End If
Next a
End Sub
Public Sub refreshlist()
List1.Clear
namelist = ""
Dim a As Integer
For a = 0 To counter
If cname(a) <> "" Then
namelist = namelist & cname(a) & " "
List1.AddItem (cname(a))
End If
Next a
serversend ("n" & namelist)
End Sub
Private Sub Timer1_Timer()
If fserver = True Then
refreshlist
Else
MsgBox ("Konnte keinen Server finden!")
Timer1.Enabled = False
sclient.Close
End If
End Sub
