对聊.frm

一个VB编写的校园即时广播系统,具有简单的定时广播性能

Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function fCreateShellLink Lib "VB5STKIT.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
Const MF_BYPOSITION = &H400&
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Public Locateuser As String, Selectuser As String, SeleFile As String, Rf As String
Public ifhb As Boolean, SoundSend As Boolean, SoundGet As Boolean, ifNM As Boolean
Public Endchr As String, Passwords As String, Comm As String
Public Filelegen As Long
Dim Tempath As String
Dim cc As ChooseColor
Dim rtn As String, lymag As String, love As String
Dim p2p As Boolean, bCancel As Boolean, Ifsound As Boolean, kc As Boolean
Dim RunRun As Integer, NowGroup As Integer, a As Integer
Dim t As NOTIFYICONDATA
Private Type Recode
  GroupInfo As String * 7
  UserInfo As String * 7
End Type


Private Sub AboutMe_Click()
Readme.Show
End Sub

Private Sub AddGroup_Click()
Dim Group As String
Group = InputBox("输入新工作组名", "新工作组")
If Trim(Group) = "" Then Exit Sub
NowGroup = NowGroup + 1
RunRun = RunRun + 1
Load NewCommand(NowGroup)
Load NewAdd(NowGroup)
Load AddtoGroup(NowGroup)
With NewCommand(NowGroup)
    .Caption = Group
    .Left = Command2.Left
    .Top = Command2.Top
    .Width = Command2.Width
    .Visible = True
    .ZOrder 0
End With
With NewAdd(NowGroup)
    .Left = L1.Left
    .Top = L1.Top
    .Height = L1.Height + 300
    .Width = L1.Width
    .ZOrder 0
    .Visible = True
End With
With AddtoGroup(NowGroup)
.Caption = "加入" & Group
.Visible = True
End With
Addto.Visible = True
DelUser.Visible = True
AddtoGroup(0).Visible = False
Command7.ZOrder 0
DelGroup.Visible = True
NewRt_Click
End Sub

Private Sub bd_Click()
t1.SetFocus
End Sub

Private Sub black_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 2 Then Exit Sub
Selectuser = black.List(black.ListIndex)
undo.Caption = "撤消" & Selectuser & "的黑名单"
PopupMenu sysb, vbPopupMenuLeftAlign
End Sub

Private Sub C_LostFocus()
On Error Resume Next
If C.Value <> 0 Then
fCreateShellLink "..\..\Desktop", "校园及时通", SavePath & App.EXEName & ".exe", ""
Else
Dim Buffer As String
Buffer = Space(260)
Buffer = Left(Buffer, GetWindowsDirectory(Buffer, Len(Buffer))) & "\Desktop\" & "校园及时通.lnk"
If Dir(Buffer) <> "" Then Kill Buffer
End If
End Sub

Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DelUser.Visible = False
If Button = vbLeftButton Then
If Command2.Caption = "复原" Then
t1.Enabled = True
BlackVisual False
AllNewVisual False
SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, 3
Me.Width = 4755
With ht
.Top = 0
.Width = 3555
.Height = 1995
End With
L1.Visible = True
Me.Visible = True
t1.SetFocus
Command4.Visible = True
ArrowVisual True
Command2.Caption = "我的同事"
If t1.Height < 780 Then Me.Height = 3255 Else Me.Height = 4800
Command2.Left = 3540
Exit Sub
End If

L1.Visible = True
t1.Enabled = True
t1.SetFocus
If p2p = False Then
If W1.State = 7 Then W1.SendData "onli"
Else
Call tweworld_Click
End If
Dim aa As Integer
If kc = False Then sndPlaySound SavePath & "Change", SND_ASYNC Or SND_NODEFAULT
For aa = Command4.Top To Me.Height - 450 Step 150
L1.Height = aa + 10
DoEvents
If Command4.Top < Me.Height - 900 Then Command4.Top = aa + 15
Next
ArrowVisual True
L1.Height = Me.Height - 725
Command4.Top = Me.Height - 900
kc = False
Else
PopupMenu Group, vbPopupMenuLeftAlign, 4500
End If
End Sub

Private Sub Command4_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ArrowVisual False
t1.Enabled = True
t1.SetFocus
t2.ListIndex = 0
sndPlaySound SavePath & "Change", SND_ASYNC Or SND_NODEFAULT
For a = Command4.Top To 280 Step -140  '改变移动速度
L1.Height = a
Command4.Top = a  '后来加的 为了适合SKIN
DoEvents
Next
L1.Visible = False
L1.Height = 30
Command4.Top = 230
Command4.Left = Command2.Left
End Sub



