while.frm

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

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form wb 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00000000&
   BorderStyle     =   5  'Sizable ToolWindow
   Caption         =   "二人画板"
   ClientHeight    =   3990
   ClientLeft      =   -15
   ClientTop       =   255
   ClientWidth     =   5550
   DrawStyle       =   2  'Dot
   DrawWidth       =   2
   FillColor       =   &H00FFC0C0&
   ForeColor       =   &H00C0C0FF&
   LinkTopic       =   "画板"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MousePointer    =   2  'Cross
   ScaleHeight     =   3990
   ScaleWidth      =   5550
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer Timer1 
      Interval        =   1
      Left            =   2010
      Top             =   720
   End
   Begin MSWinsockLib.Winsock hb 
      Left            =   1020
      Top             =   570
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   327681
   End
   Begin VB.Menu q 
      Caption         =   "menu1"
      Visible         =   0   'False
      Begin VB.Menu setbackcolor 
         Caption         =   "设置背景"
      End
      Begin VB.Menu setpen 
         Caption         =   "设置笔色"
      End
      Begin VB.Menu max 
         Caption         =   "最大化"
      End
      Begin VB.Menu re 
         Caption         =   "还原"
      End
      Begin VB.Menu ww 
         Caption         =   "-"
      End
      Begin VB.Menu clear 
         Caption         =   "橡皮擦"
      End
   End
End
Attribute VB_Name = "wb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim Nowxy As POINTAPI
Dim buff As String
Dim smag As String
Dim cc As ChooseColor
Dim rtn As String

Private Sub clear_Click()
Call Form_DblClick
End Sub

Private Sub Form_DblClick()
If hb.State = sckConnected Then hb.SendData "C": Cls
End Sub

Private Sub Form_Load()
Form1.Sf(0).Close
Form1.Sf(0).LocalPort = 0
Form1.Sf(0).RemotePort = 0
Me.BackColor = 0
Form1.Chang 3, "二人画板"
 End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then PopupMenu q: Exit Sub
GetCursorPos Nowxy
ScreenToClient hwnd, Nowxy
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
buff = ""
If Button <> 1 Then Exit Sub
buff = buff & "*" & X & "." & Y & "-" & Nowxy.X * 15 & "." & Nowxy.Y * 15
If hb.State = 7 Then hb.SendData buff: Line (X, Y)-(Nowxy.X * 15, Nowxy.Y * 15) Else Me.Caption = "网络错误,不能发送"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
AnimateWindow Me.hwnd, 200, &H4 Or &H11 Or &H10000
With Form1.Sf(0)
.Close
.LocalPort = 0
.RemotePort = 0
End With
Form1.ifhb = False
With Me
.Left = -16000
.Visible = True
End With
Form1.Chang 0, "校园及时通-" & Form1.Locateuser
End Sub

Private Sub hb_Close()
Unload Me
MsgBox "对方已关闭画板", vbQuestion + vbSystemModal
End Sub

Private Sub hb_Connect()
Me.Show
End Sub

Private Sub hb_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim Buffl  As String
Dim f, fe, s, se As Integer
hb.GetData Buffl
'"B" & CStr(cc.rgbResult) & "/"
f = InStr(1, Buffl, "B")
s = InStr(1, Buffl, "F")
If InStr(1, Buffl, "C") Then Cls
If f <> 0 Then
fe = InStr(f, Buffl, "/")
Me.BackColor = Mid(Buffl, f + 1, fe - f - 1)
End If
'"F" & CStr(cc.rgbResult) & "/"
If s <> 0 Then
se = InStr(s, Buffl, "/")
Me.ForeColor = Mid(Buffl, s + 1, se - s - 1)
End If
Call Pros(Buffl)
End Sub

Private Sub hb_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 Description, vbOKOnly + vbSystemModal + vbCritical, "错误"
End Sub

Private Sub max_Click()
Me.WindowState = 2
End Sub

Private Sub re_Click()
Me.WindowState = 0
End Sub

Private Sub setbackcolor_Click()
If hb.State = 7 Then
Call Colorset
If rtn >= 1 Then
Me.BackColor = cc.rgbResult
hb.SendData "B" & CStr(cc.rgbResult) & "/"
End If
End If
End Sub

Private Sub setpen_Click()
If hb.State = 7 Then
Call Colorset
If rtn >= 1 Then
Me.ForeColor = cc.rgbResult
hb.SendData "F" & CStr(cc.rgbResult) & "/"
End If
End If
End Sub

Private Sub Timer1_Timer()
GetCursorPos Nowxy
ScreenToClient hwnd, Nowxy
End Sub

Private Sub Pros(buff As String)
'"*" & Oldxy.X & "." & Oldxy.Y & "-" & Nowxy.X & "." & Nowxy.Y
On Error Resume Next
Dim x1, x2, y1, y2, beg, f, s, t, ff As Integer
ff = 1
Rest:
beg = InStr(ff, buff, "*")
f = InStr(beg, buff, ".")
s = InStr(f, buff, "-")
t = InStr(s, buff, ".")
ff = InStr(t, buff, "*")   '重新开始寻找
If beg = 0 Or f = 0 Or s = 0 Or t = 0 Or ff = 0 Then Exit Sub
x1 = Mid(buff, beg + 1, f - beg - 1)
y1 = Mid(buff, f + 1, s - f - 1)
x2 = Mid(buff, s + 1, t - s - 1)
y2 = Mid(buff, t + 1, ff - t - 1)
Line (x1, y1)-(x2, y2)
beg = ff
DoEvents
GoTo Rest
End Sub

Private Sub Colorset()
With cc
.lStructSize = Len(cc)
.hwndOwner = Me.hwnd
.hInstance = App.hInstance
.flags = 0
.lpCustColors = String$(16 * 4, 0)
End With
rtn = ChooseColor(cc)
End Sub