实例介绍
【实例简介】VB网络视频聊天
【实例截图】
【核心代码】
VERSION 5.00
Object = "{34754227-0620-43ED-B218-C60387EA5BB9}#6.0#0"; "AVPhone3.ocx"
Begin VB.Form Form1
Caption = "可视电话"
ClientHeight = 3192
ClientLeft = 2676
ClientTop = 2076
ClientWidth = 2280
Icon = "视频Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 3192
ScaleWidth = 2280
Begin VB.Frame Frame4
BorderStyle = 0 'None
Caption = "Frame4"
Height = 780
Left = 240
TabIndex = 15
Top = 2520
Width = 1620
Begin VB.CommandButton Command1
Caption = "&拨号"
Height = 444
Left = 0
Picture = "视频Form1.frx":030A
Style = 1 'Graphical
TabIndex = 17
Top = 120
Width = 552
End
Begin VB.CommandButton Command2
Caption = "&挂机"
Height = 444
Left = 840
Picture = "视频Form1.frx":0434
Style = 1 'Graphical
TabIndex = 16
Top = 120
Width = 552
End
End
Begin VB.Frame Frame1
BorderStyle = 0 'None
Height = 1905
Left = 0
TabIndex = 1
Top = 480
Width = 2352
Begin VB.PictureBox Picture1
Height = 1776
Left = 0
ScaleHeight = 1728
ScaleWidth = 2124
TabIndex = 2
Top = 0
Width = 2172
Begin AVPhone3.VidRnd VidRnd2
Height = 624
Left = 1296
Top = 1080
Width = 768
_ExtentX = 1355
_ExtentY = 1101
Control = "视频Form1.frx":055E
End
Begin AVPhone3.VidRnd VidRnd1
Height = 1812
Left = 0
Top = 0
Width = 2136
_ExtentX = 3747
_ExtentY = 3196
Control = "视频Form1.frx":0582
End
Begin VB.CommandButton cmdNumbers
Caption = "1"
Height = 336
Index = 0
Left = 288
TabIndex = 14
Top = 72
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "2"
Height = 336
Index = 1
Left = 828
TabIndex = 13
Top = 72
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "3"
Height = 336
Index = 2
Left = 1368
TabIndex = 12
Top = 72
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "4"
Height = 336
Index = 3
Left = 288
TabIndex = 11
Top = 468
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "5"
Height = 336
Index = 4
Left = 828
TabIndex = 10
Top = 468
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "6"
Height = 336
Index = 5
Left = 1368
TabIndex = 9
Top = 468
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "7"
Height = 336
Index = 6
Left = 288
TabIndex = 8
Top = 900
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "8"
Height = 336
Index = 7
Left = 828
TabIndex = 7
Top = 900
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "9"
Height = 336
Index = 8
Left = 1368
TabIndex = 6
Top = 900
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "*"
Height = 336
Index = 10
Left = 288
TabIndex = 5
Top = 1332
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "0"
Height = 336
Index = 9
Left = 828
TabIndex = 4
Top = 1332
Width = 444
End
Begin VB.CommandButton cmdNumbers
Caption = "#"
Height = 336
Index = 11
Left = 1368
TabIndex = 3
Top = 1332
Width = 444
End
End
Begin AVPhone3.AudCodec AudCodec1
Left = 1944
Top = 1188
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":05A6
End
End
Begin VB.Timer Timer1
Left = 3000
Top = 2160
End
Begin AVPhone3.AudCodec AudCodec2
Left = 2880
Top = 4080
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":05CA
End
Begin AVPhone3.VidCodec VidCodec2
Left = 2376
Top = 4068
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":05EE
End
Begin AVPhone3.UDPSocket UDPSocket1
Left = 2880
Top = 2520
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":0612
End
Begin AVPhone3.VidCodec VidCodec1
Left = 2160
Top = 1728
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":0636
End
Begin AVPhone3.AudRnd AudRnd1
Left = 3000
Top = 3360
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":065A
End
Begin AVPhone3.AudCap AudCap1
Left = 2580
Top = 3000
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":067E
End
Begin AVPhone3.VidCap VidCap1
Left = 2520
Top = 3672
_ExtentX = 677
_ExtentY = 677
Control = "视频Form1.frx":06A2
End
Begin VB.ComboBox Combo1
Height = 276
Left = 72
TabIndex = 0
Text = "Combo1"
Top = 72
Width = 2172
End
Begin VB.Menu mnuCall
Caption = "&Call"
Begin VB.Menu mnuCallNewCall
Caption = "New Call..."
Shortcut = ^N
End
Begin VB.Menu mnuCallHangUp
Caption = "Hang Up"
End
Begin VB.Menu mnuCallExit
Caption = "E&xit"
End
End
Begin VB.Menu mnuView
Caption = "&View"
Begin VB.Menu mnuViewPictureinPicture
Caption = "&Picture-in-Picture"
End
Begin VB.Menu mnuViewMyVideo
Caption = "&My Video(New Window)"
End
End
Begin VB.Menu mnuTools
Caption = "&Tools"
Begin VB.Menu mnuToolsVideo
Caption = "Video"
Begin VB.Menu mnuToolsVideoSend
Caption = "&Send"
End
Begin VB.Menu mnuToolsVideoReceive
Caption = "&Receive"
End
Begin VB.Menu mnuToolsVideoBar1
Caption = "-"
End
Begin VB.Menu mnuToolsVideoWindowSize
Caption = "&Window Size"
Begin VB.Menu mnuToolsVideoWindowZooms
Caption = "&100%"
Index = 0
End
Begin VB.Menu mnuToolsVideoWindowZooms
Caption = "&200%"
Index = 1
End
Begin VB.Menu mnuToolsVideoWindowZooms
Caption = "&300%"
Index = 2
End
Begin VB.Menu mnuToolsVideoWindowZooms
Caption = "&400%"
Index = 3
End
End
End
Begin VB.Menu mnuToolsAudioTuneWizard
Caption = "&Audio Tuning Wizard..."
End
Begin VB.Menu mnuToolsBar1
Caption = "-"
End
Begin VB.Menu mnuToolsOptions
Caption = "&Options..."
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
Private blnInConf As Boolean
'timeout count
Private lCount As Long
'timeout state
Private lState As Long
'send message to default remote side
Friend Sub SendMessage(ByVal Address As Long, ByVal Port As Integer, ByVal Handle As Long, Optional ByVal Para As Long, Optional Data As Variant)
UDPSocket1.Frame Address, Port, Handle, Para, Data
End Sub
'make new call
Private Sub NewCall()
Dim s As String
s = InputBox("Host name or IP and port (Host:Port):", "Call to")
'add to list
Combo1 = s
'call it
CallTo s
End Sub
Private Sub AudCap1_Frame(Data As Variant)
On Error GoTo ErrorHandle
'if we are in conf write data to audcodec1
'for compression
If blnInConf Then AudCodec1.Frame Data
ErrorHandle:
End Sub
Friend Property Get AudioSendVolume() As Long
AudioSendVolume = HScroll1
End Property
Friend Property Get AudioReceVolume() As Long
AudioReceVolume = HScroll2
End Property
Private Sub AudCodec1_Frame(Data As Variant)
On Error GoTo ErrorHandle
'data compressed, send it to remote
UDPSocket1.Frame -1, -1, TM_AUDIOFRAME, , Data
ErrorHandle:
End Sub
Private Property Get AudioCodec() As String
AudioCodec = AudCodec1.OutFormat
End Property
Private Property Let AudioCodec(Format As String)
'stop previous compression
AudCodec1.OutFormat = vbNullString
'restart
AudCodec1.OutFormat = Format
'if we are in conf tell the audio format to remote.
If blnInConf Then UDPSocket1.Frame -1, -1, TM_AUDIOFORMAT, , AudCodec1.OutFormat
End Property
Friend Property Let AudioSend(ByVal Send As Boolean)
If Send Then
'connect to device
AudCap1.Device = InitGetCurrentAudioDevice()
AudioCodec = AudioCodec
Else
'disconnect
AudCap1.Device = -2
'if we are in conf tell remote we need stop audio
If blnInConf Then UDPSocket1.Frame -1, -1, TM_AUDIOFORMAT
End If
End Property
Private Sub Check1_Click()
On Error GoTo ErrorHandle
AudioSend = Check1 = vbChecked
Exit Sub
ErrorHandle:
Unload Me
End Sub
Friend Property Let AudioRece(ByVal Rece As Boolean)
'if we are in conf tell remote we need start / stop audio
If blnInConf Then UDPSocket1.Frame -1, -1, IIf(Rece, TM_AUDIOSTART, TM_AUDIOSTOP)
End Property
Friend Property Get AudioRece() As Boolean
AudioRece = Check2 = vbChecked
End Property
Private Sub Check2_Click()
On Error GoTo ErrorHandle
AudioRece = Check2 = vbChecked
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub cmdNumbers_Click(Index As Integer)
On Error GoTo ErrorHandle
Select Case Index
Case 0 To 8
Dim s As String
s = Index 1
Case 9
s = "0"
Case 10
s = "*"
Case 11
s = "#"
End Select
Combo1 = Combo1 & s
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Combo1_KeyPress(KeyAscii As Integer)
On Error GoTo ErrorHandle
If KeyAscii = vbKeyReturn Then CallTo Combo1
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Command1_Click()
On Error GoTo ErrorHandle
Dim s As String
s = Trim$(Combo1)
If Len(s) <= 0 Then
NewCall
Else
CallTo s
End If
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Command2_Click()
On Error GoTo ErrorHandle
mnuCallHangUp_Click
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Command3_Click()
On Error GoTo ErrorHandle
mnuCallDirectory_Click
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Command4_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Command5_Click()
On Error GoTo ErrorHandle
Form6.Show vbModeless, Me
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Command6_Click()
On Error GoTo ErrorHandle
Form5.Show vbModeless, Me
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Command7_Click()
On Error GoTo ErrorHandle
mnuToolsFileTransfer_Click
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub LoadLogo()
Dim p As IPictureDisp
Set p = GetLogo()
If p Is Nothing Then Exit Sub
Set VidRnd1.Picture = p
Set VidRnd2.Picture = p
Set Form3.VidRnd1.Picture = p
End Sub
Private Sub Form_Load()
On Error Resume Next
Combo1 = vbNullString
VidRnd2.Visible = False
'local rendering needn't buffer
VidRnd2.Rate = -VidCap1.Rate
VidRnd2.Zoom = VidRnd1.Zoom / 2
Load Form3
Form3.VidRnd1.Rate = -VidCap1.Rate
Load Form4
LoadLogo
UDPSocket1.Bind
Timer1.Interval = 1000
SizeControls
GetAppSettings
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error GoTo ErrorHandle
If blnInConf Then HangupCall
Unload Form4
Form3.VidRnd1.Format = vbNullString
Unload Form3
SaveApp
'stopping all controls
VidCap1.Device = -2
AudCap1.Device = -2
VidRnd1.Format = vbNullString
VidRnd2.Format = vbNullString
AudRnd1.Format = vbNullString
VidCodec1.OutFormat = vbNullString
VidCodec2.OutFormat = vbNullString
AudCodec1.OutFormat = vbNullString
AudCodec2.OutFormat = vbNullString
UDPSocket1.Bind 0
Exit Sub
ErrorHandle:
Unload Me
Resume Next
End Sub
Private Sub HScroll1_Change()
On Error GoTo ErrorHandle
Dim l As Long
l = HScroll1
AudCap1.Volume = l * 100 l
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub HScroll2_Change()
On Error GoTo ErrorHandle
Dim l As Long
l = HScroll2
AudRnd1.Volume = l * 100 l
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuAutoAcceptCalls_Click()
On Error GoTo ErrorHandle
Accept = IIf(mnuAutoAcceptCalls.Checked, 0, 2)
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuCallDonotDisturb_Click()
On Error GoTo ErrorHandle
Accept = IIf(mnuCallDonotDisturb.Checked, 0, 1)
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuCallCreateSpeedDial_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuCallDirectory_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Friend Property Get Accept() As Long
If mnuCallDonotDisturb.Checked Then
Accept = 1
ElseIf mnuAutoAcceptCalls.Checked Then
Accept = 2
End If
End Property
Private Sub mnuCallExit_Click()
On Error GoTo ErrorHandle
Unload Me
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub CallTo(Host As String)
If Len(Host) <= 0 Then Exit Sub
If blnInConf Then MsgBox "Already in a conf.", vbExclamation: Exit Sub
Dim l As Long
l = InStr(Host, ":")
Dim s As String
Dim sp As String
If l Then
s = Left$(Host, l - 1)
sp = Mid$(Host, l 1)
Else
s = Host
End If
l = UDPSocket1.SetHost(s)
'If UDPSocket1.LocalAddress = l Then MsgBox "Can not make a self call.", vbExclamation: Exit Sub
If Len(sp) > 0 Then l = UDPSocket1.SetPort(sp)
For l = Combo1.ListCount - 1 To 0 Step -1
If Combo1.List(l) = Host Then Combo1.RemoveItem l: Exit For
Next
Combo1.AddItem Host, 0
Combo1.Text = Host
If Combo1.ListCount > 10 Then Combo1.RemoveItem Combo1.ListCount - 1
UDPSocket1.Frame -1, -1, TM_CALLSETUP, , gstrMyName
lCount = 30
lState = TM_CALLSETUP
End Sub
Private Sub ClearCall()
blnInConf = False
lCount = 0
lState = 0
Label1 = "Not in a conf."
List1.Clear
List1.AddItem "Name"
VidRnd1.Format = vbNullString
If mnuToolsVideoSend.Checked Then
VidRnd1.Format = VidCap1.Format
VidRnd1.Rate = -VidCap1.Rate
End If
End Sub
Private Sub HangupCall()
UDPSocket1.Frame -1, -1, TM_CALLHANGUP ', , "Remote hangup"
ClearCall
End Sub
Private Sub mnuCallHangUp_Click()
On Error GoTo ErrorHandle
If blnInConf Then HangupCall
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuCallHostMeeting_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuCallLogOnto_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuCallMeetingProperties_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuCallNewCall_Click()
On Error GoTo ErrorHandle
NewCall
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHeloBanasoftontheWebFeedback_Click()
On Error GoTo ErrorHandle
BrowseWeb "avphone3/bnmeeting/feedback.htm"
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHelpAbout_Click()
On Error GoTo ErrorHandle
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub BrowseWeb(Directory As String)
On Error GoTo ErrorHandle
BrowseTo "http://www.banasoft.net/" & Directory
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHelpBanasoftontheWebFAQ_Click()
On Error GoTo ErrorHandle
BrowseWeb "avphone3/bnmeeting/faq.htm"
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHelpBanasoftontheWebFreeStuff_Click()
On Error GoTo ErrorHandle
BrowseWeb "avphone3/bnmeeting/freestuff.htm"
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHelpBanasoftontheWebHome_Click()
On Error GoTo ErrorHandle
BrowseWeb vbNullString
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHelpBanasoftontheWebUpgrade_Click()
On Error GoTo ErrorHandle
BrowseWeb "avphone3/bnmeeting/upgrade.asp?curver=" & App.Major & "." & App.Minor & "." & App.Revision
Exit Sub
ErrorHandle:
Unload Me
End Sub
Friend Sub GetaCamera()
BrowseWeb "avphone3/bnmeeting/getcamera.htm"
End Sub
Private Sub mnuHelpGetaCamera_Click()
On Error GoTo ErrorHandle
GetaCamera
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHelpOnlineSupport_Click()
On Error GoTo ErrorHandle
BrowseWeb "avphone3/bnmeeting/support.htm"
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuHelpReadme_Click()
On Error GoTo ErrorHandle
BrowseTo App.Path & "\readme.htm"
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuRemoteDesktopSharing_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuToolsAudioTuneWizard_Click()
On Error GoTo ErrorHandle
Form8.Show vbModal, Me
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuToolsChat_Click()
On Error GoTo ErrorHandle
Command5_Click
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuToolsFileTransfer_Click()
On Error GoTo ErrorHandle
If Not blnInConf Then MsgBox "Not in a conf.", vbExclamation: Exit Sub
Load Form4
Form4.FileTransfer
Exit Sub
ErrorHandle:
If Err <> 32755 Then Unload Me
End Sub
Private Sub mnuToolsOptions_Click()
On Error GoTo ErrorHandle
ShowOptions 0
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuToolsShare_Click()
On Error GoTo ErrorHandle
NotImplement
Exit Sub
ErrorHandle:
Unload Me
End Sub
Friend Property Let VideoRece(ByVal State As Boolean)
VidCodec2.InFormat = vbNullString
VidCodec2.OutFormat = vbNullString
VidRnd1.Format = vbNullString
If Not blnInConf Then
VidRnd1.Format = VidCap1.Format
VidRnd1.Rate = -VidCap1.Rate
End If
mnuToolsVideoReceive.Checked = State
If blnInConf Then SendMessage -1, -1, IIf(State, TM_VIDEOSTART, TM_VIDEOSTOP)
End Property
Friend Property Get VideoRece() As Boolean
VideoRece = mnuToolsVideoReceive.Checked
End Property
Private Sub mnuToolsVideoReceive_Click()
VideoRece = Not mnuToolsVideoReceive.Checked
End Sub
Friend Property Let VideoCodec(New_Value As String)
VidCodec1.OutFormat = vbNullString
VidCodec1.OutFormat = New_Value
CodecChanged
End Property
Friend Property Get VideoCodec() As String
VideoCodec = VidCodec1.OutFormat
End Property
Private Sub CodecChanged()
If blnInConf Then SendMessage -1, -1, TM_VIDEOFORMAT, , IIf(Len(VidCap1.Format) > 0, VidCodec1.OutFormat, vbNullString)
End Sub
Private Sub FormatChanged()
Dim s As String
s = VidCap1.Format
If Not blnInConf Then VidRnd1.Format = s
VidRnd2.Format = s
Form3.VidRnd1.Format = s
VidCodec1.InFormat = vbNullString
'reset codec use fourcc name
VidCodec1.OutFormat = VidCodec1.OutFormat
VidCodec1.InFormat = s
CodecChanged
End Sub
Friend Property Let VideoFormat(ByVal New_Value As Long)
Dim s As String
s = VidCap1.Format
If Len(s) <= 0 Then s = "176,144,24"
Dim l As Long
l = InStr(s, ",")
l = InStr(l 1, s, ",")
s = Mid$(s, l)
Select Case New_Value
Case 0
s = "160,120" & s
Case 1
s = "176,144" & s
Case Else
s = "320,240" & s
End Select
VidCap1.Format = s
FormatChanged
End Property
Friend Property Get VideoFormat() As Long
Dim s As String
s = VidCap1.Format
If InStr(s, "160,") = 1 Then
VideoFormat = 0
ElseIf InStr(s, "176,") = 1 Then
VideoFormat = 1
Else
VideoFormat = 2
End If
' FormatChanged
End Property
Friend Property Let VideoSend(ByVal Send As Boolean)
If Send Then
VidCap1.Device = InitGetCurrentVideoDevice()
Else
VidCap1.Device = -2
End If
FormatChanged
mnuToolsVideoSend.Checked = Send
Form3.mnuVideoPause.Checked = Not Send
End Property
Friend Property Get VideoSend() As Boolean
VideoSend = mnuToolsVideoSend.Checked
End Property
Private Sub mnuToolsVideoSend_Click()
On Error GoTo ErrorHandle
VideoSend = Not mnuToolsVideoSend.Checked
Dim s As String
s = VidCap1.Format
VidRnd2.Format = s
Form3.VidRnd1.Format = s
VidCodec1.InFormat = s
If Not blnInConf Then
VidRnd1.Format = s
VidRnd1.Rate = -VidCap1.Rate
End If
Exit Sub
ErrorHandle:
Unload Me
End Sub
Friend Property Let VideoZoom(ByVal Index As Long)
Dim l As Long
For l = 0 To Form1.mnuToolsVideoWindowZooms.Count - 1
Form1.mnuToolsVideoWindowZooms(l).Checked = l = Index
Next
For l = 0 To Form3.mnuVideoWindowSizes.Count - 1
Form3.mnuVideoWindowSizes(l).Checked = l = Index
Next
l = (Index 1) * 100
VidRnd2.Zoom = l / 2
VidRnd1.Zoom = l
Form3.VidRnd1.Zoom = l
End Property
Friend Property Get VideoZoom() As Long
VideoZoom = VidRnd1.Zoom
End Property
Private Sub mnuToolsVideoWindowZooms_Click(Index As Integer)
On Error GoTo ErrorHandle
VideoZoom = Index
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuToolsWhiteboard_Click()
On Error GoTo ErrorHandle
Command6_Click
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuViewAlwaysonTop_Click()
On Error GoTo ErrorHandle
SetAlwaysonTop Not mnuViewAlwaysonTop.Checked
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuViewDialPad_Click()
On Error GoTo ErrorHandle
Dim b As Boolean
b = mnuViewDialPad.Checked
mnuViewDialPad.Checked = Not b
VidRnd1.Visible = b
VidRnd2.Visible = b And mnuViewPictureinPicture.Checked
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuViewMyVideo_Click()
On Error GoTo ErrorHandle
Form3.Show vbModeless, Me
Exit Sub
ErrorHandle:
Unload Me
End Sub
Friend Sub SetPictureInPicture(ByVal State As Boolean)
mnuViewPictureinPicture.Checked = State
VidRnd2.Visible = State
End Sub
Private Sub mnuViewPictureinPicture_Click()
On Error GoTo ErrorHandle
SetPictureInPicture Not mnuViewPictureinPicture.Checked
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub mnuViewStatusbar_Click()
On Error GoTo ErrorHandle
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub Timer1_Timer()
On Error GoTo ErrorHandle
If lCount <= 0 Then Exit Sub
lCount = lCount - 1
If blnInConf Then
Select Case lCount
Case 10, 20
SendMessage -1, -1, TM_CALLHANDREQ
End Select
End If
If lCount > 0 Then Exit Sub
Dim l As Long
l = lState
lState = 0
Select Case l
Case TM_CALLSETUP
HangupCall
MsgBox "Remote not response.", vbExclamation
Case TM_CALLANSWER
HangupCall
MsgBox "Communication timeout.", vbExclamation
End Select
Exit Sub
ErrorHandle:
Beep
End Sub
Private Sub AcceptCall(ByVal Address As Long, ByVal Port As Integer, Party As Variant)
'bnmeeting is only for p2p, more users might cause incorrect
'result, you can use server ports for communication
'use GetIP(0) to get the real IP and port on a proxy
With UDPSocket1
.SetHost Address
.SetPort Port
.Frame -1, -1, TM_CALLANSWER, , gstrMyName
End With
SetupCall Party
End Sub
Private Sub SetupCall(Party As Variant)
blnInConf = True
lState = TM_CALLANSWER
lCount = 30
List1.Clear
List1.AddItem "Name"
List1.AddItem " " & gstrMyName
List1.AddItem " " & Party
Label1 = "In the conf."
If mnuToolsVideoSend.Checked Then UDPSocket1.Frame -1, -1, TM_VIDEOFORMAT, , VidCodec1.OutFormat
If Check1 = vbChecked Then UDPSocket1.Frame -1, -1, TM_AUDIOFORMAT, , AudCodec1.OutFormat
End Sub
Private Sub HandleCall(ByVal Address As Long, ByVal Port As Integer, ByVal Handle As Long, ByVal lParam As Long, vData As Variant)
Select Case Handle
Case TM_CALLSETUP
If mnuCallDonotDisturb.Checked Then
UDPSocket1.Frame Address, Port, TM_CALLREJECT, , "Do not disturb active."
ElseIf mnuAutoAcceptCalls.Checked Then
AcceptCall Address, Port, vData
ElseIf MsgBox("Accept call from: " & vData & "?", vbQuestion vbYesNo) = vbYes Then
AcceptCall Address, Port, vData
Else
UDPSocket1.Frame Address, Port, TM_CALLREJECT, , "Your call was rejected by remote."
End If
Case TM_CALLREJECT
If lState = TM_CALLSETUP Then
lState = 0
MsgBox vData, vbInformation
End If
Case TM_CALLANSWER
If lState = TM_CALLSETUP Then SetupCall vData
Case TM_CALLHANGUP
If Not blnInConf Then Exit Sub
ClearCall
If Len(vData) Then
MsgBox vData, vbInformation
Else
Beep
End If
Case TM_CALLHANDREQ
If Not blnInConf Then Exit Sub
SendMessage -1, -1, TM_CALLHANDRR
Case TM_CALLHANDRR
If blnInConf Then lCount = 30
End Select
End Sub
Private Sub HandleAudioVideo(ByVal Address As Long, ByVal Port As Integer, ByVal Handle As Long, ByVal lParam As Long, vData As Variant)
Select Case Handle
Case TM_VIDEOFORMAT
If mnuToolsVideoReceive.Checked Then
VidCodec2.OutFormat = vbNullString
VidCodec2.InFormat = vData
VidRnd1.Format = VidCodec2.OutFormat
VidRnd1.Rate = Abs(VidRnd1.Rate)
Else
UDPSocket1.Frame -1, -1, TM_VIDEOSTOP
End If
Case TM_VIDEOSTART
If mnuToolsVideoSend.Checked = False Then VideoSend = True
Case TM_VIDEOSTOP
If mnuToolsVideoSend.Checked Then VideoSend = False
Case TM_VIDEOFRAME
If mnuToolsVideoReceive.Checked Then VidCodec2.Frame vData, False
Case TM_VIDEOFRAMEKEY
If mnuToolsVideoReceive.Checked Then VidCodec2.Frame vData, True
Case TM_AUDIOFORMAT
If Check2 = vbChecked Then
AudCodec2.OutFormat = vbNullString
AudCodec2.InFormat = vData
AudRnd1.Format = AudCodec2.OutFormat
Else
UDPSocket1.Frame -1, -1, TM_AUDIOSTOP
End If
Case TM_AUDIOSTART
If Check1 <> vbChecked Then Check1 = vbChecked
Case TM_AUDIOSTOP
If Check1 = vbChecked Then Check1 = vbUnchecked
Case TM_AUDIOFRAME
If Check2 = vbChecked Then AudCodec2.Frame vData
End Select
End Sub
Private Sub UDPSocket1_Frame(ByVal Address As Long, ByVal Port As Integer, ByVal Handle As Long, ByVal lParam As Long, vData As Variant)
On Error GoTo ErrorHandle
Select Case Handle And TM_CLASSMASK
Case TM_CALLCLASS
HandleCall Address, Port, Handle, lParam, vData
Case Else
If Not blnInConf Then Exit Sub
lCount = 30
Select Case Handle And TM_CLASSMASK
Case TM_AUDIOVIDEOCLASS
HandleAudioVideo Address, Port, Handle, lParam, vData
Case TM_FILECLASS
Form4.OnMessage Address, Port, Handle, lParam, vData
Case TM_WHITECLASS
Form5.OnMessage Address, Port, Handle, lParam, vData
Case TM_CHATCLASS
Form6.OnMessage Trim$(List1.List(List1.ListCount - 1)), Address, Port, Handle, lParam, vData
End Select
End Select
Exit Sub
ErrorHandle:
' Beep
Label1 = Err.Description
End Sub
Private Sub VidCap1_Frame(Data As Variant)
On Error GoTo ErrorHandle
If mnuViewPictureinPicture.Checked Then VidRnd2.Frame Data
If Form3.Visible Then Form3.VidRnd1.Frame Data
If blnInConf Then
If mnuToolsVideoSend.Checked Then VidCodec1.Frame Data
Else
VidRnd1.Frame Data
End If
Exit Sub
ErrorHandle:
End Sub
Private Sub VidCodec1_Frame(Data As Variant, ByVal IsKeyFrame As Boolean)
On Error GoTo ErrorHandle
UDPSocket1.Frame -1, -1, IIf(IsKeyFrame, TM_VIDEOFRAMEKEY, TM_VIDEOFRAME), , Data
Exit Sub
ErrorHandle:
Label1 = Err.Description
End Sub
Private Sub VidCodec2_Frame(Data As Variant, ByVal IsKeyFrame As Boolean)
On Error GoTo ErrorHandle
VidRnd1.Frame Data
Exit Sub
ErrorHandle:
Label1 = Err.Description
End Sub
Private Sub VidRnd1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo ErrorHandle
If Button = vbRightButton Then PopupMenu Form3.mnuVideo
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub SizeControls()
Frame1.Move Frame1.Left, Frame1.Top, VidRnd1.Width 90, VidRnd1.Height * 1.3
Picture1.Move Picture1.Left, Picture1.Top, VidRnd1.Width, VidRnd1.Height
Combo1.Width = Picture1.Width
Frame4.Left = Frame1.Left Frame1.Width - 30
Frame4.Height = Frame1.Height
VidRnd2.Move VidRnd1.Width - VidRnd2.Width, VidRnd1.Height - VidRnd2.Height
End Sub
Private Sub VidRnd1_Resize()
On Error GoTo ErrorHandle
SizeControls
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub VidRnd2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo ErrorHandle
If Button = vbRightButton Then PopupMenu Form3.mnuVideo
Exit Sub
ErrorHandle:
Unload Me
End Sub
Private Sub AudCodec2_Frame(Data As Variant)
On Error GoTo ErrorHandle
AudRnd1.Frame Data
ErrorHandle:
End Sub
Private Sub VidRnd2_Resize()
On Error GoTo ErrorHandle
SizeControls
Exit Sub
ErrorHandle:
Unload Me
End Sub
Friend Sub AudioCompressorDlg()
AudCodec1.CompressorDlg
AudioCodec = AudioCodec
End Sub
Friend Sub VideoSourceDlg()
VidCap1.SourceDlg
FormatChanged
End Sub
Friend Sub VideoFormatDlg()
VidCap1.FormatDlg
FormatChanged
End Sub
Friend Sub VideoCompressorDlg()
VidCodec1.CompressorDlg
CodecChanged
End Sub
Friend Property Get VideoDevice() As Long
VideoDevice = VidCap1.Device
End Property
Friend Property Let VideoDevice(ByVal Index As Long)
VidCap1.Device = Index
FormatChanged
End Property
好例子网口号：伸出你的我的手 — 分享！
小贴士
感谢您为本站写下的评论，您的评论对其它用户来说具有重要的参考价值，所以请认真填写。
- 类似“顶”、“沙发”之类没有营养的文字，对勤劳贡献的楼主来说是令人沮丧的反馈信息。
- 相信您也不想看到一排文字/表情墙，所以请不要反馈意义不大的重复字符，也请尽量不要纯表情的回复。
- 提问之前请再仔细看一遍楼主的说明，或许是您遗漏了。
- 请勿到处挖坑绊人、招贴广告。既占空间让人厌烦，又没人会搭理，于人于己都无利。
关于好例子网
本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享，对搜索内容的合法性不具有预见性、识别性、控制性，仅供学习研究，请务必在下载后24小时内给予删除，不得用于其他任何用途，否则后果自负。基于互联网的特殊性，平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查；无论平台是否已进行审查，用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场，基于网友分享，根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定，若资源存在侵权或相关问题请联系本站客服人员，点此联系我们。关于更多版权及免责申明参见 版权及免责申明
网友评论
我要评论