RiskYourLife/Client
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit: ROW Client source code

Browse Source 
Game client codebase including:
- CharacterActionControl: Character and creature management
- GlobalScript: Network, items, skills, quests, utilities
- RYLClient: Main client application with GUI and event handlers
- Engine: 3D rendering engine (RYLGL)
- MemoryManager: Custom memory allocation
- Library: Third-party dependencies (DirectX, boost, etc.)
- Tools: Development utilities

🤖 Generated with [Claude Code](https://claude.com/claude-code)

Co-Authored-By: Claude <noreply@anthropic.com>
This commit is contained in:
tindevil
2025-11-29 16:24:34 +09:00
commit e067522598
5135 changed files with 1745744 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

262
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmChat.frm Normal file
View File

@@ -0,0 +1,262 @@
VERSION 5.00
Begin VB.Form frmChat
BorderStyle = 3 'Fixed Dialog
Caption = "vbDirectPlay Chat"
ClientHeight = 5085
ClientLeft = 45
ClientTop = 330
ClientWidth = 7710
Icon = "frmChat.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5085
ScaleWidth = 7710
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdWhisper
Caption = "Whisper"
Height = 255
Left = 5820
TabIndex = 3
Top = 4740
Width = 1695
End
Begin VB.Timer tmrUpdate
Enabled = 0 'False
Interval = 50
Left = 10200
Top = 120
End
Begin VB.TextBox txtSend
Height = 285
Left = 60
TabIndex = 0
Top = 4740
Width = 5655
End
Begin VB.ListBox lstUsers
Height = 4545
Left = 5760
TabIndex = 2
Top = 120
Width = 1815
End
Begin VB.TextBox txtChat
Height = 4635
Left = 60
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 1
TabStop = 0 'False
Top = 60
Width = 5595
End
End
Attribute VB_Name = "frmChat"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmChat.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private Sub cmdWhisper_Click()
Dim lMsg As Long, lOffset As Long
Dim sChatMsg As String
Dim oBuf() As Byte
If lstUsers.ListIndex < 0 Then
MsgBox "You must select a user in the list before you can whisper to that person.", vbOKOnly Or vbInformation, "Select someone"
Exit Sub
End If
If lstUsers.ItemData(lstUsers.ListIndex) = 0 Then
MsgBox "Why are you whispering to yourself?", vbOKOnly Or vbInformation, "Select someone else"
Exit Sub
End If
If txtSend.Text = vbNullString Then
MsgBox "What's the point of whispering if you have nothing to say..", vbOKOnly Or vbInformation, "Enter text"
Exit Sub
End If
'Send this message to the person you are whispering to
lMsg = MsgWhisper
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
sChatMsg = txtSend.Text
AddStringToBuffer oBuf, sChatMsg, lOffset
txtSend.Text = vbNullString
dpp.SendTo lstUsers.ItemData(lstUsers.ListIndex), oBuf, 0, DPNSEND_NOLOOPBACK
UpdateChat "**<" & gsUserName & ">** " & sChatMsg
End Sub
Private Sub Form_Load()
'load all of the players into our list
LoadAllPlayers
End Sub
Private Sub UpdateChat(ByVal sString As String)
'Update the chat window first
txtChat.Text = txtChat.Text & sString & vbCrLf
'Now limit the text in the window to be 16k
If Len(txtChat.Text) > 16384 Then
txtChat.Text = Right$(txtChat.Text, 16384)
End If
'Autoscroll the text
txtChat.SelStart = Len(txtChat.Text)
End Sub
Private Sub txtSend_KeyPress(KeyAscii As Integer)
Dim lMsg As Long, lOffset As Long
Dim sChatMsg As String
Dim oBuf() As Byte
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
If txtSend.Text = vbNullString Then Exit Sub
'Send this message to everyone
lMsg = MsgChat
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
sChatMsg = txtSend.Text
AddStringToBuffer oBuf, sChatMsg, lOffset
txtSend.Text = vbNullString
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
UpdateChat "<" & gsUserName & ">" & sChatMsg
End If
End Sub
Private Function GetName(ByVal lID As Long) As String
Dim lCount As Long
GetName = vbNullString
For lCount = 0 To lstUsers.ListCount - 1
If lstUsers.ItemData(lCount) = lID Then 'This is the player
GetName = lstUsers.List(lCount)
Exit For
End If
Next
End Function
Public Sub LoadAllPlayers()
Dim lCount As Long
Dim dpPlayer As DPN_PLAYER_INFO
lstUsers.Clear
For lCount = 1 To dpp.GetCountPlayersAndGroups(DPNENUM_PLAYERS)
dpPlayer = dpp.GetPeerInfo(dpp.GetPlayerOrGroup(lCount))
lstUsers.AddItem dpPlayer.Name
If ((dpPlayer.lPlayerFlags And DPNPLAYER_LOCAL) <> DPNPLAYER_LOCAL) Then
'Do not add a ItemData key for myself
lstUsers.ItemData(lstUsers.ListCount - 1) = dpp.GetPlayerOrGroup(lCount)
End If
Next
End Sub
Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
Dim lCount As Long
'We only care when someone leaves. When they join we will receive a 'MSGJoin'
'Remove this player from our list
For lCount = 0 To lstUsers.ListCount - 1
If lstUsers.ItemData(lCount) = lPlayerID Then 'This is the player
UpdateChat "---- " & lstUsers.List(lCount) & " has left the chat."
lstUsers.RemoveItem lCount
Exit For
End If
Next
End Sub
Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
'process what msgs we receive.
'All we care about in this form is what msgs we receive.
Dim lMsg As Long, lOffset As Long
Dim dpPeer As DPN_PLAYER_INFO, sName As String
Dim sChat As String
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case MsgChat
sName = GetName(.idSender)
sChat = GetStringFromBuffer(.ReceivedData, lOffset)
UpdateChat "<" & sName & "> " & sChat
Case MsgWhisper
sName = GetName(.idSender)
sChat = GetStringFromBuffer(.ReceivedData, lOffset)
UpdateChat "**<" & sName & ">** " & sChat
End Select
End With
End Sub
Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmChat.frx Normal file
View File

Binary file not shown.

112
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmJoinRequest.frm Normal file
View File

@@ -0,0 +1,112 @@
VERSION 5.00
Begin VB.Form frmJoinRequest
BorderStyle = 3 'Fixed Dialog
Caption = "Receiving a call...."
ClientHeight = 975
ClientLeft = 45
ClientTop = 330
ClientWidth = 4680
ControlBox = 0 'False
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 975
ScaleWidth = 4680
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdReject
Cancel = -1 'True
Caption = "Reject"
Height = 315
Left = 3420
TabIndex = 3
Top = 120
Width = 1155
End
Begin VB.CommandButton cmdAccept
Caption = "Accept"
Default = -1 'True
Height = 315
Left = 3420
TabIndex = 2
Top = 540
Width = 1155
End
Begin VB.Label lblFriend
BackStyle = 0 'Transparent
Height = 195
Left = 720
TabIndex = 1
Top = 420
Width = 2115
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "You are receiving a call from"
Height = 195
Left = 720
TabIndex = 0
Top = 180
Width = 2115
End
Begin VB.Image Image1
Height = 480
Left = 120
Picture = "frmJoinRequest.frx":0000
Top = 180
Width = 480
End
End
Attribute VB_Name = "frmJoinRequest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmJoinRequest.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private mlPlayerID As Long
Private msPlayername As String
Private moForm As frmNetwork
Public Sub SetupRequest(oForm As frmNetwork, ByVal lPlayerID As Long, ByVal sPlayerName As String)
Set moForm = oForm
mlPlayerID = lPlayerID
msPlayername = sPlayerName
lblFriend.Caption = sPlayerName
End Sub
Private Sub cmdAccept_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Accept this connection
lMsg = MsgAcceptJoin
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
dpp.SendTo mlPlayerID, oBuf, 0, DPNSEND_NOLOOPBACK
moForm.UpdatePlayerList
'Notify everyone that this player has joined
lMsg = MsgNewPlayerJoined
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
Unload Me
End Sub
Private Sub cmdReject_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Reject this connection
lMsg = MsgRejectJoin
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
dpp.SendTo mlPlayerID, oBuf, 0, DPNSEND_NOLOOPBACK
Unload Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmJoinRequest.frx Normal file
View File

Binary file not shown.

947
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmNetwork.frm Normal file
View File

@@ -0,0 +1,947 @@
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmNetwork
BorderStyle = 3 'Fixed Dialog
Caption = "vbConferencer"
ClientHeight = 4605
ClientLeft = 45
ClientTop = 330
ClientWidth = 3930
Icon = "frmNetwork.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4605
ScaleWidth = 3930
StartUpPosition = 3 'Windows Default
Begin VB.Timer tmrVoice
Enabled = 0 'False
Interval = 10
Left = 6435
Top = 975
End
Begin VB.CheckBox chkVoice
Caption = "Enable Voice Chat"
Height = 255
Left = 1140
TabIndex = 9
Top = 3660
Value = 1 'Checked
Width = 1635
End
Begin MSComDlg.CommonDialog cdlSend
Left = 6360
Top = 3180
_ExtentX = 847
_ExtentY = 847
_Version = 393216
DialogTitle = "Send File"
Filter = "Any File |*.*"
Flags = 4
InitDir = "C:\"
End
Begin VB.Timer tmrJoin
Enabled = 0 'False
Interval = 50
Left = 6420
Top = 540
End
Begin VB.Timer tmrUpdate
Enabled = 0 'False
Interval = 10
Left = 6420
Top = 60
End
Begin VB.TextBox txtCall
Height = 285
Left = 60
TabIndex = 0
Top = 300
Width = 2535
End
Begin VB.ListBox lstUsers
Height = 2595
Left = 60
TabIndex = 3
Top = 1020
Width = 3795
End
Begin VB.CommandButton cmdHangup
Height = 495
Left = 3240
MaskColor = &H00FF0000&
Picture = "frmNetwork.frx":030A
Style = 1 'Graphical
TabIndex = 2
ToolTipText = "Hang up"
Top = 120
UseMaskColor = -1 'True
Width = 495
End
Begin VB.CommandButton cmdCall
Default = -1 'True
Height = 495
Left = 2700
MaskColor = &H000000FF&
Picture = "frmNetwork.frx":0A0C
Style = 1 'Graphical
TabIndex = 1
ToolTipText = "Call a friend"
Top = 120
UseMaskColor = -1 'True
Width = 495
End
Begin VB.CommandButton cmdWhiteBoard
Height = 495
Left = 2325
MaskColor = &H000000FF&
Picture = "frmNetwork.frx":110E
Style = 1 'Graphical
TabIndex = 6
ToolTipText = "Use the whiteboard"
Top = 4020
UseMaskColor = -1 'True
Width = 495
End
Begin VB.CommandButton cmdChat
Height = 495
Left = 1125
MaskColor = &H000000FF&
Picture = "frmNetwork.frx":1A18
Style = 1 'Graphical
TabIndex = 4
ToolTipText = "Chat with someone"
Top = 4020
UseMaskColor = -1 'True
Width = 495
End
Begin VB.CommandButton cmdSendFile
Height = 495
Left = 1725
MaskColor = &H000000FF&
Picture = "frmNetwork.frx":2322
Style = 1 'Graphical
TabIndex = 5
ToolTipText = "Transfer files to someone"
Top = 4020
UseMaskColor = -1 'True
Width = 495
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Enter a name or IP to call"
Height = 195
Index = 1
Left = 60
TabIndex = 8
Top = 60
Width = 2475
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Users currently in this session"
Height = 315
Index = 0
Left = 60
TabIndex = 7
Top = 780
Width = 3735
End
Begin VB.Menu mnuPopup
Caption = "PopUp"
Visible = 0 'False
Begin VB.Menu mnuExit
Caption = "E&xit"
End
End
End
Attribute VB_Name = "frmNetwork"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmNetwork.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Implements DirectPlayVoiceEvent8
'You can make bigger or smaller chunks here
Private Const mlFileChunkSize As Long = 512
'Variables for file transfers
Private moReceivedFiles As New Collection
Private moSendFiles As New Collection
Private mlSendUnique As Long
'Misc private variables
Private moCallBack As DirectPlay8Event
Private mfExit As Boolean
Private mfTerminate As Boolean
Private mlVoiceError As Long
Private Sub chkVoice_Click()
If gfNoVoice Then Exit Sub 'Ignore this since voice chat isn't possible on this session
If chkVoice.Value = vbChecked Then
ConnectVoice Me
ElseIf chkVoice.Value = vbUnchecked Then
If Not (dvClient Is Nothing) Then dvClient.UnRegisterMessageHandler
If Not (dvClient Is Nothing) Then dvClient.Disconnect DVFLAGS_SYNC
Set dvClient = Nothing
End If
End Sub
Private Sub cmdCall_Click()
If txtCall.Text = vbNullString Then
MsgBox "You must type the name or address of the person you wish to call before I can make the call.", vbOKOnly Or vbInformation, "No callee"
Exit Sub
End If
Connect Me, txtCall.Text
End Sub
Private Sub cmdChat_Click()
If lstUsers.ListCount < 2 Then
MsgBox "You must have at least two people in the session before you can chat.", vbOKOnly Or vbInformation, "Not enough people"
Exit Sub
End If
If ChatWindow Is Nothing Then Set ChatWindow = New frmChat
ChatWindow.Show vbModeless
'Notify everyone
SendOpenChatWindowMessage
Set moCallBack = ChatWindow
End Sub
Private Sub cmdHangup_Click()
'Cleanup and quit
mfExit = True
Unload Me
End Sub
Private Sub cmdSendFile_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
If lstUsers.ListIndex < 0 Then
MsgBox "You must select someone to send a file to before sending one.", vbOKOnly Or vbInformation, "No selection"
Exit Sub
End If
If lstUsers.ListIndex < 1 Then
MsgBox "You must select someone other than yourself to send a file to before sending one.", vbOKOnly Or vbInformation, "No selection"
Exit Sub
End If
'Ok, we can send a file.. Let them pick one
cdlSend.FileName = vbNullString
On Error Resume Next
cdlSend.ShowOpen
If Err Or (cdlSend.FileName = vbNullString) Then Exit Sub 'They clicked cancel
cdlSend.InitDir = GetFolder(cdlSend.FileName)
'Otherwise start the file send
LockSendCollection
Dim f As frmProgress
Set f = New frmProgress
With f
.sFileName = cdlSend.FileName
.lDPlayID = lstUsers.ItemData(lstUsers.ListIndex)
mlSendUnique = mlSendUnique + 1
.FileUniqueID = mlSendUnique
'We need to send a 'Request' message first
lOffset = NewBuffer(oBuf)
lMsg = MsgSendFileRequest
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, mlSendUnique, LenB(mlSendUnique), lOffset
AddStringToBuffer oBuf, StripFileName(cdlSend.FileName), lOffset
dpp.SendTo lstUsers.ItemData(lstUsers.ListIndex), oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
End With
moSendFiles.Add f
UnlockSendCollection
End Sub
Private Sub cmdWhiteBoard_Click()
If lstUsers.ListCount < 2 Then
MsgBox "You must have at least two people in the session before you can use the whiteboard.", vbOKOnly Or vbInformation, "Not enough people"
Exit Sub
End If
If WhiteBoardWindow Is Nothing Then Set WhiteBoardWindow = New frmWhiteBoard
WhiteBoardWindow.Show vbModeless
'Notify everyone
SendOpenWhiteBoardWindowMessage
Set moCallBack = WhiteBoardWindow
End Sub
Private Sub Form_Load()
'First start our server. We need to be running a server in case
'someone tries to connect to us.
StartHosting Me
'Add ourselves to the listbox
lstUsers.AddItem gsUserName
lstUsers.ItemData(0) = glMyPlayerID
'Now put up our system tray icon
With sysIcon
.cbSize = LenB(sysIcon)
.hwnd = Me.hwnd
.uFlags = NIF_DOALL
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.sTip = "vbConferencer" & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, sysIcon
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ShellMsg As Long
ShellMsg = X / Screen.TwipsPerPixelX
Select Case ShellMsg
Case WM_LBUTTONDBLCLK
ShowMyForm
Case WM_RBUTTONUP
'Show the menu
'If gfStarted Then mnuStart.Enabled = False
PopupMenu mnuPopup, , , , mnuExit
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not mfExit Then
Cancel = 1
Me.Hide
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim f As Form
Dim lCount As Long
Me.Hide
Shell_NotifyIcon NIM_DELETE, sysIcon
Cleanup
For lCount = 1 To moSendFiles.Count 'Clear the collection
moSendFiles.Remove 1
Next
Set moSendFiles = Nothing
For lCount = 1 To moReceivedFiles.Count 'Clear the collection
moReceivedFiles.Remove 1
Next
Set moReceivedFiles = Nothing
For Each f In Forms
If Not (f Is Me) Then
Unload f
Set f = Nothing
End If
Next
DeleteCriticalSection goSendFile
DeleteCriticalSection goReceiveFile
End
End Sub
Private Sub mnuExit_Click()
mfExit = True
Unload Me
End Sub
Private Sub ShowMyForm()
Me.Visible = True
End Sub
Private Sub tmrJoin_Timer()
tmrJoin.Enabled = False
MsgBox "The person you are trying to reach did not accept your call.", vbOKOnly Or vbInformation, "Didn't accept"
StartHosting Me
End Sub
Public Sub UpdatePlayerList()
Dim lCount As Long, dpPeer As DPN_PLAYER_INFO
Dim lInner As Long, fFound As Boolean
Dim lTotal As Long
lTotal = dpp.GetCountPlayersAndGroups(DPNENUM_PLAYERS)
If lTotal > 1 Then
cmdHangup.Enabled = True
cmdCall.Enabled = False
End If
For lCount = 1 To lTotal
dpPeer = dpp.GetPeerInfo(dpp.GetPlayerOrGroup(lCount))
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then
'Don't add me
Else
fFound = False
'Make sure they're not already added
For lInner = 0 To lstUsers.ListCount - 1
If lstUsers.ItemData(lInner) = dpp.GetPlayerOrGroup(lCount) Then fFound = True
Next
If Not fFound Then
'Go ahead and add them
lstUsers.AddItem dpPeer.Name
lstUsers.ItemData(lstUsers.ListCount - 1) = dpp.GetPlayerOrGroup(lCount)
End If
End If
Next
End Sub
Private Sub SendOpenWhiteBoardWindowMessage()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Now let's send a message asking the host to accept our call
lOffset = NewBuffer(oBuf)
lMsg = MsgShowWhiteBoard
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
End Sub
Private Sub SendOpenChatWindowMessage()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Now let's send a message asking the host to accept our call
lOffset = NewBuffer(oBuf)
lMsg = MsgShowChat
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
End Sub
Private Sub RemovePlayer(ByVal lPlayerID As Long)
Dim lCount As Long
'Remove anyone who has this player id
For lCount = 0 To lstUsers.ListCount - 1
If lstUsers.ItemData(lCount) = lPlayerID Then lstUsers.RemoveItem lCount
Next
If Not (ChatWindow Is Nothing) Then ChatWindow.LoadAllPlayers
'Let's see if there are any files being sent to this user
Dim f As frmProgress
LockSendCollection
For Each f In moSendFiles
If f.lDPlayID = lPlayerID Then
'Notify the user
MsgBox "Cancelled transfering file " & f.sFileName & " because the user quit."
'Yup, get rid of this file
EraseSendFile f.FileUniqueID
End If
Next
UnlockSendCollection
'Now look through the receive collection
LockReceiveCollection
For Each f In moReceivedFiles
If f.lDPlayID = lPlayerID Then
'Notify the user
MsgBox "Cancelled receiving file " & f.sFileName & " because the user quit."
'Yup, get rid of this file
EraseReceiveFile f.FileUniqueID
End If
Next
UnlockReceiveCollection
If lstUsers.ListCount <= 1 Then 'We are the only person left
cmdCall.Enabled = True
cmdHangup.Enabled = False
End If
End Sub
Private Function StripFileName(ByVal sFile As String) As String
'Get rid of the path to the file (Strip everything after the last \)
If InStr(sFile, "\") Then
StripFileName = Right$(sFile, Len(sFile) - InStrRev(sFile, "\"))
Else
StripFileName = sFile
End If
End Function
Private Sub SendNextFilePart(ByVal lUniqueID As Long)
Dim lNewMsg As Long, lNewOffSet As Long
Dim oBuf() As Byte, lChunkSize As Long
Dim oFile() As Byte, f As frmProgress
'First we need to find the correct file in our send list
LockSendCollection
Set f = GetSendProgressForm(lUniqueID)
With f
'Send this chunk
lNewOffSet = NewBuffer(oBuf)
lNewMsg = MsgSendFilePart
AddDataToBuffer oBuf, lNewMsg, LenB(lNewMsg), lNewOffSet
AddDataToBuffer oBuf, .FileUniqueID, SIZE_LONG, lNewOffSet
'Is this chunk bigger than the amount we will send?
If .lCurrentPos + mlFileChunkSize > .lFileSize Then
'First send the chunksize
lChunkSize = .lFileSize - .lCurrentPos
Else
lChunkSize = mlFileChunkSize
End If
AddDataToBuffer oBuf, lChunkSize, LenB(lChunkSize), lNewOffSet
ReDim oFile(1 To lChunkSize)
'Now read in a chunk that size
If .filNumber = 0 Then
.filNumber = FreeFile
Open .sFileName For Binary Access Read As #.filNumber
End If
Get #.filNumber, , oFile
AddDataToBuffer oBuf, oFile(1), lChunkSize, lNewOffSet
dpp.SendTo .lDPlayID, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
.lCurrentPos = .lCurrentPos + lChunkSize
'Update our transfer window
.SetValue .lCurrentPos
If .lCurrentPos >= .lFileSize Then
Close #.filNumber
'Now get rid of this member of the array
EraseSendFile .FileUniqueID
End If
End With
UnlockSendCollection
End Sub
Public Sub EraseSendFile(ByVal lUnique As Long)
Dim lCount As Long, f As frmProgress
'First we need to find the correct file in our send list
LockSendCollection
For lCount = moSendFiles.Count To 1 Step -1
Set f = moSendFiles.Item(lCount)
If f.FileUniqueID = lUnique Then
moSendFiles.Remove lCount
Unload f
Set f = Nothing
Exit For
End If
Next
UnlockSendCollection
End Sub
Public Sub EraseReceiveFile(ByVal lUnique As Long)
Dim lCount As Long, f As frmProgress
'First we need to find the correct file in our send list
LockReceiveCollection
For lCount = moReceivedFiles.Count To 1 Step -1
Set f = moReceivedFiles.Item(lCount)
If f.FileUniqueID = lUnique Then
moReceivedFiles.Remove lCount
Unload f.RequestForm
Set f.RequestForm = Nothing
Unload f
Set f = Nothing
Exit For
End If
Next
UnlockReceiveCollection
End Sub
Private Function GetSendProgressForm(ByVal lUnique As Long) As frmProgress
Dim f As frmProgress
LockSendCollection
For Each f In moSendFiles
If f.FileUniqueID = lUnique Then
Set GetSendProgressForm = f
Exit For
End If
Next
UnlockSendCollection
End Function
Private Function GetReceiveProgressForm(ByVal lUnique As Long) As frmProgress
Dim f As frmProgress
LockReceiveCollection
For Each f In moReceivedFiles
If f.FileUniqueID = lUnique Then
Set GetReceiveProgressForm = f
Exit For
End If
Next
UnlockReceiveCollection
End Function
Private Function GetFolder(ByVal sFile As String) As String
Dim lCount As Long
For lCount = Len(sFile) To 1 Step -1
If Mid$(sFile, lCount, 1) = "\" Then
GetFolder = Left$(sFile, lCount)
Exit Function
End If
Next
GetFolder = vbNullString
End Function
Private Sub tmrUpdate_Timer()
tmrUpdate.Enabled = False
If Not mfTerminate Then
MsgBox "The person you are trying to reach is not available.", vbOKOnly Or vbInformation, "Unavailable"
End If
StartHosting Me
mfTerminate = False
End Sub
Private Sub tmrVoice_Timer()
tmrVoice.Enabled = False
MsgBox "Could not start DirectPlayVoice. This sample will not have any voice capablities." & vbCrLf & "Error:" & CStr(mlVoiceError), vbOKOnly Or vbInformation, "No Voice"
gfNoVoice = True
chkVoice.Value = vbUnchecked
chkVoice.Enabled = False
End Sub
'We will hold a critical section for the two separate collections
'This will ensure that two threads can't access the data at the same time
Public Sub LockSendCollection()
EnterCriticalSection goSendFile
End Sub
Public Sub UnlockSendCollection()
LeaveCriticalSection goSendFile
End Sub
Public Sub LockReceiveCollection()
EnterCriticalSection goReceiveFile
End Sub
Public Sub UnlockReceiveCollection()
LeaveCriticalSection goReceiveFile
End Sub
'We will handle all of the msgs here, and report them all back to the callback sub
'in case the caller cares what's going on
Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.AddRemovePlayerGroup lMsgID, lPlayerID, lGroupID, fRejectMsg
End Sub
Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.AppDesc fRejectMsg
End Sub
Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.AsyncOpComplete dpnotify, fRejectMsg
End Sub
Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
If dpnotify.hResultCode = 0 Then 'Success!
cmdHangup.Enabled = True
'Now let's send a message asking the host to accept our call
lOffset = NewBuffer(oBuf)
lMsg = MsgAskToJoin
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
Else
tmrUpdate.Enabled = True
End If
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.ConnectComplete dpnotify, fRejectMsg
End Sub
Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.CreateGroup lGroupID, lOwnerID, fRejectMsg
End Sub
Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
Dim dpPeer As DPN_PLAYER_INFO
On Error Resume Next
dpPeer = dpp.GetPeerInfo(lPlayerID)
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then
glMyPlayerID = lPlayerID
lstUsers.ItemData(0) = glMyPlayerID
End If
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.CreatePlayer lPlayerID, fRejectMsg
End Sub
Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.DestroyGroup lGroupID, lReason, fRejectMsg
End Sub
Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
Dim dpPeer As DPN_PLAYER_INFO
On Error Resume Next
If lPlayerID <> glMyPlayerID Then 'ignore removing myself
RemovePlayer lPlayerID
End If
If Not (ChatWindow Is Nothing) Then Set moCallBack = ChatWindow 'If the chat window is open, let them know about the departure.
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.DestroyPlayer lPlayerID, lReason, fRejectMsg
End Sub
Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.EnumHostsQuery dpnotify, fRejectMsg
End Sub
Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.EnumHostsResponse dpnotify, fRejectMsg
End Sub
Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.HostMigrate lNewHostID, fRejectMsg
End Sub
Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.IndicateConnect dpnotify, fRejectMsg
End Sub
Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.IndicatedConnectAborted fRejectMsg
End Sub
Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.InfoNotify lMsgID, lNotifyID, fRejectMsg
End Sub
Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
Dim lNewMsg As Long, lNewOffSet As Long
Dim oBuf() As Byte, f As frmProgress
Dim lMsg As Long, lOffset As Long
Dim frmJoin As frmJoinRequest
Dim dpPeer As DPN_PLAYER_INFO
Dim sFile As String, lUnique As Long
Dim oFile() As Byte, lFileSize As Long
Dim lChunkSize As Long, oData() As Byte
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case MsgChat, MsgWhisper 'Make sure chat messages get to the chat window
If ChatWindow Is Nothing Then
Set ChatWindow = New frmChat
End If
ChatWindow.Show
Set moCallBack = ChatWindow
Case MsgSendDrawPixel, MsgClearWhiteBoard
If WhiteBoardWindow Is Nothing Then
Set WhiteBoardWindow = New frmWhiteBoard
End If
WhiteBoardWindow.Show
Set moCallBack = WhiteBoardWindow
Case MsgAskToJoin
If gfHost Then
'We are the host, pop up the 'Ask to join dialog
dpPeer = dpp.GetPeerInfo(dpnotify.idSender)
Set frmJoin = New frmJoinRequest
frmJoin.SetupRequest Me, dpnotify.idSender, dpPeer.Name
frmJoin.Show vbModeless
End If
Case MsgAcceptJoin
'We have been accepted
'Enumerate all the players and add anyone we don't already have listed
UpdatePlayerList
If Not (ChatWindow Is Nothing) Then ChatWindow.LoadAllPlayers
ConnectVoice Me
Case MsgRejectJoin
'We have been rejected
tmrJoin.Enabled = True
'We need to use a timer here, without it, we would be attempting to cleanup
'our dplay objects to restart our host before this message was done being processed.
Case MsgShowChat
'Someone wants to chat. Open the chat window
If ChatWindow Is Nothing Then Set ChatWindow = New frmChat
ChatWindow.Show vbModeless
Set moCallBack = ChatWindow
Case MsgShowWhiteBoard
'Someone wants to draw. Open the whiteboard window
If WhiteBoardWindow Is Nothing Then Set WhiteBoardWindow = New frmWhiteBoard
WhiteBoardWindow.Show vbModeless
Set moCallBack = WhiteBoardWindow
Case MsgSendFileRequest
'Someone wants to send us a file. Should we accept?
dpPeer = dpp.GetPeerInfo(dpnotify.idSender)
GetDataFromBuffer .ReceivedData, lUnique, LenB(lUnique), lOffset
sFile = GetStringFromBuffer(.ReceivedData, lOffset)
LockReceiveCollection
Set f = New frmProgress
With f
.FileUniqueID = lUnique
.sFileName = sFile
.lDPlayID = dpnotify.idSender
Set .RequestForm = New frmTransferRequest
.RequestForm.SetupRequest Me, dpPeer.Name, .sFileName, .FileUniqueID, dpnotify.idSender
.RequestForm.Show vbModeless
End With
moReceivedFiles.Add f
UnlockReceiveCollection
Case MsgSendFileDeny
'We don't care about this file
GetDataFromBuffer .ReceivedData, lUnique, LenB(lUnique), lOffset
'Now remove this one
EraseSendFile lUnique
Case MsgSendFileAccept
'Ok, they do want us to send the file to them.. We will send it in chunks
'First we will send the file info
GetDataFromBuffer .ReceivedData, lUnique, LenB(lUnique), lOffset
'First we need to find the correct file in our send list
LockSendCollection
Set f = GetSendProgressForm(lUnique)
lNewOffSet = NewBuffer(oBuf)
lMsg = MsgSendFileInfo
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lNewOffSet
With f
.lFileSize = FileLen(.sFileName)
AddDataToBuffer oBuf, .FileUniqueID, SIZE_LONG, lNewOffSet
AddDataToBuffer oBuf, .lFileSize, SIZE_LONG, lNewOffSet
dpp.SendTo .lDPlayID, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
.SetFile .sFileName
.SetMax .lFileSize
.SetValue 0
.Show
End With
UnlockSendCollection
Case MsgSendFileInfo
'They just send us the file size, save it
GetDataFromBuffer .ReceivedData, lUnique, LenB(lUnique), lOffset
'First we need to find the correct file in our receive list
LockReceiveCollection
Set f = GetReceiveProgressForm(lUnique)
With f
GetDataFromBuffer dpnotify.ReceivedData, lFileSize, LenB(lFileSize), lOffset
.lFileSize = lFileSize
.SetFile .sFileName, True
.SetMax .lFileSize
.SetValue 0
.Show
End With
'Acknowledge that we received this part
lNewMsg = MsgAckFilePart
lNewOffSet = NewBuffer(oBuf)
AddDataToBuffer oBuf, lNewMsg, LenB(lNewMsg), lNewOffSet
AddDataToBuffer oBuf, lUnique, LenB(lUnique), lNewOffSet
dpp.SendTo dpnotify.idSender, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
UnlockReceiveCollection
Case MsgSendFilePart
'They just send us the file size, save it
GetDataFromBuffer .ReceivedData, lUnique, LenB(lUnique), lOffset
GetDataFromBuffer .ReceivedData, lChunkSize, LenB(lChunkSize), lOffset
'First we need to find the correct file in our receive list
LockReceiveCollection
Set f = GetReceiveProgressForm(lUnique)
With f
ReDim oData(1 To lChunkSize)
'We just received a file part.. Append this to our current file
If .filNumber = 0 Then
.filNumber = FreeFile
If Dir$(App.Path & "\" & .sFileName) <> vbNullString Then Kill App.Path & "\" & .sFileName
Open App.Path & "\" & .sFileName For Binary Access Write As #.filNumber
End If
GetDataFromBuffer dpnotify.ReceivedData, oData(1), lChunkSize, lOffset
Put #.filNumber, , oData
'Is this the end of the file?
.lCurrentPos = .lCurrentPos + lChunkSize
.SetValue .lCurrentPos
If .lCurrentPos >= .lFileSize Then
'We're done with the file
Close #.filNumber
EraseReceiveFile .FileUniqueID
Else
'Acknowledge that we received this part
lNewMsg = MsgAckFilePart
lNewOffSet = NewBuffer(oBuf)
AddDataToBuffer oBuf, lNewMsg, LenB(lNewMsg), lNewOffSet
AddDataToBuffer oBuf, lUnique, LenB(lUnique), lNewOffSet
dpp.SendTo dpnotify.idSender, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
End If
End With
UnlockReceiveCollection
Case MsgAckFilePart
GetDataFromBuffer .ReceivedData, lUnique, LenB(lUnique), lOffset
SendNextFilePart lUnique
Case MsgNewPlayerJoined
UpdatePlayerList 'Update our list here
If Not (ChatWindow Is Nothing) Then ChatWindow.LoadAllPlayers 'And in the chat window if we need to
End Select
End With
If (Not moCallBack Is Nothing) Then moCallBack.Receive dpnotify, fRejectMsg
End Sub
Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.SendComplete dpnotify, fRejectMsg
End Sub
Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
If (Not moCallBack Is Nothing) Then moCallBack.TerminateSession dpnotify, fRejectMsg
mfTerminate = True
tmrUpdate.Enabled = True
End Sub
Private Sub DirectPlayVoiceEvent8_ConnectResult(ByVal ResultCode As Long)
Dim lTargets(0) As Long
lTargets(0) = DVID_ALLPLAYERS
On Error Resume Next
'Connect the client
dvClient.SetTransmitTargets lTargets, 0
If Err.Number <> 0 And Err.Number <> DVERR_PENDING Then
mlVoiceError = Err.Number
tmrVoice.Enabled = True
Exit Sub
End If
End Sub
Private Sub DirectPlayVoiceEvent8_CreateVoicePlayer(ByVal playerID As Long, ByVal flags As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_DeleteVoicePlayer(ByVal playerID As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_DisconnectResult(ByVal ResultCode As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_HostMigrated(ByVal NewHostID As Long, ByVal NewServer As DxVBLibA.DirectPlayVoiceServer8)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_InputLevel(ByVal PeakLevel As Long, ByVal RecordVolume As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_OutputLevel(ByVal PeakLevel As Long, ByVal OutputVolume As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_PlayerOutputLevel(ByVal SourcePlayerID As Long, ByVal PeakLevel As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_PlayerVoiceStart(ByVal SourcePlayerID As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_PlayerVoiceStop(ByVal SourcePlayerID As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_RecordStart(ByVal PeakVolume As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_RecordStop(ByVal PeakVolume As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_SessionLost(ByVal ResultCode As Long)
'VB requires that we must implement *every* member of this interface
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmNetwork.frx Normal file
View File

Binary file not shown.

78
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmProgress.frm Normal file
View File

@@ -0,0 +1,78 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmProgress
BorderStyle = 3 'Fixed Dialog
Caption = "File Copy Progress"
ClientHeight = 1350
ClientLeft = 45
ClientTop = 330
ClientWidth = 3870
Icon = "frmProgress.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1350
ScaleWidth = 3870
StartUpPosition = 3 'Windows Default
Begin MSComctlLib.ProgressBar bar
Height = 375
Left = 60
TabIndex = 0
Top = 900
Width = 3675
_ExtentX = 6482
_ExtentY = 661
_Version = 393216
Appearance = 1
Scrolling = 1
End
Begin VB.Label lblFile
BackStyle = 0 'Transparent
Height = 735
Left = 60
TabIndex = 1
Top = 60
Width = 3675
End
End
Attribute VB_Name = "frmProgress"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmProgress.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
'This form will act both as the UI for the progress of file transfers as well
'as holding the information for the transfer
Public sFileName As String
Public lFileSize As Long
Public lDPlayID As Long
Public FileUniqueID As Long
Public lCurrentPos As Long
Public filNumber As Long
Public RequestForm As frmTransferRequest
Public Sub SetFile(ByVal sFile As String, Optional ByVal fReceive As Boolean = False)
If fReceive Then
lblFile.Caption = "Receiving: " & sFile
Else
lblFile.Caption = "Transfering: " & sFile
End If
End Sub
Public Sub SetMax(ByVal lMax As Long)
bar.Max = lMax
End Sub
Public Sub SetValue(ByVal lValue As Long)
bar.Value = lValue
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmProgress.frx Normal file
View File

Binary file not shown.

46
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmSplash.frm Normal file
View File

@@ -0,0 +1,46 @@
VERSION 5.00
Begin VB.Form frmSplash
BorderStyle = 0 'None
ClientHeight = 3675
ClientLeft = 0
ClientTop = 0
ClientWidth = 5970
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
Picture = "frmSplash.frx":0000
ScaleHeight = 3675
ScaleWidth = 5970
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin VB.Label Label1
BackStyle = 0 'Transparent
Height = 2175
Left = 3480
TabIndex = 0
Top = 120
Width = 2355
End
End
Attribute VB_Name = "frmSplash"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmSplash.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Form_Load()
Label1.Caption = "This sample will demonstrate how to create many of the features found in Netmeeting with Visual Basic and DirectX8." & _
vbCrLf & vbCrLf & vbCrLf & "Microsoft<66> Netmeeting<6E> is <20>Copyright Microsoft 1996-2001"
Me.Show
DoEvents
'Now wait for a short time
Sleep 1500
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmSplash.frx Normal file
View File

Binary file not shown.

111
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmTransferReq.frm Normal file
View File

@@ -0,0 +1,111 @@
VERSION 5.00
Begin VB.Form frmTransferRequest
BorderStyle = 3 'Fixed Dialog
Caption = "Receiving a file transfer...."
ClientHeight = 975
ClientLeft = 45
ClientTop = 330
ClientWidth = 4680
ControlBox = 0 'False
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 975
ScaleWidth = 4680
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdReject
Cancel = -1 'True
Caption = "Reject"
Height = 315
Left = 3420
TabIndex = 3
Top = 120
Width = 1155
End
Begin VB.CommandButton cmdAccept
Caption = "Accept"
Default = -1 'True
Height = 315
Left = 3420
TabIndex = 2
Top = 540
Width = 1155
End
Begin VB.Label lblFriend
BackStyle = 0 'Transparent
Height = 195
Left = 720
TabIndex = 1
Top = 420
Width = 2115
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "You are receiving a file transfer from"
Height = 195
Left = 720
TabIndex = 0
Top = 180
Width = 2115
End
Begin VB.Image Image1
Height = 480
Left = 120
Picture = "frmTransferReq.frx":0000
Top = 180
Width = 480
End
End
Attribute VB_Name = "frmTransferRequest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmTransferReq.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private msFile As String
Private mlUnique As Long
Private mlPlayerID As Long
Private moForm As frmNetwork
Public Sub SetupRequest(oForm As frmNetwork, ByVal sPlayerName As String, ByVal sFileName As String, ByVal lUniqueID As Long, ByVal lPlayer As Long)
Set moForm = oForm
msFile = sFileName
mlUnique = lUniqueID
mlPlayerID = lPlayer
lblFriend.Caption = sPlayerName & " (" & sFileName & ")"
End Sub
Private Sub cmdAccept_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Accept this connection
lMsg = MsgSendFileAccept
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, mlUnique, LenB(mlUnique), lOffset
dpp.SendTo mlPlayerID, oBuf, 0, DPNSEND_NOLOOPBACK
Unload Me
End Sub
Private Sub cmdReject_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Reject this connection
lMsg = MsgSendFileDeny
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, mlUnique, LenB(mlUnique), lOffset
dpp.SendTo mlPlayerID, oBuf, 0, DPNSEND_NOLOOPBACK
moForm.EraseReceiveFile mlUnique
Unload Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmTransferReq.frx Normal file
View File

Binary file not shown.

253
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmWhiteBoard.frm Normal file
View File

@@ -0,0 +1,253 @@
VERSION 5.00
Begin VB.Form frmWhiteBoard
Caption = "Whiteboard"
ClientHeight = 7200
ClientLeft = 60
ClientTop = 345
ClientWidth = 9600
Icon = "frmWhiteBoard.frx":0000
LinkTopic = "Form1"
ScaleHeight = 7200
ScaleWidth = 9600
StartUpPosition = 3 'Windows Default
Begin VB.PictureBox picDraw
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
Height = 7155
Left = 0
ScaleHeight = 7095
ScaleWidth = 9495
TabIndex = 0
Top = 0
Width = 9555
End
Begin VB.Menu Pop
Caption = "mnuPop"
Visible = 0 'False
Begin VB.Menu mnuRed
Caption = "Draw with Red"
End
Begin VB.Menu mnuBlue
Caption = "Draw with Blue"
End
Begin VB.Menu mnuGreen
Caption = "Draw with Green"
End
Begin VB.Menu mnuGrey
Caption = "Draw with Grey"
End
Begin VB.Menu mnuPurp
Caption = "Draw with Purple"
End
Begin VB.Menu mnuYellow
Caption = "Draw with Yellow"
End
Begin VB.Menu mnuSep
Caption = "-"
End
Begin VB.Menu mnuClear
Caption = "Clear Board"
End
End
End
Attribute VB_Name = "frmWhiteBoard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmWhiteBoard.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private mlColor As Long
Private mlLastX As Single: Private mlLastY As Single
Private Sub Form_Resize()
picDraw.Move 0, 0, Me.Width, Me.Height
End Sub
Private Sub mnuBlue_Click()
mlColor = RGB(0, 0, 255)
End Sub
Private Sub mnuClear_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
picDraw.Cls
'Send the clear msg
lOffset = NewBuffer(oBuf)
lMsg = MsgClearWhiteBoard
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
End Sub
Private Sub mnuGreen_Click()
mlColor = RGB(0, 255, 0)
End Sub
Private Sub mnuGrey_Click()
mlColor = RGB(128, 128, 128)
End Sub
Private Sub mnuPurp_Click()
mlColor = RGB(156, 56, 167)
End Sub
Private Sub mnuRed_Click()
mlColor = RGB(255, 0, 0)
End Sub
Private Sub mnuYellow_Click()
mlColor = RGB(255, 255, 0)
End Sub
Private Sub picDraw_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
If Button = vbLeftButton Then 'We are drawing
If mlColor = 0 Then mlColor = RGB(255, 0, 0)
'First draw the dot
picDraw.PSet (X, Y), mlColor
'Now tell everyone about it
'Now let's send a message to draw this dot
lOffset = NewBuffer(oBuf)
lMsg = MsgSendDrawPixel
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, mlColor, LenB(mlColor), lOffset
AddDataToBuffer oBuf, X, SIZE_SINGLE, lOffset
AddDataToBuffer oBuf, Y, SIZE_SINGLE, lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
'Now store the last x/y
mlLastX = X: mlLastY = Y
End If
End Sub
Private Sub picDraw_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
If Button = vbLeftButton Then 'We are drawing
If mlColor = 0 Then mlColor = RGB(255, 0, 0)
'First draw the dot
picDraw.Line (mlLastX, mlLastY)-(X, Y), mlColor
'Now tell everyone about it
'Now let's send a message to draw this line
lOffset = NewBuffer(oBuf)
lMsg = MsgSendDrawLine
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, mlColor, LenB(mlColor), lOffset
AddDataToBuffer oBuf, mlLastX, SIZE_SINGLE, lOffset
AddDataToBuffer oBuf, mlLastY, SIZE_SINGLE, lOffset
AddDataToBuffer oBuf, X, SIZE_SINGLE, lOffset
AddDataToBuffer oBuf, Y, SIZE_SINGLE, lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
'Now store the last x/y
mlLastX = X: mlLastY = Y
End If
End Sub
Private Sub picDraw_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then
PopupMenu Pop
End If
End Sub
Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
'All we care about in this form is what msgs we receive.
Dim lMsg As Long, lOffset As Long
Dim lColor As Long
Dim lX As Single, lY As Single
Dim lX1 As Single, lY1 As Single
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case MsgSendDrawPixel
GetDataFromBuffer .ReceivedData, lColor, LenB(lColor), lOffset
GetDataFromBuffer .ReceivedData, lX, LenB(lX), lOffset
GetDataFromBuffer .ReceivedData, lY, LenB(lY), lOffset
On Error Resume Next
picDraw.PSet (lX, lY), lColor
Case MsgSendDrawLine
GetDataFromBuffer .ReceivedData, lColor, LenB(lColor), lOffset
GetDataFromBuffer .ReceivedData, lX, LenB(lX), lOffset
GetDataFromBuffer .ReceivedData, lY, LenB(lY), lOffset
GetDataFromBuffer .ReceivedData, lX1, LenB(lX), lOffset
GetDataFromBuffer .ReceivedData, lY1, LenB(lY), lOffset
On Error Resume Next
picDraw.Line (lX, lY)-(lX1, lY1), lColor
Case MsgClearWhiteBoard
picDraw.Cls
End Select
End With
End Sub
Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/frmWhiteBoard.frx Normal file
View File

Binary file not shown.

328
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/modDplay.bas Normal file
View File

@@ -0,0 +1,328 @@
Attribute VB_Name = "modDplay"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Here are all of the messages we can transfer in this app
Public Enum vbMsgType
MsgChat 'We are talking in the chat channel
MsgWhisper 'We are whispering to someone in the chat channel
MsgAskToJoin 'We want to ask if we can join this session
MsgAcceptJoin 'Accept the call
MsgRejectJoin 'Reject the call
MsgCancelCall 'Cancel the call
MsgShowChat 'Show the chat window
MsgSendFileRequest 'Request a file transfer
MsgSendFileAccept 'Accept the file transfer
MsgSendFileDeny 'Deny the file transfer
MsgSendFileInfo 'File information (size)
MsgSendFilePart 'Send a chunk of the file
MsgAckFilePart 'Acknowledge the file part
MsgSendDrawPixel 'Send a drawn pixel
MsgSendDrawLine 'Send a drawn line
MsgShowWhiteBoard 'Show the whiteboard window
MsgClearWhiteBoard 'Clear the contents of the whiteboard
MsgNewPlayerJoined 'A new player has joined our session
End Enum
'Win32 declares
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Sub InitializeCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)
Public Declare Sub LeaveCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)
Public Declare Sub EnterCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)
Public Declare Sub DeleteCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION)
Public Type CRITICAL_SECTION
DebugInfo As Long
LockCount As Long
RecursionCount As Long
OwningThread As Long
LockSemaphore As Long
SpinCount As Long
End Type
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
sTip As String * 64
End Type
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIF_DOALL = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONUP = &H205
'Constants
Public Const AppGuid = "{9073823A-A565-4865-87EC-19B93B014D27}"
Public Const glDefaultPort As Long = 9897
'DirectX variables
Public dx As DirectX8
Public dpp As DirectPlay8Peer
Public dvClient As DirectPlayVoiceClient8
Public dvServer As DirectPlayVoiceServer8
'Window variables for this app
Public ChatWindow As frmChat
Public WhiteBoardWindow As frmWhiteBoard
Public NetWorkForm As frmNetwork
'Misc app variables
Public sysIcon As NOTIFYICONDATA
Public gsUserName As String
Public glAsyncEnum As Long
Public glMyPlayerID As Long
Public glHostPlayerID As Long
Public gfHost As Boolean
Public gfNoVoice As Boolean
Public goSendFile As CRITICAL_SECTION
Public goReceiveFile As CRITICAL_SECTION
Public Sub Main()
If App.PrevInstance Then
'We can only run one instance of this sample per machine since we
'specify a port to run this application on. Only one application can
'be listening (hosting) on a particular port at any given time.
MsgBox "Only one instance of vbConferencer may be run at a time.", vbOKOnly Or vbInformation, "Only one"
Exit Sub
End If
Screen.MousePointer = vbHourglass
'Show the splash screen
frmSplash.Show
'Set our username up
gsUserName = GetSetting("VBDirectPlay", "Defaults", "UserName", vbNullString)
If gsUserName = vbNullString Then
'If there is not a default username, then pick the currently
'logged on username
gsUserName = Space$(255)
GetUserName gsUserName, 255
gsUserName = Left$(gsUserName, InStr(gsUserName, Chr$(0)) - 1)
End If
'Start the host
Set NetWorkForm = New frmNetwork
Load NetWorkForm
'We don't need it anymore
Unload frmSplash
Screen.MousePointer = vbNormal
NetWorkForm.Show vbModeless
InitializeCriticalSection goSendFile
InitializeCriticalSection goReceiveFile
End Sub
Public Sub InitDPlay()
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
End Sub
Public Sub Cleanup()
On Error Resume Next
'We might have references for the chat and whiteboard windows
'Get rid of them
Set ChatWindow = Nothing
Set WhiteBoardWindow = Nothing
'Disconnect and destroy the client
If Not (dvClient Is Nothing) Then
dvClient.UnRegisterMessageHandler
dvClient.Disconnect DVFLAGS_SYNC
Set dvClient = Nothing
End If
'Stop and Destroy the server
If Not (dvServer Is Nothing) Then
dvServer.UnRegisterMessageHandler
dvServer.StopSession 0
Set dvServer = Nothing
End If
'Now the main session
If Not (dpp Is Nothing) Then
dpp.UnRegisterMessageHandler
'Close our peer connection
dpp.Close
'Lose references to peer object
Set dpp = Nothing
End If
'Lose references to dx object
Set dx = Nothing
DoSleep 500
End Sub
Public Sub StartHosting(MsgForm As Form)
Dim dpa As DirectPlay8Address
Dim oPlayer As DPN_PLAYER_INFO
Dim oAppDesc As DPN_APPLICATION_DESC
'Make sure we're ready to host
Cleanup
InitDPlay
NetWorkForm.cmdHangup.Enabled = False
NetWorkForm.cmdCall.Enabled = True
gfHost = True
'Register the Message Handler
dpp.RegisterMessageHandler MsgForm
'Set the peer info
oPlayer.lInfoFlags = DPNINFO_NAME
oPlayer.Name = gsUserName
dpp.SetPeerInfo oPlayer, DPNOP_SYNC
'Create an address
Set dpa = dx.DirectPlayAddressCreate
'We will only be connecting via TCP/IP
dpa.SetSP DP8SP_TCPIP
dpa.AddComponentLong DPN_KEY_PORT, glDefaultPort
'First set up our application description
With oAppDesc
.guidApplication = AppGuid
.lMaxPlayers = 10 'We don't want to overcrowd our 'room'
.lFlags = DPNSESSION_NODPNSVR
End With
'Start our host
dpp.Host oAppDesc, dpa
Set dpa = Nothing
'After we've created the session and let's start
'the DplayVoice server
Dim oSession As DVSESSIONDESC
'Create our DPlayVoice Server
Set dvServer = dx.DirectPlayVoiceServerCreate
'Set up the Session
oSession.lBufferAggressiveness = DVBUFFERAGGRESSIVENESS_DEFAULT
oSession.lBufferQuality = DVBUFFERQUALITY_DEFAULT
oSession.lSessionType = DVSESSIONTYPE_PEER
oSession.guidCT = vbNullString
'Init and start the session
dvServer.Initialize dpp, 0
dvServer.StartSession oSession, 0
ConnectVoice MsgForm
Set dpa = Nothing
End Sub
Public Sub Connect(MsgForm As Form, ByVal sHost As String)
Dim dpa As DirectPlay8Address
Dim dpl As DirectPlay8Address
Dim oPlayer As DPN_PLAYER_INFO
Dim oAppDesc As DPN_APPLICATION_DESC
'Try to connect to the host
'Make sure we're ready to connect
Cleanup
InitDPlay
NetWorkForm.cmdCall.Enabled = False
gfHost = False
'Register the Message Handler
dpp.RegisterMessageHandler MsgForm
'Set the peer info
oPlayer.lInfoFlags = DPNINFO_NAME
oPlayer.Name = gsUserName
dpp.SetPeerInfo oPlayer, DPNOP_SYNC
'Now try to enum hosts
'Create an address
Set dpa = dx.DirectPlayAddressCreate
'We will only be connecting via TCP/IP
dpa.SetSP DP8SP_TCPIP
dpa.AddComponentString DPN_KEY_HOSTNAME, sHost 'We will try to connect to this host
dpa.AddComponentLong DPN_KEY_PORT, glDefaultPort
Set dpl = dx.DirectPlayAddressCreate
'We will only be connecting via TCP/IP
dpl.SetSP DP8SP_TCPIP
'First set up our application description
With oAppDesc
.guidApplication = AppGuid
End With
'Try to connect to this host
On Error Resume Next
DoSleep 500 'Give a slight pause to clean up any loose ends
dpp.Connect oAppDesc, dpa, dpl, 0, ByVal 0&, 0
If Err.Number <> 0 Then 'Woah, an error
MsgBox "There was an error trying to connect to this machine.", vbOKOnly Or vbInformation, "Unavailable"
StartHosting MsgForm
End If
Set dpa = Nothing
Set dpl = Nothing
End Sub
Public Sub ConnectVoice(MsgForm As Form)
Dim oSound As DVSOUNDDEVICECONFIG
Dim oClient As DVCLIENTCONFIG
'Make sure we haven't determined there would be no voice in this app
If gfNoVoice Then Exit Sub
'Now create a client as well (so we can both talk and listen)
Set dvClient = dx.DirectPlayVoiceClientCreate
'Now let's create a client event..
dvClient.Initialize dpp, 0
dvClient.StartClientNotification MsgForm
'Set up our client and sound structs
oClient.lFlags = DVCLIENTCONFIG_AUTOVOICEACTIVATED Or DVCLIENTCONFIG_AUTORECORDVOLUME
oClient.lBufferAggressiveness = DVBUFFERAGGRESSIVENESS_DEFAULT
oClient.lBufferQuality = DVBUFFERQUALITY_DEFAULT
oClient.lNotifyPeriod = 0
oClient.lThreshold = DVTHRESHOLD_UNUSED
oClient.lPlaybackVolume = DVPLAYBACKVOLUME_DEFAULT
oSound.hwndAppWindow = NetWorkForm.hwnd
On Error Resume Next
'Connect the client
dvClient.Connect oSound, oClient, 0
If Err.Number = DVERR_RUN_SETUP Then 'The audio tests have not been run on this
'machine. Run them now.
'we need to run setup first
Dim dvSetup As DirectPlayVoiceTest8
Set dvSetup = dx.DirectPlayVoiceTestCreate
dvSetup.CheckAudioSetup vbNullString, vbNullString, NetWorkForm.hwnd, 0 'Check the default devices since that's what we'll be using
If Err.Number = DVERR_COMMANDALREADYPENDING Then
MsgBox "Could not start DirectPlayVoice. The Voice Networking wizard is already open. This sample will not have any voice capablities.", vbOKOnly Or vbInformation, "No Voice"
gfNoVoice = True
NetWorkForm.chkVoice.Value = vbUnchecked
NetWorkForm.chkVoice.Enabled = False
Exit Sub
End If
If Err.Number = DVERR_USERCANCEL Then
MsgBox "Could not start DirectPlayVoice. The Voice Networking wizard was cancelled. This sample will not have any voice capablities.", vbOKOnly Or vbInformation, "No Voice"
gfNoVoice = True
NetWorkForm.chkVoice.Value = vbUnchecked
NetWorkForm.chkVoice.Enabled = False
Exit Sub
End If
Set dvSetup = Nothing
dvClient.Connect oSound, oClient, 0
ElseIf Err.Number <> 0 And Err.Number <> DVERR_PENDING Then
MsgBox "Could not start DirectPlayVoice. This sample will not have any voice capablities." & vbCrLf & "Error:" & CStr(Err.Number), vbOKOnly Or vbInformation, "No Voice"
gfNoVoice = True
NetWorkForm.chkVoice.Value = vbUnchecked
NetWorkForm.chkVoice.Enabled = False
Exit Sub
End If
On Error GoTo 0
End Sub
Public Sub DoSleep(ByVal lNumMS As Long)
Dim lCount As Long
For lCount = 1 To lNumMS \ 5
Sleep 5
DoEvents
Next
End Sub

68
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/readme.txt Normal file
View File

@@ -0,0 +1,68 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Conferencer Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
Conferencer is similar in form to MS Netmeeting (tm).
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Conferencer
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
You may 'call' friends in this application, and then share files,
share a whiteboard, use voice chat, and text chat.
Programming Notes
=================
Here are the messages this application responds to:
MsgChat - This message is received when someone is chatting (text) in
the chat window.
MsgWhisper - This message is received when someone is whispering (text) in
the chat window.
MsgAskToJoin - When a user attempts to contact you, this message is sent,
which will pop up a dialog that enables the person receiving the
event the opportunity to deny this person from joining.
MsgAcceptJoin - You will to allow this person to join your session.
MsgRejectJoin - You will not allow this person to join your session.
MsgCancelCall - You no longer want to wait for the session you are attempting to
join to either accept or deny you.
MsgShowChat - Someone has opened the text chat window, and wants this session to
do the same.
MsgSendFileRequest - Request a file transfer
MsgSendFileAccept - Accept the file transfer
MsgSendFileDeny - Deny the file transfer
MsgSendFileInfo - File information (size)
MsgSendFilePart - Send a chunk of the file
MsgAckFilePart - Acknowledge the file part
MsgSendDrawPixel - Send a drawn pixel (in the whiteboard window, including color)
MsgSendDrawLine - Send a drawn line (in the whiteboard window, including color)
MsgShowWhiteBoard - Show the whiteboard window
MsgClearWhiteBoard - Clear the contents of the whiteboard

42
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Conferencer/vb_Conferencer.vbp Normal file
View File

@@ -0,0 +1,42 @@
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#stdole2.tlb#OLE Automation
Reference=*\G{E1211242-8E94-11D1-8808-00C04FC2C603}#1.0#0#dx8vb.dll#DirectX 8 for Visual Basic Type Library
Form=frmNetwork.frm
Module=modDplay; modDplay.bas
Form=frmSplash.frm
Form=frmChat.frm
Form=frmJoinRequest.frm
Object={F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0; comdlg32.ocx
Form=frmTransferReq.frm
Form=frmProgress.frm
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; Mscomctl.ocx
Form=frmWhiteBoard.frm
IconForm="frmNetwork"
Startup="Sub Main"
HelpFile=""
Title="vb_Conferencer"
Command32=""
Name="vbConferencer"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1