Private Sub Command7_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
With t1
If .Enabled Then .SetFocus
End With
If NowGroup = 0 Then Exit Sub
RunRun = RunRun + 1
If NowGroup <> 0 Then
If RunRun > NowGroup Then RunRun = 1
Check:
If ExistGroup(RunRun) = False Then
RunRun = RunRun + 1
If RunRun > NowGroup Then Exit Sub
GoTo Check
End If
QQQ (RunRun)
DelUser.Visible = True
End If
Command7.ZOrder 0
ht.ZOrder 0
t1.ZOrder 0
End Sub

Private Sub DelGroup_Click()
On Error GoTo Erroro
For a = 1 To NowGroup
If ExistGroup(a) = True Then
If NewAdd(a).Visible = True Then
Unload NewAdd(a)
Unload NewCommand(a)
Unload AddtoGroup(a)
AllNewVisual False
Call NewRt_Click

Exit For
End If
End If
Next
Exit Sub
Erroro:
If Err.Number = 361 Then
AddtoGroup(a).Caption = "加入"
Addto.Visible = False
End If
Resume Next
End Sub

Private Sub DelUser_Click()
Dim b As Integer
For a = 1 To NowGroup
If ExistGroup(a) = True Then
If NewAdd(a).Visible = True Then Exit For
End If
Next

For b = 1 To NewAdd(a).ListCount
If NewAdd(a).List(b - 1) = Selectuser Then
NewAdd(a).RemoveItem b - 1
Exit For
End If
Next
End Sub

Private Sub ExitNetCall_Click()
 On Error Resume Next
 Dim Numb As Integer
    For Numb = 0 To 4
    t.hwnd = P1(Numb).hwnd
    Shell_NotifyIcon NIM_DELETE, t
Next
End
End Sub

Private Sub Form_DblClick()
Readme.Show
End Sub

