www.pudn.com > AVPhone.zip > Form1.frm
VERSION 5.00
Object = "{5D94A3BA-EC48-42EA-BADC-FF2338438CC0}#1.1#0"; "AVPhone.ocx"
Begin VB.Form Form1
Caption = "My AVPhone"
ClientHeight = 2580
ClientLeft = 3390
ClientTop = 4590
ClientWidth = 3675
Icon = "Form1.frx":0000
LinkTopic = "Form1"
ScaleHeight = 2580
ScaleWidth = 3675
Begin MyAVPhone.UDPSocket UDPSocket1
Left = 780
Top = 450
_ExtentX = 1138
_ExtentY = 873
End
Begin AVPhone.Audio Audio1
Left = 1590
Top = 1320
_ExtentX = 847
_ExtentY = 847
AVPhone = "Form1.frx":0442
End
Begin AVPhone.VidCap VidCap1
Height = 2160
Left = 60
Top = 120
Width = 2640
_ExtentX = 4657
_ExtentY = 3810
Compressor = "IV50"
Quality = 40
AVPhone = "Form1.frx":046A
End
Begin AVPhone.VidRnd VidRnd1
Height = 2160
Left = 60
Top = 120
Width = 2640
_ExtentX = 4657
_ExtentY = 3810
AVPhone = "Form1.frx":0492
End
Begin VB.Timer Timer1
Interval = 1000
Left = 2940
Top = 1470
End
Begin VB.CommandButton Command2
Caption = "&Call"
Default = -1 'True
Height = 435
Left = 2820
TabIndex = 0
Top = 120
Width = 795
End
Begin VB.CommandButton Command1
Cancel = -1 'True
Caption = "&HangUp"
Height = 435
Left = 2820
TabIndex = 1
Top = 690
Width = 795
End
Begin AVPhone.AVIFile AVIFile1
Left = 780
Top = 1410
_ExtentX = 847
_ExtentY = 847
AVPhone = "Form1.frx":04BA
End
Begin VB.Label Label1
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 255
Left = 60
TabIndex = 2
Top = 2370
Width = 3495
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuFileRecord
Caption = "&Record..."
Shortcut = ^R
End
Begin VB.Menu mnuFilePlay
Caption = "&Play..."
Shortcut = ^P
End
Begin VB.Menu mnuFileBar
Caption = "-"
End
Begin VB.Menu mnuFileConnect
Caption = "Co&nnect"
End
Begin VB.Menu mnuFileBar1
Caption = "-"
End
Begin VB.Menu mnuFileCall
Caption = "&Call..."
Shortcut = ^C
End
Begin VB.Menu mnuFileHangUp
Caption = "&HangUp"
Shortcut = ^H
End
Begin VB.Menu mnuFileBar2
Caption = "-"
End
Begin VB.Menu mnuFileExit
Caption = "E&xit"
End
End
Begin VB.Menu mnuView
Caption = "&View"
Begin VB.Menu mnuViewRemote
Caption = "Remo&te"
Shortcut = ^T
End
Begin VB.Menu mnuViewLocal
Caption = "&Local"
Shortcut = ^L
End
Begin VB.Menu mnuViewBar
Caption = "-"
End
Begin VB.Menu mnuViewChat
Caption = "Ch&at"
Shortcut = ^A
End
Begin VB.Menu mnuViewDraw
Caption = "&White Board"
Shortcut = ^W
End
Begin VB.Menu mnuViewBar1
Caption = "-"
End
Begin VB.Menu mnuViewSize
Caption = "&Size"
Begin VB.Menu mnuViewZoom
Caption = "&Random"
Index = 0
End
Begin VB.Menu mnuViewZoom
Caption = "&100%"
Checked = -1 'True
Index = 1
End
Begin VB.Menu mnuViewZoom
Caption = "&200%"
Index = 2
End
Begin VB.Menu mnuViewZoom
Caption = "&300%"
Index = 3
End
Begin VB.Menu mnuViewZoom
Caption = "&400%"
Index = 4
End
End
Begin VB.Menu mnuViewBar2
Caption = "-"
End
Begin VB.Menu mnuViewTakePicture
Caption = "Ta&ke a Picture"
Shortcut = ^K
End
Begin VB.Menu mnuViewBar3
Caption = "-"
End
Begin VB.Menu mnuViewMonitor
Caption = "&Monitor"
End
End
Begin VB.Menu mnuOptions
Caption = "&Options"
Begin VB.Menu mnuOptionsAudioCompress
Caption = "Audio C&ompress..."
End
Begin VB.Menu mnuOptionsVolume
Caption = "Audio &Volume..."
Shortcut = ^V
End
Begin VB.Menu mnuOptionsBar
Caption = "-"
End
Begin VB.Menu mnuOptionsVideo
Caption = "Video &Performance..."
End
Begin VB.Menu mnuOptionsVideoCompressor
Caption = "Video &Compress..."
End
Begin VB.Menu mnuOptionsVideoFormat
Caption = "Video &Format..."
End
Begin VB.Menu mnuOptionsVideoDisplay
Caption = "Video &Display..."
End
Begin VB.Menu mnuOptionsVideoSource
Caption = "Video &Source..."
Shortcut = ^S
End
Begin VB.Menu mnuOptionsBar1
Caption = "-"
End
Begin VB.Menu mnuOptionsTrace
Caption = "Local &Trace"
End
End
Begin VB.Menu mnuHelp
Caption = "&Help"
Begin VB.Menu mnuHelpCompany
Caption = "&Banasoft..."
End
Begin VB.Menu mnuHelpBar
Caption = "-"
End
Begin VB.Menu mnuHelpCodecs
Caption = "&Video Audio Codecs..."
End
Begin VB.Menu mnuHelpBar1
Caption = "-"
End
Begin VB.Menu mnuHelpRegister
Caption = "&Register..."
End
Begin VB.Menu mnuHelpBar2
Caption = "-"
End
Begin VB.Menu mnuHelpAbout
Caption = "&About..."
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'message handles
Private Const TM_AUDIOFRAME As Long = 1
Private Const TM_VIDEOFRAME As Long = 2
Private Const TM_AUDIOFORMAT As Long = 3
Private Const TM_VIDEOFORMAT As Long = 4
Private Const TM_VIDEORATE As Long = 5
Private Const TM_CHAT As Long = 6
Private Const TM_DRAW As Long = 7
Private Const TM_CALL As Long = 10
Private Const TM_ANSWER As Long = 11
Private Const TM_REJECT As Long = 12
Private Const TM_HANGUP As Long = 13
'main form
'bytes count
Private lCount As Long
'In conference flag
Private blnInConf As Boolean
'play or record flag
Private lFile As Long
Private bfRemote As Variant
Private wfRemote As Variant
Private Declare Function ShellExecuteAPI Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Sub ShellCmd(URL As String)
If ShellExecuteAPI(hwnd, vbNullString, URL, vbNullString, vbNullString, 3) < 32 Then Err.Raise 5, , "ShellExecute Error"
End Sub
Private Sub ShowErr()
MsgBox Err.Description, vbCritical
End Sub
'audio output buffer is empty
Private Sub Audio1_BufferEmpty()
On Error GoTo ErrorHandle
If lFile = 2 Then
'read a block of audio data
Dim bt() As Byte
AVIFile1.ReadAudio bt
'write to output buffer
Audio1.Frame bt
'
lCount = lCount + UBound(bt) + 1
End If
Exit Sub
ErrorHandle:
End Sub
'every audio frame captured, this event fired
'data include the compressed audio data
Private Sub Audio1_Frame(Data As Variant)
On Error Resume Next
lCount = lCount + UBound(Data) + 1
If mnuOptionsTrace.Checked Then Form7.PrintA Time & vbTab & "Audio:" & UBound(Data) + 1
'if need send it to remote
If blnInConf Then UDPSocket1.SendMessage TM_AUDIOFRAME, Data
'if now recording local, write data to file
If lFile = 1 Then AVIFile1.WriteAudio Data
End Sub
Private Sub Command1_Click()
On Error GoTo ErrorHandle
If blnInConf Then
blnInConf = False
Dim bt() As Byte
'tell remote we need stop
With UDPSocket1
bt = .LocalIP
.SendMessage TM_HANGUP, bt
End With
StopRemote
End If
Exit Sub
ErrorHandle:
ShowErr
Resume Next
End Sub
Private Sub MakeCall(Remote As String)
With UDPSocket1
'set the address
.RemoteHost = Remote
'request a link
Dim bt() As Byte
bt = .LocalIP
.SendMessage TM_CALL, bt
End With
End Sub
Private Sub Command2_Click()
On Error GoTo ErrorHandle
With UDPSocket1
Dim s As String
s = Trim$(InputBox("Input host name or IP:", "Call to", .RemoteHost))
If Len(s) > 0 Then
'check if user input local ip
If StrComp(s, .LocalIP, vbTextCompare) = 0 Then
Dim b As Boolean
b = True
ElseIf StrComp(s, .LocalHostName, vbTextCompare) = 0 Then
b = True
End If
If b Then
MsgBox "Can not make a self call.", vbInformation
Else
'make the call
MakeCall s
End If
End If
End With
Exit Sub
ErrorHandle:
ShowErr
End Sub
'load a byte array from reg
Private Function LoadByteArray(Key As String) As Variant
Dim s As String
s = Trim$(GetSetting(App.Title, "Settings", Key, vbNullString))
If Len(s) Then
'Convert string to a byte array
On Error GoTo ErrorHandle
Dim bt() As Byte
Dim l As Long
Do
l = InStr(s, " ")
If l <= 0 Then Exit Do
Dim lc As Long
ReDim Preserve bt(lc)
bt(lc) = Left$(s, l - 1)
s = Mid$(s, l + 1)
lc = lc + 1
Loop
ReDim Preserve bt(lc)
bt(lc) = s
LoadByteArray = bt
End If
ErrorHandle:
End Function
'get last wave format otherwise return -1
Private Function GetWaveFormat() As Variant
GetWaveFormat = LoadByteArray("WaveFormat")
If IsEmpty(GetWaveFormat) Then GetWaveFormat = -1
End Function
'save a byte array to reg
Private Sub SaveByteArray(Key As String, Data As Variant)
'convert byte array to string first
Dim l As Long
For l = 0 To UBound(Data)
Dim s As String
If l <= 0 Then
s = Data(l)
Else
s = s & " " & Data(l)
End If
Next
'save it
SaveSetting App.Title, "Settings", Key, s
End Sub
'save last wave format
Private Sub SaveWaveFormat()
SaveByteArray "WaveFormat", Audio1.WaveFormat
End Sub
'connect audio ok
Private Sub AudioConnected()
With Audio1
SaveWaveFormat
'start the capture
.StartCapture
If blnInConf Then
'if we are in conf, send new audio format to remote
UDPSocket1.SendMessage TM_AUDIOFORMAT, .WaveFormat
End If
End With
End Sub
Private Sub ConnectAudio()
On Error GoTo ErrorHandle
Dim wf As Variant
wf = GetWaveFormat()
'connect to wave capture device
'default ACM is GSM610
Audio1.CapConnect , wf
AudioConnected
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub ConnectVideo(ByVal Driver As Long)
On Error GoTo ErrorHandle
With VidCap1
'you can change compressor to any video compressor you want.
'of cause it must been installed in your system.
Const csICM As String = "iv50"
Dim s As String
s = GetSetting(App.Title, "Settings", "VideoCompressor", csICM)
If Len(s) <> 4 Then s = csICM
.Compressor = s
'connect video capture device
.Connect Driver
SaveSetting App.Title, "Settings", "Driver", Driver
'load the default device format
Dim vt As Variant
vt = LoadByteArray("DeviceFormat")
If Not IsEmpty(vt) Then .DeviceFormat = vt
VideoConnected
End With
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub ConnectProc(ByVal Video As Long, ByVal Audio As Boolean)
mnuFileConnect.Caption = "Disconnec&t"
If Audio Then ConnectAudio
If Video <> -3 Then ConnectVideo Video
End Sub
Private Sub CommandProc(Cmd As String, Callee As String, Video As Long, NoAudio As Boolean)
Do Until Len(Cmd) <= 0
Dim l As Long
l = InStr(Cmd, " ")
Dim s As String
If l > 0 Then
s = Left$(Cmd, l - 1)
Cmd = LTrim$(Mid$(Cmd, l + 1))
Else
s = Cmd
Cmd = vbNullString
End If
s = UCase$(s)
If InStr(s, "/CALL:") = 1 Then
'/CALL:IP call the ip
Callee = Trim$(Mid$(s, 7))
ElseIf s = "/NOVIDEO" Then
'/NOVIDEO need not connect to video
Video = -3
ElseIf s = "/NOAUDIO" Then
'/NOAUDIO need not connect to audio
NoAudio = True
End If
Loop
End Sub
Private Sub Form_Load()
On Error GoTo ErrorHandle
LoadLogo
'init remote formats
wfRemote = Null
bfRemote = Null
Dim cl As String
Dim vd As Long
Dim na As Boolean
'check command line
Dim s As String
s = GetSetting(App.Title, "Settings", "Driver", -1)
If Not IsNumeric(s) Then s = "-1"
vd = s
CommandProc Command$, cl, vd, na
Label1 = vbNullString
Show
Form3.Show vbModeless, Form1
'connect to video or audio
ConnectProc vd, Not na
'if need make the call
If Len(cl) Then MakeCall cl
Exit Sub
ErrorHandle:
ShowErr
Resume Next
End Sub
Private Sub ResizeAll()
Dim lw As Long
lw = ScaleWidth
Dim lh As Long
lh = ScaleHeight - Label1.Height
Label1.Move 0, lh, lw
lw = lw - Command1.Width - 60
Command1.Left = lw
Command2.Left = lw
lw = lw - 60
lh = lh - 60
With VidCap1
.Move 0, 0, lw, lh
End With
With VidRnd1
.Move 0, 0, lw, lh
End With
End Sub
Private Sub Form_Resize()
On Error Resume Next
ResizeAll
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrorHandle
SetMouse vbHourglass
Command1_Click
DoEvents
'close socket
UDPSocket1.Port = 0
'stop video capture
With VidCap1
If Not IsNull(.BitmapFormat) Then .StopCapture
If Not IsNull(.DeviceFormat) Then .Disconnect
End With
'stop video render
VidRnd1.StopDecompress
'stop audio capture and play back
With Audio1
If Not IsNull(.WaveFormat) Then .CapDisconnect
.FeedDisconnect
End With
'unload all forms
ProgramEnd
Exit Sub
ErrorHandle:
ShowErr
Resume Next
End Sub
Private Sub mnuFileConnect_Click()
On Error GoTo ErrorHandle
Static b As Boolean
b = Not b
If b Then
mnuFileConnect.Caption = "Connec&t"
With Audio1
'stop audio capture
.StopCapture
'disconnect audio capture device
.CapDisconnect
'disconnect audio play back device
.FeedDisconnect
End With
With VidCap1
'stop video capture
.StopCapture
'disconnect video capture device
.Disconnect
End With
SaveSetting App.Title, "Settings", "Driver", -3
Else
Dim s As String
s = InputBox("Enter driver index:" & vbCrLf & vbTab & "0 to 9 for video hardware" & vbCrLf & vbTab & "-1 for default" & vbCrLf & "Else for hwnd" & vbCrLf & vbTab & " -2 for screen.", "Connect", -1)
If StrPtr(s) Then
Dim l As Long
l = s
SetMouse vbHourglass
ConnectProc l, True
SetMouse vbDefault
End If
End If
Exit Sub
ErrorHandle:
SetMouse vbDefault
ShowErr
End Sub
Private Sub mnuFileCall_Click()
Command2_Click
End Sub
Private Sub mnuFileHangUp_Click()
Command1_Click
End Sub
Private Sub mnuFileExit_Click()
On Error GoTo ErrorHandle
Unload Me
Exit Sub
ErrorHandle:
ShowErr
End Sub
'stop avi play back
Private Sub StopPlay()
mnuFilePlay.Caption = "&Play..."
lFile = 0
'close file
AVIFile1.CloseFile
'stop video render
VidRnd1.StopDecompress
'stop audio playback
Audio1.FeedDisconnect
If blnInConf Then
'restore conferencing format stored before playback
If Not IsNull(bfRemote) Then
VidRnd1.Rate = Form4.VidRnd1.Rate
VidRnd1.StartDecompress bfRemote
End If
If Not IsNull(wfRemote) Then Audio1.FeedConnect wfRemote
Else
VidCap1.ZOrder
End If
End Sub
Private Sub mnuFilePlay_Click()
On Error GoTo ErrorHandle
If InStr(mnuFilePlay.Caption, "S") Then
StopPlay
ElseIf lFile = 1 Then
MsgBox "Please stop record first.", vbExclamation
Else
Dim s As String
s = GetOpenFile(hwnd, 1)
mnuFilePlay.Caption = "Stop &Play"
'AVIFile
With AVIFile1
'open file
.OpenFile s
lFile = 2
Dim vt As Variant
vt = .WaveFormat
If Not IsNull(vt) Then
'there is valid audio track in the file
With Audio1
'stop audio playback
.FeedDisconnect
'restart it using new wave format
.FeedConnect vt
End With
End If
vt = .BitmapFormat
If Not IsNull(vt) Then
'there is valid video track in the file
With VidRnd1
'stop video render
.ZOrder
.StopDecompress
'set the render speed
.Rate = AVIFile1.Rate
'restart it using new bitmap format
.StartDecompress vt
End With
End If
End With
End If
Exit Sub
ErrorHandle:
If Err <> 32755 Then ShowErr
End Sub
Private Sub mnuFileRecord_Click()
On Error GoTo ErrorHandle
If InStr(mnuFileRecord.Caption, "S") Then
mnuFileRecord.Caption = "&Record..."
lFile = 0
'stop recording
AVIFile1.CloseFile
ElseIf lFile = 2 Then
MsgBox "Please stop play first.", vbExclamation
Else
Dim s As String
s = GetSaveASFile(hwnd, 1)
If Len(Dir$(s)) > 0 Then Kill s
mnuFileRecord.Caption = "Stop &Record"
'start recording
With AVIFile1
'set video speed
.Rate = IIf(blnInConf, VidRnd1.Rate, VidCap1.Rate)
'create AVI file for recording
.CreateFile s, IIf(blnInConf, bfRemote, VidCap1.BitmapFormat), IIf(blnInConf, wfRemote, Audio1.WaveFormat)
End With
lFile = 1
End If
Exit Sub
ErrorHandle:
'canceled
If Err <> 32755 Then ShowErr
End Sub
Private Sub mnuHelpAbout_Click()
On Error GoTo ErrorHandle
MsgBox "My AVPhone sample application version " & App.Major & "." & App.Minor & vbCrLf & vbCrLf & _
"Make visual call over the internet." & vbCrLf & "This is a demo app for Banasoft AVPhone ActiveX Controls." & vbCrLf & vbCrLf & _
"Local IP: " & UDPSocket1.LocalIP & vbCrLf & vbCrLf & _
"www.banasoft.net", vbInformation
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuHelpCodecs_Click()
On Error GoTo ErrorHandle
ShellCmd "http://www.banasoft.net/Links.htm"
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuHelpCompany_Click()
On Error GoTo ErrorHandle
ShellCmd "http://www.banasoft.net"
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuHelpRegister_Click()
On Error GoTo ErrorHandle
SendKeys "%R"
VidCap1.AboutBox
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuOptionsAudioCompress_Click()
On Error GoTo ErrorHandle
With Audio1
'you must stop and disconnect the audio
'capture device first
.StopCapture
.CapDisconnect
'show the dialog
.CompressorDlg
.CapConnect
AudioConnected
Exit Sub
ReConnect:
.CapConnect
.StartCapture
End With
Exit Sub
ErrorHandle:
'error &h80047ff3 if user press "Cancel"
If Err <> &H80047FF3 Then
ShowErr
Else
Resume ReConnect
End If
End Sub
Private Sub mnuOptionsTrace_Click()
On Error GoTo ErrorHandle
mnuOptionsTrace.Checked = Not mnuOptionsTrace.Checked
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuOptionsVideo_Click()
On Error GoTo ErrorHandle
form5.Show vbModal, Me
If blnInConf Then
'if need tell remote our video format changed
Dim s As String
s = VidCap1.Rate
UDPSocket1.SendMessage TM_VIDEORATE, s
End If
Exit Sub
ErrorHandle:
ShowErr
End Sub
'connect video ok
Private Sub VideoConnected()
'restart the video capture
VidCap1.StartCapture
'notify new video format
NewFormat
End Sub
'stop capture if captrue started
'before show any capture dialog, you must stop video capture first
Private Sub StopCaptureVideo()
On Error GoTo ErrorHandle
VidCap1.StopCapture
ErrorHandle:
End Sub
Private Sub mnuOptionsVideoCompressor_Click()
On Error GoTo ErrorHandle
StopCaptureVideo
'show the video compressor dialog
'notice not all compreesor list in the dialog can work correctly
'some of them may need a license message to be sent in DriverOpened
'event
VidCap1.CompressorDlg
VideoConnected
Exit Sub
ReConnect:
VidCap1.StartCapture
Exit Sub
ErrorHandle:
'error &h80047ff3 if user press "Cancel"
If Err <> &H80047FF3 Then
ShowErr
Else
Resume ReConnect
End If
End Sub
Private Sub mnuOptionsVideoDisplay_Click()
On Error GoTo ErrorHandle
'show the video display dialog
VidCap1.DisplayDlg
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub NewFormat()
'save the video device format
SaveByteArray "DeviceFormat", VidCap1.DeviceFormat
Dim vt As Variant
vt = VidCap1.BitmapFormat
'save the video compress format
SaveSetting App.Title, "Settings", "VideoCompressor", VidCap1.Compressor
With Form3.VidRnd1
'restart video render using new format
.StopDecompress
.StartDecompress vt
End With
'tell remote change to new video format
If blnInConf Then UDPSocket1.SendMessage TM_VIDEOFORMAT, vt
End Sub
Private Sub mnuOptionsVideoFormat_Click()
On Error GoTo ErrorHandle
With VidCap1
'stop capture first
.StopCapture
'show the video format dialog
'notice not all format would be support by current compressor
'some format would be time-consuming
.FormatDlg
'restart video capture
.StartCapture
End With
NewFormat
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuOptionsVideoSource_Click()
On Error GoTo ErrorHandle
With VidCap1
.StopCapture
'show the video source dialog
.SourceDlg
.StartCapture
End With
NewFormat
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuOptionsVolume_Click()
On Error GoTo ErrorHandle
'test if audio output started
Dim l As Long
l = Audio1.Volume
'show volume dialog
Form6.Show vbModal, Form1
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuViewDraw_Click()
On Error GoTo ErrorHandle
Form10.Show vbModeless, Me
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuViewLocal_Click()
On Error GoTo ErrorHandle
Form3.Show vbModeless, Form1
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuViewMonitor_Click()
On Error GoTo ErrorHandle
'form7 is a simple debug window
Form7.Show vbModeless, Me
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuViewRemote_Click()
On Error GoTo ErrorHandle
Form4.Show vbModeless, Form1
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuViewChat_Click()
On Error GoTo ErrorHandle
Form8.Show vbModeless, Me
Exit Sub
ErrorHandle:
ShowErr
End Sub
Friend Sub TakePicture()
Dim p As Object
If lFile = 2 Then
Set p = VidRnd1.Picture
ElseIf lFile = 1 Then
Set p = VidCap1.Picture
ElseIf blnInConf Then
Set p = VidRnd1.Picture
Else
Set p = VidCap1.Picture
End If
With Form9
.SetPicture p
.Show vbModeless, Me
End With
End Sub
Private Sub mnuViewTakePicture_Click()
On Error GoTo ErrorHandle
DoEvents
TakePicture
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub mnuViewZoom_Click(Index As Integer)
On Error GoTo ErrorHandle
'you can change ZoomFactor to size current video window
Form3.VidRnd1.ZoomFactor = Index
Form4.VidRnd1.ZoomFactor = Index
VidCap1.ZoomFactor = Index
VidRnd1.ZoomFactor = Index
Dim l As Long
For l = 0 To 4
mnuViewZoom(l).Checked = False
Next
mnuViewZoom(Index).Checked = True
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
'show bps
Static l As Long
l = l + 1
Dim s As Single
s = lCount * 8 / 1000 / l
Label1 = Format(s, "#0.000") & "kbit/s"
If l = 10 Then
lCount = 0
l = 0
End If
End Sub
Private Sub StopRemote()
On Error Resume Next
wfRemote = Null
bfRemote = Null
'stop audio playback
Audio1.FeedDisconnect
'stop video playback
VidRnd1.StopDecompress
VidCap1.ZOrder
Form4.VidRnd1.StopDecompress
End Sub
'receive messages sent by remote
Private Sub UDPSocket1_MessageArrival(ByVal Msg As Byte, Data As Variant)
On Error GoTo ErrorHandle
Select Case Msg
'msg TM_CALL is a call setup signal
Case TM_CALL
'for debug
Dim sm As String
sm = "TM_CALL"
'get remote IP
Dim s As String
s = Data
With UDPSocket1
.RemoteHost = s
Dim bt() As Byte
bt = .LocalIP
If blnInConf Then
'now this sample do not support multi-connection
'if we are in conf we refuse remote
.SendMessage TM_REJECT, bt
'else prompt to accept
ElseIf MsgBox("Accept call from: " & s & "?", vbQuestion + vbYesNo) = vbYes Then
'tell remote we accept it
.SendMessage TM_ANSWER, bt
Dim vt As Variant
vt = VidCap1.BitmapFormat
If Not IsNull(vt) Then
'tell remote we video format
.SendMessage TM_VIDEOFORMAT, vt
'we video rate
s = VidCap1.Rate
.SendMessage TM_VIDEORATE, s
End If
vt = Audio1.WaveFormat
If Not IsNull(vt) Then
'tell remote we audio format
.SendMessage TM_AUDIOFORMAT, vt
End If
blnInConf = True
Else
'refuse remote
.SendMessage TM_REJECT, bt
End If
End With
Case TM_ANSWER
sm = "TM_ANSWER"
'remote accepted us
s = Data
With UDPSocket1
.RemoteHost = s
bt = .LocalIP
If blnInConf Then
'if we alreay in conf refuse remote
.SendMessage TM_REJECT, bt
Else
blnInConf = True
vt = VidCap1.BitmapFormat
If Not IsNull(vt) Then
'tell remote we video format
.SendMessage TM_VIDEOFORMAT, vt
s = VidCap1.Rate
.SendMessage TM_VIDEORATE, s
End If
vt = Audio1.WaveFormat
If Not IsNull(vt) Then
'tell remote we audio format
.SendMessage TM_AUDIOFORMAT, vt
End If
End If
End With
Case TM_REJECT
sm = "TM_REJECT"
'prompt remote refuse us
s = Data
MsgBox "Call refused by " & s, vbInformation
Case TM_HANGUP
sm = "TM_HANGUP"
If blnInConf Then
blnInConf = False
StopRemote
'prompt remote hangup
MsgBox "Remote hangup", vbInformation
End If
Case Else
If blnInConf Then
'these message are invalid only conf activate
Select Case Msg
Case TM_AUDIOFRAME
'new audio frame
sm = "TM_AUDIOFRAME"
If lFile <> 2 Then Audio1.Frame Data
Case TM_VIDEOFRAME
sm = "TM_VIDEOFRAME"
'new video frame
If lFile <> 2 Then VidRnd1.Frame Data
Form4.VidRnd1.Frame Data
Case TM_AUDIOFORMAT
sm = "TM_AUDIOFORMAT"
'new audio format
wfRemote = Data
If lFile <> 2 Then
With Audio1
.FeedDisconnect
.FeedConnect Data
End With
End If
Case TM_VIDEOFORMAT
sm = "TM_VIDEOFORMAT"
'new video format
bfRemote = Data
If lFile <> 2 Then
With VidRnd1
.StopDecompress
.StartDecompress Data
.ZOrder
End With
End If
With Form4.VidRnd1
.StopDecompress
.StartDecompress Data
End With
Case TM_VIDEORATE
sm = "TM_VIDEORATE"
If lFile <> 2 Then
'video rate
s = Data
VidRnd1.Rate = s
End If
Form4.VidRnd1.Rate = s
Case TM_CHAT
sm = "TM_CHAT"
s = Data
If Len(s) > 0 Then
With Form8
.AddMessage "Remote: " & s
.Show vbModeless, Me
End With
End If
Case TM_DRAW
sm = "TM_DRAW"
s = Data
'split to array
Dim l As Long
Dim lo As Long
Dim sa() As String
Dim lc As Long
Do
l = InStr(lo + 1, s, " ")
If l <= 0 Then Exit Do
ReDim Preserve sa(lc)
sa(lc) = Mid$(s, lo + 1, l - lo - 1)
lc = lc + 1
lo = l
Loop
ReDim Preserve sa(lc)
sa(lc) = Mid$(s, lo + 1)
If UBound(sa) = 4 Then
'draw it
With Form10
.AddDraw sa(0), sa(1), sa(2), sa(3), sa(4)
.Show vbModeless, Me
End With
End If
Case Else
sm = "TM_UNKNOW"
End Select
Else
sm = "TM_INVALID"
End If
End Select
Form7.PrintA Time & vbTab & sm & vbTab & UBound(Data) + 1
Exit Sub
ErrorHandle:
Label1 = Err.Description
End Sub
Private Sub VidCap1_Click()
On Error GoTo ErrorHandle
ShowClick
Exit Sub
ErrorHandle:
ShowErr
End Sub
'every video frame captured, this event fired
'data include the compressed video data
Private Sub VidCap1_Frame(Data As Variant)
On Error Resume Next
lCount = lCount + UBound(Data) + 1
Form3.VidRnd1.Frame Data
If mnuOptionsTrace.Checked Then Form7.PrintA Time & vbTab & "Video:" & UBound(Data) + 1
'if need send it
If blnInConf Then UDPSocket1.SendMessage TM_VIDEOFRAME, Data
'if in recording write it to file
If lFile = 1 Then AVIFile1.WriteVideo Data
End Sub
Private Sub VidCap1_ContextMenu()
On Error GoTo ErrorHandle
PopupMenu mnuView
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub VidCap1_Resize()
On Error Resume Next
Move Left, Top, VidCap1.Width + 60 + Command1.Width + 60 + Width - ScaleWidth, VidCap1.Height + 60 + Label1.Height + Height - ScaleHeight
End Sub
Private Sub VidRnd1_BufferEmpty()
On Error GoTo ErrorHandle
If lFile = 2 Then
'video playback output buffer empty
'read a block of video data
Dim bt() As Byte
AVIFile1.ReadVideo bt
'write it to output buffer
VidRnd1.Frame bt
lCount = lCount + UBound(bt) + 1
End If
Exit Sub
ErrorHandle:
End Sub
Private Sub VidRnd1_Click()
On Error GoTo ErrorHandle
ShowClick
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub VidRnd1_ContextMenu()
On Error GoTo ErrorHandle
'right mouse button up
PopupMenu mnuView
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub VidRnd1_Resize()
On Error Resume Next
Move Left, Top, VidRnd1.Width + 60 + Command1.Width + 60 + Width - ScaleWidth, VidRnd1.Height + 60 + Label1.Height + Height - ScaleHeight
End Sub
Private Sub VidCap1_DriverOpened()
On Error GoTo ErrorHandle
Dim s As String
s = UCase$(VidRnd1.Decompressor)
'Select Case UCase$(s)
'Case "YOURCOMPRESSOR"
' VidCap1.SendMessage YOURMESSAGEID, YOURMSGPARAM1, YOURMSGPARAM2
'End Select
Exit Sub
ErrorHandle:
ShowErr
End Sub
Private Sub VidRnd1_DriverOpened()
On Error GoTo ErrorHandle
Dim s As String
s = UCase$(VidRnd1.Decompressor)
'Select Case UCase$(s)
'Case "YOURCOMPRESSOR"
' VidCap1.SendMessage YOURMESSAGEID, YOURMSGPARAM1, YOURMSGPARAM2
'End Select
Exit Sub
ErrorHandle:
ShowErr
End Sub
'send chating message
Friend Sub WriteMessage(Msg As String)
'if we are in conf send it
If blnInConf Then UDPSocket1.SendMessage TM_CHAT, Msg
End Sub
'send drawing message
Friend Sub WriteDraw(ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer, ByVal Color As Long)
'if we are in conf send it
If blnInConf Then UDPSocket1.SendMessage TM_DRAW, X1 & " " & Y1 & " " & X2 & " " & Y2 & " " & Color
End Sub