Private Sub Form_Load()
On Error Resume Next
RunRun = 0
SoundSend = False
SoundGet = False
Ifsound = True
Tempath = Getwin(True)
Endchr = Chr(13) & Chr(10) & Chr(13) & Chr(10)
love = "lsbxbsbxbsbxbsbxbsbxbsbxbsbxbsbxbs" + Chr(10) + "lsbxbsbxbs    sbxbs    sbxbsbxbsbx" + Chr(10) + "lsbxbsb        xbs        sbxbsbxb" + Chr(10) + "lsbxbs          b          xbsbxbs" + Chr(10) + "lsbxbs                     bxbsbxb" + Chr(10) + "lsbxbsb                   sbxbsbxb" + Chr(10) + "lsbxbsbx    I love you   bsbxbsbxb" + Chr(10) + "lbsbxbsbx               bsbxbsbxbs" + Chr(10) + "plmlmlmlmlm           lmlmlmlmlmlm" + Chr(10) + "plmlmlmlmlmlm       " + "lmlmlmlmlmlmlm" + Chr(10) + "pzlzlzlzlzlzlzlx xzlzlzlzlzlzlzlzl" + Chr(10) + "plblblbslslsllbbfslsllmlmzlzlsbsbs"
C1.Value = getstring(HKEY_LOCAL_MACHINE, "Software\New Sun\Net Call", "AutoRun")
If Len(getstring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\run", "Net Call")) > 3 Then C2.Value = 1 Else C2.Value = 0
Load Login
End Sub

Private Sub clearreco_Click()
Dim SPath As String
SPath = SavePath
If Dir(SPath & "client.msg", vbNormal) <> "" Then Kill SPath & "client.msg"
If Dir(SPath & Locateuser & ".msg", vbNormal) <> "" Then Kill SPath & Locateuser & ".msg"
ht.Text = ""
End Sub

Private Sub Command1_Click()
If Command2.Caption = "复原" Then Exit Sub
If Me.Visible = True Then t1.SetFocus
If Command1.Caption = "连接(&R)" Then Me.Visible = False: Login.Show: Exit Sub
If Len(RTrim(t1.Text)) < 1 Then Exit Sub
Call Sendclick
t1.Text = ""
End Sub

Private Sub Command3_Click()
t1.SetFocus
t1.Text = ""
End Sub

Public Sub Command5_Click()
Call Colorset
If rtn >= 1 Then
Select Case t2.ListIndex
 Case 0
   t2.BackColor = cc.rgbResult
   ht.BackColor = cc.rgbResult
 Case 1
   t2.BackColor = cc.rgbResult
   t1.BackColor = cc.rgbResult
 Case 2
   t2.BackColor = cc.rgbResult
   L1.BackColor = cc.rgbResult
End Select
End If
End Sub

Private Sub Command6_Click()
Call Colorset
If rtn >= 1 Then
Select Case t2.ListIndex
 Case 0
   t2.ForeColor = cc.rgbResult
   ht.SelColor = cc.rgbResult
 Case 1
   t2.ForeColor = cc.rgbResult
   t1.ForeColor = cc.rgbResult
 Case 2
   t2.ForeColor = cc.rgbResult
   L1.ForeColor = cc.rgbResult
End Select
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
If Dir(Comm, vbNormal) <> "" Then Kill Comm
SaveGroup
bCancel = True
Call UnregisterHotKey(Me.hwnd, &HBFFF&)
Reset
Unload Form2
Unload Getf
Unload Login
Unload Readme
Unload Wave
Unload wb
If Len(ht.Text) > 1 Then ht.SaveFile SavePath & "client.msg", rtfRTF
If Not C2.Value = 0 Then
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\run", "Net Call", SavePath & App.EXEName & ".exe")
Else
Call DeleteValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\run", "Net Call")
End If
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call", "AutoRun", CStr(C1.Value))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call", "TalkRecoBackColor", CStr(ht.BackColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call", "SendMagsageBackColor", CStr(t1.BackColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call", "SendMagsageForeColor", CStr(t1.ForeColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call", "OnlinenameBackColor", CStr(L1.BackColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call", "OnlinenameForeColor", CStr(L1.ForeColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call", "AutoFrisk", CStr(add1.Text))
  t.cbSize = Len(t)
    t.uId = 1&
    Dim Numb As Integer
    For Numb = 0 To 4
    t.hwnd = P1(Numb).hwnd
    Shell_NotifyIcon NIM_DELETE, t
Next
End Sub

Private Sub Resize()
BlackVisual False
C1.Left = Me.Width - C1.Width - 180
C2.Left = C1.Left
IECk.Left = C1.Left
C.Left = C1.Left
Command2.Left = Me.Width - Command2.Width - 40
Command4.Left = Command2.Left
Command4.Top = Me.Height - 900
Command5.Left = Me.Width - Command5.Width - 40
Command6.Left = Command5.Left
t2.Left = Command6.Left
L1.Left = Me.Width - L1.Width - 40
L1.Height = Me.Height - 725
L1.Visible = True
l2.Left = Me.Width - l2.Width - 60
add1.Left = Me.Width - add1.Width - 40
ht.Width = Me.Width - Command2.Width + 20
ht.Height = 1995 * Me.Height / 3285
Command7.Left = Me.Width - Command7.Width - 200
Command7.Top = L1.Height / 2
Command1.Top = ht.Height - 70
Command3.Top = Command1.Top
Command3.Left = L1.Left - Command3.Width + 20
t1.Width = ht.Width
t1.Top = Command3.Top + 300
t1.Height = Me.Height - Command3.Top - Command3.Height - 550
For a = 1 To RunRun
NewCommand(RunRun).Left = Command2.Left
NewAdd(RunRun).Height = L1.Height
NewAdd(RunRun).Left = L1.Left
NewRt.Top = Command4.Top
NewRt.Left = Command4.Left
Next
If Me.Height - ht.Height - Command1.Height - 250 < 10 Then Exit Sub Else t1.Height = Me.Height - Command3.Top - Command3.Height - 550
End Sub

Private Sub Form_Resize()
If Me.Width < 4740 Or Me.Height < 3285 And Not Command2.Caption = "复原" Then
Me.Width = 4740
Me.Height = 3285
Resize
Exit Sub
End If
If Command2.Caption = "复原" Then
If Me.Height < 750 Or Me.Height > 800 Then Me.Height = 800: Me.Width = Screen.Width: Exit Sub
AllNewVisual False
Exit Sub
End If
Resize
End Sub

Private Sub goblack_Click()
BlackVisual True
End Sub

Private Sub goout_Click()
Dim b As Integer
Dim Exist As Boolean
bd.Left = Command4.Left
With rt
.Top = Command4.Top
.Left = Command4.Left
End With
black.Left = L1.Left
Exist = False
For b = 0 To black.ListCount
If black.List(b) = Selectuser Then Exist = True
If black.ListCount = 0 Then Exit For
Next

For a = 0 To L1.ListCount - 1
If L1.List(a) = Selectuser Then
L1.RemoveItem a
If Exist = True Then Exit Sub
black.AddItem Selectuser
Exit For
End If
Next
BlackVisual True
End Sub

Private Sub ht_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then PopupMenu l, vbPopupMenuLeftAlign
End Sub

Private Sub IECk_LostFocus()
If IECk.Value <> 0 Then
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\Extensions\{11111111-f40a-11d1-b792-444553540001}", "clsid", "{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}")
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\Extensions\{11111111-f40a-11d1-b792-444553540001}", "default visible", "yes")
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\Extensions\{11111111-f40a-11d1-b792-444553540001}", "hoticon", SavePath & App.EXEName & ".exe,1")
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\Extensions\{11111111-f40a-11d1-b792-444553540001}", "icon", SavePath & App.EXEName & ".exe,1")
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\Extensions\{11111111-f40a-11d1-b792-444553540001}", "exec", SavePath & App.EXEName & ".exe")
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\Extensions\{11111111-f40a-11d1-b792-444553540001}", "buttontext", "NetCall")
Else