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

287
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Chat/frmChat.frm Normal file
View File

@@ -0,0 +1,287 @@
VERSION 5.00
Begin VB.Form frmChat
BorderStyle = 3 'Fixed Dialog
Caption = "vbDirectPlay Chat"
ClientHeight = 5085
ClientLeft = 45
ClientTop = 330
ClientWidth = 7695
Icon = "frmChat.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5085
ScaleWidth = 7695
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdWhisper
Caption = "Whisper"
Height = 255
Left = 5820
TabIndex = 3
Top = 4740
Width = 1695
End
Begin VB.TextBox txtSend
Height = 285
Left = 60
TabIndex = 0
Top = 4740
Width = 5595
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 = 3 'Both
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()
'Oh good, we want to play a multiplayer game.
'First lets get the dplay connection started
'Here we will init our DPlay objects
InitDPlay
'Now we can create a new Connection Form (which will also be our message pump)
Set DPlayEventsForm = New DPlayConnect
'Start the connection form (it will either create or join a session)
If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 20, Me) Then
Cleanup
End
Else 'We did choose to play a game
gsUserName = DPlayEventsForm.UserName
If DPlayEventsForm.IsHost Then
Me.Caption = Me.Caption & " (HOST)"
End If
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.Hide
DPlayEventsForm.DoSleep 50
Cleanup
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
If txtSend.Text <> vbNullString Then 'Make sure they are trying to send something
'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
KeyAscii = 0
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
UpdateChat "<" & gsUserName & ">" & sChatMsg
End If 'We won't set KeyAscii to 0 here, because if they are trying to
'send blank data, we don't care about the ding for hitting enter on
'an empty line
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
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)
If dpnotify.hResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
End If
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)
Dim dpPeer As DPN_PLAYER_INFO
dpPeer = dpp.GetPeerInfo(lPlayerID)
'Add this person to chat (even if it's me)
lstUsers.AddItem dpPeer.Name
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) <> DPNPLAYER_LOCAL Then 'this isn't me, someone just joined
UpdateChat "- " & dpPeer.Name & " is chatting"
'If it's not me, include an ItemData
lstUsers.ItemData(lstUsers.ListCount - 1) = lPlayerID
End If
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) & " is no longer chatting."
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)
Dim dpPeer As DPN_PLAYER_INFO
dpPeer = dpp.GetPeerInfo(lNewHostID)
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then 'I am the new host
Me.Caption = Me.Caption & " (HOST)"
End If
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.
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)
If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
MsgBox "The host has terminated this session. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
Else
MsgBox "This session has been lost. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
End If
DPlayEventsForm.CloseForm Me
End Sub

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

Binary file not shown.

48
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Chat/modDplay.bas Normal file
View File

@@ -0,0 +1,48 @@
Attribute VB_Name = "modDplay"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDplay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Enum vbDplayChatMsgType
MsgChat
MsgWhisper
End Enum
'Constants
Public Const AppGuid = "{EABD4D9B-6AA9-4c24-9D10-1A6701B07342}"
Public dx As DirectX8
Public dpp As DirectPlay8Peer
'App specific variables
Public gsUserName As String
'Our connection form and message pump
Public DPlayEventsForm As DPlayConnect
Public Sub InitDPlay()
'Create our DX/DirectPlay objects
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
End Sub
Public Sub Cleanup()
If Not (DPlayEventsForm Is Nothing) Then
If Not (dpp Is Nothing) Then dpp.UnRegisterMessageHandler
'Get rid of our message pump
DPlayEventsForm.GoUnload
'Close down our session
If Not (dpp Is Nothing) Then dpp.Close
DPlayEventsForm.DoSleep 50
'Lose references to peer and dx objects
Set dpp = Nothing
Set dx = Nothing
End If
Set DPlayEventsForm = Nothing
End Sub

56
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Chat/readme.txt Normal file
View File

@@ -0,0 +1,56 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Chat Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
Chat is similar in form to SimplePeer. Once a player hosts or connects
to a session, the players can chat with either other by passing text
strings.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Chat
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Refer to User's Guide section of the SimplePeer sample.
Programming Notes
=================
The ChatPeer sample is very similar in form to the SimplePeer sample. For
detailed programming notes on the basics this sample, refer to Programming
Notes section of the SimplePeer sample.
The ChatPeer differs by letting clients send text strings to all players
connected to the session.
* The <Enter> key is pressed. See txtSend_KeyPress.
1. Retrieves the text string from the dialog.
2. Fills out a byte array using the string.
3. Calls DirectPlay8Peer.SendTo with the byte array. It passes
DPNID_ALL_PLAYERS_GROUP so this message goes to everyone.
* The "Whisper" button is pressed. See cmdWhisper_Click.
1. Retrieves the text string from the dialog.
2. Fills out a byte array using the string.
3. Calls DirectPlay8Peer.SendTo with the byte array. It passes
the DPNID of the player so this message only goes to the person you
are whispering too.
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
The Chat sample handles the typical messages as described in the
SimplePeer programming notes, and in addition:
- Upon Receive event:
*Checks if this is a chat message or a whisper message.
*Retrieve the string from the byte array we receive.
*Update the UI accordingly.

34
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Chat/vb_Chat.vbp Normal file
View File

@@ -0,0 +1,34 @@
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=frmChat.frm
Form=..\..\common\DplayCon.frm
Module=modDplay; modDplay.bas
IconForm="frmChat"
Startup="frmChat"
ExeName32="vb_Chat.exe"
Command32=""
Name="vbChat"
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

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

591
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmClient.frm Normal file
View File

@@ -0,0 +1,591 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmClient
BorderStyle = 3 'Fixed Dialog
Caption = "vbMessenger Service (Not logged in)"
ClientHeight = 4740
ClientLeft = 150
ClientTop = 720
ClientWidth = 4170
Icon = "frmClient.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4740
ScaleWidth = 4170
StartUpPosition = 3 'Windows Default
Begin VB.Timer tmrUpdate
Enabled = 0 'False
Interval = 50
Left = 4650
Top = 2700
End
Begin VB.Timer tmrExit
Interval = 50
Left = 8100
Top = 840
End
Begin MSComctlLib.ImageList imlTree
Left = 4680
Top = 1140
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 2
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClient.frx":030A
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClient.frx":0C34
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.TreeView tvwFriends
Height = 4695
Left = 0
TabIndex = 0
Top = 0
Width = 4155
_ExtentX = 7329
_ExtentY = 8281
_Version = 393217
Indentation = 88
LabelEdit = 1
Style = 7
ImageList = "imlTree"
Appearance = 1
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuLogon
Caption = "&Log on..."
Shortcut = ^L
End
Begin VB.Menu mnuLogoff
Caption = "Lo&g Off"
Shortcut = ^X
End
Begin VB.Menu mnuSep
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "E&xit"
End
End
Begin VB.Menu mnuOptions
Caption = "&Options"
Begin VB.Menu mnuAddFriend
Caption = "&Add Friend..."
Shortcut = ^A
End
Begin VB.Menu mnuBlock
Caption = "&Block User..."
Shortcut = ^B
End
Begin VB.Menu mnuSep1
Caption = "-"
End
Begin VB.Menu mnuSendIM
Caption = "&Send Message..."
Shortcut = ^S
End
End
Begin VB.Menu mnuPop
Caption = "pop"
Visible = 0 'False
Begin VB.Menu mnuSend
Caption = "Send Message"
End
End
Begin VB.Menu mnuPopTray
Caption = "pop2"
Visible = 0 'False
Begin VB.Menu mnuExitTray
Caption = "E&xit"
End
End
End
Attribute VB_Name = "frmClient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmClient.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private Const msAppTitle As String = "vbMessenger Service"
Private mfExit As Boolean
Private oLog As frmLogin
Private oLeafOnline As Node
Private oLeafOffline As Node
Private oMsgWnd() As frmMsgTemplate
Private mfServerExit As Boolean
Private Sub Form_Load()
'Initialize DirectPlay
Set gofrmClient = Me
InitDPlay
'Lets put an icon in the system tray
With sysIcon
.cbSize = LenB(sysIcon)
.hwnd = Me.hwnd
.uFlags = NIF_DOALL
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.sTip = msAppTitle & " - Not logged in." & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, sysIcon
SetupDefaultTree
EnableLoggedinUI False
EnableSendUI False
Me.Caption = msAppTitle & " - Not logged in."
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
Me.Visible = True
Me.SetFocus
Case WM_RBUTTONUP
PopupMenu mnuPopTray
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 lCount As Long
'Cleanup the DPlay objects
Cleanup
'Remove all the forms
On Error Resume Next
Dim lNum As Long
lNum = UBound(oMsgWnd)
For lCount = 0 To lNum
Unload oMsgWnd(lCount)
Set oMsgWnd(lCount) = Nothing
Next
Erase oMsgWnd
'Remove the icon from the system tray
Shell_NotifyIcon NIM_DELETE, sysIcon
End Sub
Private Sub mnuAddFriend_Click()
'Let's get the name of the friend we want to add
Dim sFriend As String
sFriend = InputBox("Please enter the name of the friend you wish to add", "Add Friend")
If sFriend = vbNullString Then
'nothing was entered
MsgBox "You must enter a friends name to add one.", vbOKOnly Or vbInformation, "Nothing entered."
Exit Sub
ElseIf sFriend = gsUserName Then
'Entered our own name
MsgBox "Everyone wants to be friends with themselves, but in this sample, it's not allowed.", vbOKOnly Or vbInformation, "Don't enter your name."
Exit Sub
End If
'Ok, let's add the friend
AddFriend sFriend
End Sub
Private Sub mnuBlock_Click()
'Let's get the name of the friend we want to block
Dim sFriend As String
sFriend = InputBox("Please enter the name of the user you wish to block", "Block user")
If sFriend = vbNullString Then
'nothing was entered
MsgBox "You must enter a user name to block one.", vbOKOnly Or vbInformation, "Nothing entered."
Exit Sub
ElseIf sFriend = gsUserName Then
'Entered our own name
MsgBox "Why would you want to block yourself?.", vbOKOnly Or vbInformation, "Don't enter your name."
Exit Sub
End If
'Ok, let's add the friend
BlockUser sFriend
End Sub
Private Sub mnuExit_Click()
mfExit = True
Unload Me
End Sub
Private Sub mnuExitTray_Click()
mnuExit_Click
End Sub
Private Sub mnuLogoff_Click()
EnableLoggedinUI False
gfConnected = False
gfCreatePlayer = False
gfLoggedIn = False
gsUserName = vbNullString
gsPass = vbNullString
gsServerName = vbNullString
Me.Caption = "vbMessenger Service (Not logged in)"
UpdateText "vbMessenger Service (Not logged in)"
SetupDefaultTree
'Initialize DirectPlay
InitDPlay
End Sub
Private Sub mnuLogon_Click()
'They want to log on, show the logon screen
Set oLog = New frmLogin
oLog.Show , Me
End Sub
Private Sub EnableLoggedinUI(ByVal fEnable As Boolean)
mnuAddFriend.Enabled = fEnable
mnuBlock.Enabled = fEnable
mnuLogoff.Enabled = fEnable
mnuLogon.Enabled = Not fEnable
End Sub
Private Sub EnableSendUI(ByVal fEnable As Boolean)
mnuSend.Enabled = fEnable
mnuSendIM.Enabled = fEnable
End Sub
Private Sub mnuSend_Click()
mnuSendIM_Click 'Go ahead and send a message
End Sub
Private Sub mnuSendIM_Click()
Dim frm As frmMsgTemplate
If InStr(tvwFriends.SelectedItem.Text, " ") > 0 Then
Set frm = GetMsgWindow(Left$(tvwFriends.SelectedItem.Text, InStr(tvwFriends.SelectedItem.Text, " ") - 1))
frm.UserName = Left$(tvwFriends.SelectedItem.Text, InStr(tvwFriends.SelectedItem.Text, " ") - 1)
Else
Set frm = GetMsgWindow(tvwFriends.SelectedItem.Text)
frm.UserName = tvwFriends.SelectedItem.Text
End If
frm.Show
frm.SetFocus
End Sub
Private Sub tmrExit_Timer()
If mfServerExit Then 'Gotta quit now
tmrExit.Enabled = False
MsgBox "The server has disconnected. This session will now end.", vbOKOnly Or vbInformation, "Exiting..."
mfExit = True
Unload Me
End
End If
End Sub
Private Sub tmrUpdate_Timer()
tmrUpdate.Enabled = False
If gfCreatePlayer Then
CreatePlayer 'We're creating a player
Else
LogonPlayer 'We're just logging in
End If
End Sub
Private Sub tvwFriends_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim oNode As Node
If Button = vbRightButton Then 'They right clicked, should we show the menu?
If tvwFriends.SelectedItem.Parent Is Nothing Then
Set oNode = oLeafOffline
Else
Set oNode = tvwFriends.SelectedItem
End If
If (oNode.Children = 0) And oNode <> oLeafOffline Then
PopupMenu mnuPop
End If
End If
End Sub
Private Sub tvwFriends_NodeClick(ByVal Node As MSComctlLib.Node)
Dim oNode As Node
If Node.Parent Is Nothing Then
Set oNode = oLeafOffline
Else
Set oNode = Node
End If
If (oNode.Children = 0) And oNode <> oLeafOffline Then
EnableSendUI True
Else
EnableSendUI False
End If
End Sub
Private Sub UpdateText(sNewText As String)
'modify our icon text
sysIcon.sTip = sNewText & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
End Sub
Private Function GetMsgWindow(ByVal sUser As String) As frmMsgTemplate
'Let's check to see if there is a window open
Dim lCount As Long, lNumWindows As Long
On Error Resume Next
lNumWindows = UBound(oMsgWnd)
If Err = 0 Then
For lCount = 0 To lNumWindows
If Not (oMsgWnd(lCount) Is Nothing) Then
If sUser = oMsgWnd(lCount).UserName Then
Set GetMsgWindow = oMsgWnd(lCount)
Exit Function
End If
End If
Next
ReDim Preserve oMsgWnd(lNumWindows + 1)
Set oMsgWnd(lNumWindows + 1) = New frmMsgTemplate
Set GetMsgWindow = oMsgWnd(lNumWindows + 1)
Else
ReDim oMsgWnd(0)
Set oMsgWnd(0) = New frmMsgTemplate
Set GetMsgWindow = oMsgWnd(0)
End If
End Function
Private Sub SetupDefaultTree()
'Clear the tree first
tvwFriends.Nodes.Clear
'Let's add the two default icons into our treeview
Set oLeafOnline = tvwFriends.Nodes.Add(, , "OnlineLeafKey", "Friends online", 1, 1)
Set oLeafOffline = tvwFriends.Nodes.Add(, , "OfflineLeafKey", "Friends offline", 2, 2)
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)
If dpnotify.hResultCode <> 0 Then
MsgBox "The server does not exist or is unavailable.", vbOKOnly Or vbInformation, "Unavailable"
Else
tmrUpdate.Enabled = True
End If
gfConnected = True
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)
'We need to get each message we receive from the server, process it, and respond accordingly
Dim lMsg As Long, lOffset As Long
Dim oNewMsg() As Byte, lNewOffSet As Long
Dim sUsername As String, lNumFriends As Long, lCount As Long
Dim lNewMsg As Long, oNode As Node
Dim sChat As String, fChatFrm As frmMsgTemplate
Dim fFriend As Boolean, fFound As Boolean
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg 'The client will only receive certain messages. Handle those.
Case Msg_LoginSuccess 'Login successfully completed.
'All we really need to do is get rid of the login screen.
If Not (oLog Is Nothing) Then
Unload oLog
Set oLog = Nothing
End If
Unload frmCreate
gfLoggedIn = True
EnableLoggedinUI True
Me.Caption = msAppTitle & " - (" & gsUserName & ")"
UpdateText msAppTitle & " - (" & gsUserName & ")"
Case Msg_InvalidPassword 'The server didn't like our password
'The password they entered was invalid.
MsgBox "The password you entered was invalid.", vbOKOnly Or vbInformation, "Not valid."
oLog.cmdLogin.Enabled = True
oLog.txtPassword = vbNullString
oLog.txtPassword.SetFocus
Case Msg_InvalidUser 'We do not exist on this server
'This user does not exist
MsgBox "The username you entered does not exist.", vbOKOnly Or vbInformation, "Not valid."
oLog.cmdLogin.Enabled = True
Case Msg_UserAlreadyExists 'We can't create this account since the user exists
'This user already exists
MsgBox "The username you entered already exists." & vbCrLf & "You must choose a different one.", vbOKOnly Or vbInformation, "Not valid."
frmCreate.cmdLogin.Enabled = True
Case Msg_SendClientFriends 'The server is going to send us a list of our current friends
GetDataFromBuffer .ReceivedData, lNumFriends, LenB(lNumFriends), lOffset
'Ok, now go through and add each friend to our 'offline' list (The server will notify who is online after this message
For lCount = 1 To lNumFriends
GetDataFromBuffer .ReceivedData, fFriend, LenB(fFriend), lOffset
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
'Add this user to our list
If fFriend Then
tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername, 2, 2
Else
tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername & " (BLOCKED)", 2, 2
End If
Next
oLeafOffline.Expanded = True
oLeafOnline.Expanded = True
Case Msg_FriendAdded
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
fFound = False
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername Then
oNode.Text = sUsername
fFound = True
End If
Next
If Not fFound Then tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername, 2, 2
'Friend added successfully
MsgBox sUsername & " added successfully to your friends list.", vbOKOnly Or vbInformation, "Added."
Case Msg_FriendBlocked
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
fFound = False
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername Then
oNode.Text = sUsername & " (BLOCKED)"
fFound = True
End If
Next
If Not fFound Then tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername & " (BLOCKED)", 2, 2
'Friend blocked successfully
MsgBox sUsername & " added successfully to your blocked list.", vbOKOnly Or vbInformation, "Added."
Case Msg_FriendDoesNotExist
'Friend doesn't exist
MsgBox "You cannot add this friend, since they do not exist.", vbOKOnly Or vbInformation, "Unknown."
Case Msg_BlockUserDoesNotExist
'Friend doesn't exist
MsgBox "You cannot block this user, since they do not exist.", vbOKOnly Or vbInformation, "Unknown."
Case Msg_FriendLogon
'We need to go through each of the current nodes and see if this is that friend
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername And oNode.Children = 0 Then
oNode.Image = 1: oNode.SelectedImage = 1
Set oNode.Parent = oLeafOnline
End If
Next
Case Msg_FriendLogoff
'We need to go through each of the current nodes and see if this is that friend
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername And oNode.Children = 0 Then
oNode.Image = 2: oNode.SelectedImage = 2
Set oNode.Parent = oLeafOffline
End If
Next
Case Msg_ReceiveMessage
'We need to go through each of the current forms and see if this is friend is loaded
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
sChat = GetStringFromBuffer(.ReceivedData, lOffset)
Set fChatFrm = GetMsgWindow(sUsername)
fChatFrm.UserName = sUsername
fChatFrm.Show
fChatFrm.SetFocus
fChatFrm.AddChatMessage sChat
Case Msg_UserBlocked
'This user has blocked me
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
Set fChatFrm = GetMsgWindow(sUsername)
fChatFrm.UserName = sUsername
fChatFrm.Show
fChatFrm.SetFocus
fChatFrm.AddChatMessage "Your message to " & sUsername & " could not be delivered since they have blocked you.", , True
Case Msg_UserUnavailable
'This user is no longer available
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
sChat = GetStringFromBuffer(.ReceivedData, lOffset)
Set fChatFrm = GetMsgWindow(sUsername)
fChatFrm.UserName = sUsername
fChatFrm.Show
fChatFrm.SetFocus
fChatFrm.AddChatMessage "Your message: " & vbCrLf & sChat & vbCrLf & "to " & sUsername & " could not be delivered since they are no longer available.", , True
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)
'We're no longer connected for some reason.
mfServerExit = True
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmClient.frx Normal file
View File

Binary file not shown.

194
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmCreate.frm Normal file
View File

@@ -0,0 +1,194 @@
VERSION 5.00
Begin VB.Form frmCreate
BorderStyle = 4 'Fixed ToolWindow
Caption = "Create a new account"
ClientHeight = 3585
ClientLeft = 45
ClientTop = 285
ClientWidth = 4680
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3585
ScaleWidth = 4680
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.TextBox txtVerify
Height = 285
IMEMode = 3 'DISABLE
Left = 60
PasswordChar = "*"
TabIndex = 2
Top = 2100
Width = 4515
End
Begin VB.TextBox txtUserName
Height = 285
Left = 60
TabIndex = 0
Top = 900
Width = 4515
End
Begin VB.TextBox txtPassword
Height = 285
IMEMode = 3 'DISABLE
Left = 60
PasswordChar = "*"
TabIndex = 1
Top = 1500
Width = 4515
End
Begin VB.TextBox txtServerName
Height = 285
Left = 60
TabIndex = 3
Top = 2700
Width = 4515
End
Begin VB.CommandButton cmdLogin
Caption = "Create"
Default = -1 'True
Height = 375
Left = 3600
TabIndex = 5
Top = 3120
Width = 1035
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Cancel"
Height = 375
Left = 2520
TabIndex = 4
Top = 3120
Width = 1035
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Verify Password:"
Height = 195
Index = 4
Left = 60
TabIndex = 10
Top = 1860
Width = 2955
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "UserName:"
Height = 195
Index = 1
Left = 60
TabIndex = 9
Top = 660
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Password:"
Height = 195
Index = 2
Left = 60
TabIndex = 8
Top = 1260
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Please type in your username, password and server to connect to, or click the 'Create Account' button..."
Height = 495
Index = 0
Left = 60
TabIndex = 7
Top = 120
Width = 4575
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Server Name:"
Height = 195
Index = 3
Left = 60
TabIndex = 6
Top = 2460
Width = 1395
End
End
Attribute VB_Name = "frmCreate"
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: frmCreate.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdLogin_Click()
Dim AppDesc As DPN_APPLICATION_DESC
gfCreatePlayer = True
If txtServerName.Text = vbNullString Then 'They didn't enter a server name
MsgBox "You must enter a server name.", vbOKOnly Or vbInformation, "No server name."
Exit Sub
End If
If txtPassword.Text = vbNullString Then 'They didn't enter a password
MsgBox "You must enter a password.", vbOKOnly Or vbInformation, "No password."
Exit Sub
End If
If txtPassword.Text <> txtVerify.Text Then 'They didn't verify they're password correctly
MsgBox "The passwords do not match.", vbOKOnly Or vbInformation, "Passwords don't match."
Exit Sub
End If
If txtUserName.Text = vbNullString Then 'They didn't enter a user name
MsgBox "You must enter a user name.", vbOKOnly Or vbInformation, "No user name."
Exit Sub
End If
cmdLogin.Enabled = False
If gsServerName = vbNullString Then gsServerName = txtServerName.Text
'Now let's save the settings
SaveSetting gsAppName, "Startup", "ServerName", txtServerName.Text
SaveSetting gsAppName, "Startup", "Username", txtUserName.Text
If gfConnected And (gsServerName = txtServerName.Text) Then
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
CreatePlayer
Else
If gfConnected Then
InitDPlay 'Re-Initialize DPlay
End If
dpas.AddComponentString DPN_KEY_HOSTNAME, txtServerName.Text 'We only want to enumerate connections on this host
'First set up our application description
With AppDesc
.guidApplication = AppGuid
End With
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
On Error Resume Next
'Try to connect to this server
dpc.Connect AppDesc, dpas, dpa, 0, ByVal 0&, 0
If Err.Number <> 0 Then
MsgBox "This server could not be contacted. Please check the server name and try again.", vbOKOnly Or vbInformation, "Not found."
cmdLogin.Enabled = True
Exit Sub
End If
End If
End Sub
Private Sub Form_Load()
'First retrieve the settings
txtServerName.Text = GetSetting(gsAppName, "Startup", "ServerName", vbNullString)
cmdLogin.Enabled = True
End Sub

202
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmLogin.frm Normal file
View File

@@ -0,0 +1,202 @@
VERSION 5.00
Begin VB.Form frmLogin
BorderStyle = 4 'Fixed ToolWindow
Caption = "Login"
ClientHeight = 3255
ClientLeft = 45
ClientTop = 285
ClientWidth = 4680
Icon = "frmLogin.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3255
ScaleWidth = 4680
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Cancel"
Height = 375
Left = 2520
TabIndex = 5
Top = 2760
Width = 1035
End
Begin VB.CommandButton cmdCreate
Caption = "&Create Account"
Height = 375
Left = 60
TabIndex = 4
Top = 2760
Width = 1335
End
Begin VB.CommandButton cmdLogin
Caption = "Log on"
Default = -1 'True
Height = 375
Left = 3600
TabIndex = 6
Top = 2760
Width = 1035
End
Begin VB.TextBox txtServerName
Height = 285
Left = 60
TabIndex = 3
Top = 2400
Width = 4515
End
Begin VB.CheckBox chkRemember
Caption = "Remember this password"
Height = 255
Left = 60
TabIndex = 2
Top = 1860
Width = 4515
End
Begin VB.TextBox txtPassword
Height = 285
IMEMode = 3 'DISABLE
Left = 60
PasswordChar = "*"
TabIndex = 1
Top = 1500
Width = 4515
End
Begin VB.TextBox txtUserName
Height = 285
Left = 60
TabIndex = 0
Top = 900
Width = 4515
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Server Name:"
Height = 195
Index = 3
Left = 60
TabIndex = 10
Top = 2160
Width = 1395
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Password:"
Height = 195
Index = 2
Left = 60
TabIndex = 9
Top = 1260
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "UserName:"
Height = 195
Index = 1
Left = 60
TabIndex = 8
Top = 660
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Please type in your username, password and server to connect to, or click the 'Create Account' button..."
Height = 495
Index = 0
Left = 60
TabIndex = 7
Top = 120
Width = 4575
End
End
Attribute VB_Name = "frmLogin"
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: frmLogin.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdCreate_Click()
Unload Me
frmCreate.Show , frmClient
End Sub
Private Sub cmdLogin_Click()
Dim AppDesc As DPN_APPLICATION_DESC
gfCreatePlayer = False
If txtServerName.Text = vbNullString Then 'They didn't enter a server name
MsgBox "You must enter a server name.", vbOKOnly Or vbInformation, "No server name."
Exit Sub
End If
If txtPassword.Text = vbNullString Then 'They didn't enter a password
MsgBox "You must enter a password.", vbOKOnly Or vbInformation, "No password."
Exit Sub
End If
If txtUserName.Text = vbNullString Then 'They didn't enter a user name
MsgBox "You must enter a user name.", vbOKOnly Or vbInformation, "No user name."
Exit Sub
End If
cmdLogin.Enabled = False
'Now let's save the settings
SaveSetting gsAppName, "Startup", "ServerName", txtServerName.Text
SaveSetting gsAppName, "Startup", "Username", txtUserName.Text
If chkRemember.Value = vbChecked Then
SaveSetting gsAppName, "Startup", "Password", txtPassword.Text
Else
SaveSetting gsAppName, "Startup", "Password", vbNullString
End If
If gsServerName = vbNullString Then gsServerName = txtServerName.Text
If gfConnected And (gsServerName = txtServerName.Text) Then
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
LogonPlayer
Else
If gfConnected Then
InitDPlay 'Re-Initialize DPlay
End If
dpas.AddComponentString DPN_KEY_HOSTNAME, txtServerName.Text 'We only want to connect on this host
'First set up our application description
With AppDesc
.guidApplication = AppGuid
End With
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
On Error Resume Next
'Try to connect to this server
dpc.Connect AppDesc, dpas, dpa, 0, ByVal 0&, 0
If Err.Number <> 0 Then
MsgBox "This server could not be contacted. Please check the server name and try again.", vbOKOnly Or vbInformation, "Not found."
cmdLogin.Enabled = True
Exit Sub
End If
End If
End Sub
Private Sub Form_Load()
'First retrieve the settings
txtServerName.Text = GetSetting(gsAppName, "Startup", "ServerName", vbNullString)
txtUserName.Text = GetSetting(gsAppName, "Startup", "Username", vbNullString)
txtPassword.Text = GetSetting(gsAppName, "Startup", "Password", vbNullString)
If txtPassword.Text <> vbNullString Then chkRemember.Value = vbChecked 'We remembered our password
cmdLogin.Enabled = True
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmLogin.frx Normal file
View File

Binary file not shown.

117
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmMsgTemplate.frm Normal file
View File

@@ -0,0 +1,117 @@
VERSION 5.00
Begin VB.Form frmMsgTemplate
Caption = "Message"
ClientHeight = 4665
ClientLeft = 60
ClientTop = 345
ClientWidth = 4680
Icon = "frmMsgTemplate.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4665
ScaleWidth = 4680
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtSendData
Height = 450
Left = -15
MultiLine = -1 'True
TabIndex = 0
Top = 4155
Width = 4635
End
Begin VB.TextBox txtConversation
Height = 3915
Left = 0
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 1
Top = 0
Width = 4635
End
End
Attribute VB_Name = "frmMsgTemplate"
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: frmMsgTemplate.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private msUser As String
'The username property lets us make sure messages get routed to the right place
Public Property Let UserName(ByVal sUser As String)
msUser = sUser
Me.Caption = "Message - " & sUser
End Property
Public Property Get UserName() As String
UserName = msUser
End Property
Public Sub AddChatMessage(ByVal sChat As String, Optional ByVal fMeTalking As Boolean = False, Optional fNoTalking As Boolean = False)
If Not fNoTalking Then
If fMeTalking Then
sChat = "<" & gsUserName & "> " & sChat
Else
sChat = "<" & msUser & "> " & sChat
End If
End If
'Update the chat window first
txtConversation.Text = txtConversation.Text & sChat & vbCrLf
'Now limit the text in the window to be 32k
If Len(txtConversation.Text) > 32767 Then
txtConversation.Text = Right$(txtConversation.Text, 32767)
End If
'Autoscroll the text
txtConversation.SelStart = Len(txtConversation.Text)
End Sub
Private Sub Form_GotFocus()
On Error Resume Next
txtSendData.SetFocus
End Sub
Private Sub Form_Load()
Me.Caption = "Message - " & msUser
End Sub
Private Sub Form_Resize()
If Me.WindowState <> vbMinimized Then
If Me.Height < (100 * Screen.TwipsPerPixelY) Then
Me.Move Me.Left, Me.Top, Me.Width, (100 * Screen.TwipsPerPixelY)
Else
txtConversation.Move Screen.TwipsPerPixelX, Screen.TwipsPerPixelY, Me.Width - (10 * Screen.TwipsPerPixelX), Me.Height - (2 * txtSendData.Height + (8 * Screen.TwipsPerPixelY))
txtSendData.Move Screen.TwipsPerPixelX, Me.Height - (2 * txtSendData.Height + (1 * Screen.TwipsPerPixelY)), Me.Width - (8 * Screen.TwipsPerPixelX)
End If
End If
End Sub
Private Sub txtSendData_KeyPress(KeyAscii As Integer)
Dim lMsg As Long
Dim oBuf() As Byte, lOffset As Long
If KeyAscii = vbKeyReturn Then 'Send this message
If txtSendData.Text <> vbNullString Then
lMsg = Msg_SendMessage
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, msUser, lOffset
AddStringToBuffer oBuf, gsUserName, lOffset
AddStringToBuffer oBuf, txtSendData.Text, lOffset
dpc.Send oBuf, 0, 0
AddChatMessage txtSendData.Text, True
End If
KeyAscii = 0
txtSendData.Text = vbNullString
End If
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmMsgTemplate.frx Normal file
View File

Binary file not shown.

124
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/modDPlayClient.bas Normal file
View File

@@ -0,0 +1,124 @@
Attribute VB_Name = "modDPlayClient"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDplayClient.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Sleep declare
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Constants for the app
Public Const gsAppName As String = "vbMessengerClient"
'Public vars for the app
Public dx As DirectX8
Public dpc As DirectPlay8Client 'Client object
Public dpa As DirectPlay8Address 'Local address
Public dpas As DirectPlay8Address 'Host address
Public gsUserName As String
Public gsPass As String
Public gsServerName As String
Public gfConnected As Boolean
Public gfCreatePlayer As Boolean
Public gfLoggedIn As Boolean
Public gofrmClient As frmClient
Public Sub InitDPlay()
Cleanup 'Just in case
Set dx = New DirectX8
Set dpc = dx.DirectPlayClientCreate 'Create the client object
Set dpa = dx.DirectPlayAddressCreate 'Create an address
Set dpas = dx.DirectPlayAddressCreate 'Create the servers address object
dpc.RegisterMessageHandler gofrmClient
'Set up the local address
dpa.SetSP DP8SP_TCPIP
'Set up the host address
dpas.SetSP DP8SP_TCPIP
dpas.AddComponentLong DPN_KEY_PORT, glDefaultPort
End Sub
Public Sub Cleanup()
'Close may return DPNERR_UNINITIALIZED if we've already logged off, and we don't
'care, so lets ignore errors here.
On Error Resume Next
'Shut down our message handler
If Not dpc Is Nothing Then dpc.UnRegisterMessageHandler
'Close down our session
If Not dpc Is Nothing Then dpc.Close
Sleep 50 'Lets wait a small portion of time
DoEvents
Set dpc = Nothing
Set dpa = Nothing
Set dpas = Nothing
Set dx = Nothing
End Sub
Public Sub LogonPlayer()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'The connect call has been completed. Now we can send over our logon information
lOffset = NewBuffer(oBuf)
lMsg = Msg_Login
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, gsUserName, lOffset
AddStringToBuffer oBuf, gsPass, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub
Public Sub CreatePlayer()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'The connect call has been completed. Now we can send over our logon information
lOffset = NewBuffer(oBuf)
lMsg = Msg_CreateNewAccount
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, gsUserName, lOffset
AddStringToBuffer oBuf, gsPass, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub
Public Sub AddFriend(ByVal sFriend As String)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Go ahead and add our friend
lOffset = NewBuffer(oBuf)
lMsg = Msg_AddFriend
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sFriend, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub
Public Sub BlockUser(ByVal sFriend As String)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Go ahead and add our friend
lOffset = NewBuffer(oBuf)
lMsg = Msg_BlockFriend
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sFriend, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub

44
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/readme.txt Normal file
View File

@@ -0,0 +1,44 @@
//-----------------------------------------------------------------------------
//
// Sample Name: DXVB Messenger Client Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
DXVB Messenger is an instant messaging application.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\DXVBMessenger\Client
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Log onto a server, add friends, and send instant messages.
Programming Notes
=================
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
- Upon Receive event (the following messages can be received):
Msg_LoginSuccess - Logged in successfully, update the UI
Msg_InvalidPassword - The password for this account is invalid
Msg_InvalidUser - This user doesn't exist
Msg_UserAlreadyExists - This user already exists
'Friend Controls
Msg_FriendAdded - A user was added to my list of friends
Msg_FriendDoesNotExist - Tried to add a friend that doesn't exist
Msg_BlockUserDoesNotExist - Tried to block a user that doesn't exist
Msg_FriendBlocked - A user was added to my list of blocked users.
Msg_SendClientFriends - Get the list of my friends from the server.
Msg_UserBlocked - Can't send a message to this person, they've blocked you
Msg_ReceiveMessage - Received a message, show the message UI and display the message
Msg_FriendLogon - A friend has just logged on, update UI
Msg_FriendLogoff - A friend has just logged off, update UI

36
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/vb_MsgClient.vbp Normal file
View File

@@ -0,0 +1,36 @@
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=frmClient.frm
Module=modMsgShared; ..\modMsgShared.bas
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCTL.OCX
Form=frmLogin.frm
Module=modDPlayClient; modDPlayClient.bas
Form=frmCreate.frm
Form=frmMsgTemplate.frm
Startup="frmClient"
Command32=""
Name="vbMessengerClient"
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

3
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Messenger.vbg Normal file
View File

@@ -0,0 +1,3 @@
VBGROUP 5.0
StartupProject=Server\vb_MsgServer.vbp
Project=Client\vb_MsgClient.vbp

426
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/frmServer.frm Normal file
View File

@@ -0,0 +1,426 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmServer
BorderStyle = 3 'Fixed Dialog
Caption = "vbMessenger Server"
ClientHeight = 4515
ClientLeft = 45
ClientTop = 330
ClientWidth = 3645
Icon = "frmServer.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4515
ScaleWidth = 3645
StartUpPosition = 3 'Windows Default
Begin VB.Timer tmrSaveXML
Interval = 60000
Left = 3660
Top = 1410
End
Begin VB.Timer tmrLogon
Interval = 50
Left = 3660
Top = 960
End
Begin VB.Timer tmrLogoff
Interval = 50
Left = 3660
Top = 480
End
Begin VB.ListBox lstUsers
Height = 3765
Left = 60
TabIndex = 1
Top = 360
Width = 3495
End
Begin MSComctlLib.StatusBar sBar
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 0
Top = 4140
Width = 3645
_ExtentX = 6429
_ExtentY = 661
Style = 1
SimpleText = " "
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Users currently in this session"
Height = 255
Left = 60
TabIndex = 2
Top = 60
Width = 3495
End
Begin VB.Menu mnuPop
Caption = "PopUp"
Visible = 0 'False
Begin VB.Menu mnuShow
Caption = "Show"
End
Begin VB.Menu mnuSep
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "Exit"
End
End
End
Attribute VB_Name = "frmServer"
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: frmServer.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private mfExit As Boolean
Private mfLogoffTimer As Boolean
Private msLogoffName As String
Private mfLogonTimer As Boolean
Private msLogonName As String
Private Sub StartServer()
Dim appdesc As DPN_APPLICATION_DESC
'Now set up the app description
With appdesc
.guidApplication = AppGuid
.lMaxPlayers = 1000 'This seems like a nice round number
.SessionName = "vbMessengerServer"
.lFlags = DPNSESSION_CLIENT_SERVER Or DPNSESSION_NODPNSVR 'We must pass the client server flags if we are a server
End With
'Now set up our address value
dpa.SetSP DP8SP_TCPIP
dpa.AddComponentLong DPN_KEY_PORT, glDefaultPort 'Use a specific port
'Now start the server
dps.Host appdesc, dpa
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
End Sub
Private Sub Form_Load()
dps.RegisterMessageHandler Me
'Lets put an icon in the system tray
With sysIcon
.cbSize = LenB(sysIcon)
.hwnd = Me.hwnd
.uFlags = NIF_DOALL
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.sTip = "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)" & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, sysIcon
'Open the database
OpenClientDatabase
'Start the server
StartServer
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
mnuShow_Click
Case WM_RBUTTONUP
'Show the menu
PopupMenu mnuPop, , , , mnuShow
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)
'Remove the icon from the system tray
Shell_NotifyIcon NIM_DELETE, sysIcon
'Close the database
CloseDownDB
'Cleanup the dplay objects
Cleanup
End Sub
Private Sub mnuExit_Click()
mfExit = True
Unload Me
End Sub
Private Sub mnuShow_Click()
Me.Visible = True
Me.SetFocus
End Sub
Private Sub tmrSaveXML_Timer()
Static lCount As Long
'Every 5 minutes we will save the xml
lCount = lCount + 1
If lCount >= 5 Then
lCount = 0
SaveXMLStructure
End If
End Sub
Private Sub UpdateText(sNewText As String)
sBar.SimpleText = sNewText
'modify our icon text
sysIcon.sTip = sNewText & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
End Sub
Private Sub tmrLogoff_Timer()
'Log this user off
If mfLogoffTimer Then
NotifyFriends msLogoffName, Msg_FriendLogoff
End If
msLogoffName = vbNullString
mfLogoffTimer = False
End Sub
Private Sub tmrLogon_Timer()
If mfLogonTimer Then
mfLogonTimer = False
NotifyFriends msLogonName, Msg_FriendLogon 'Tell everyone who has me marked as a friend that I'm online
GetFriendsOfMineOnline msLogonName 'Find out if any of my friends are online and tell me
End If
msLogonName = vbNullString
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
On Local Error GoTo ErrOut 'So we don't get an InvalidPlayer error when checking on the host
'Update the DB to show a logoff
UpdateDBToShowLogoff lPlayerID
'Remove this player from our listbox
For lCount = lstUsers.ListCount - 1 To 0 Step -1
If lstUsers.ItemData(lCount) = lPlayerID Then
mfLogoffTimer = True
msLogoffName = lstUsers.List(lCount)
glNumPlayers = glNumPlayers - 1
lstUsers.RemoveItem lCount
Exit For
End If
Next
ErrOut:
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
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)
'We need to get each message we receive from a client, process it, and respond accordingly
Dim lMsg As Long, lOffset As Long
Dim oNewMsg() As Byte, lNewOffSet As Long
Dim sUserName As String, sPass As String
Dim lNewMsg As Long, fLoggedin As Boolean
Dim sChatMsg As String, sFromMsg As String
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg 'The server will only receive certain messages. Handle those.
Case Msg_AddFriend 'They want to add a friend to their list
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
If Not DoesUserExist(sUserName) Then
'This user does not exist, notify the person that they cannot be added
lNewMsg = Msg_FriendDoesNotExist
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Else
'Great, add this user to our friend list
fLoggedin = AddFriend(.idSender, sUserName, True)
lNewMsg = Msg_FriendAdded
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
AddStringToBuffer oNewMsg, sUserName, lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, DPNSEND_SYNC
If fLoggedin Then
lNewMsg = Msg_FriendLogon
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lMsg), lNewOffSet
AddStringToBuffer oNewMsg, sUserName, lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
End If
End If
Case Msg_BlockFriend 'They want to block a friend from their list
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
If Not DoesUserExist(sUserName) Then
'This user does not exist, notify the person that they cannot be blocked
lNewMsg = Msg_BlockUserDoesNotExist
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Else
'Great, block this user in our friend list
AddFriend .idSender, sUserName, False
lNewMsg = Msg_FriendBlocked
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
AddStringToBuffer oNewMsg, sUserName, lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
End If
Case Msg_CreateNewAccount 'They want to create a new account
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
sPass = GetStringFromBuffer(.ReceivedData, lOffset)
If DoesUserExist(sUserName) Then
'This user already exists, inform the person so they can try a new name
lNewMsg = Msg_UserAlreadyExists
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Else
'Great, this username doesn't exist. Now lets add this user
AddUser sUserName, sPass, .idSender
'We don't need to inform anyone we are logged on, because
'no one could have us listed as a friend yet
'Notify the user they logged on successfully
lNewMsg = Msg_LoginSuccess
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
'Increment our user count
glNumPlayers = glNumPlayers + 1
'Add this user to our list of users currently online
lstUsers.AddItem sUserName & " 0x" & Hex$(.idSender)
lstUsers.ItemData(lstUsers.ListCount - 1) = .idSender
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
End If
Case Msg_Login 'They have requested a login, check name/password
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
sPass = GetStringFromBuffer(.ReceivedData, lOffset)
Select Case LogonUser(sUserName, sPass) 'Try to log on the user
Case LogonSuccess 'Great, they logged on
UpdateDBToShowLogon sUserName, dpnotify.idSender 'Update the DB to show I'm online
'Notify the user they logged on successfully
lNewMsg = Msg_LoginSuccess
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
mfLogonTimer = True
msLogonName = sUserName
'Increment our user count
glNumPlayers = glNumPlayers + 1
'Add this user to our list of users currently online
lstUsers.AddItem sUserName & " 0x" & Hex$(.idSender)
lstUsers.ItemData(lstUsers.ListCount - 1) = .idSender
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
Case InvalidPassword 'Let the user know that they didn't type in the right password
'Notify the user they sent the wrong password
lNewMsg = Msg_InvalidPassword
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Case AccountDoesNotExist 'Let the user know this account isn't in the DB
'Notify the user that this account doesn't exist
lNewMsg = Msg_InvalidUser
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
End Select
Case Msg_SendMessage 'They are trying to send a message to someone
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
sFromMsg = GetStringFromBuffer(.ReceivedData, lOffset)
sChatMsg = GetStringFromBuffer(.ReceivedData, lOffset)
SendMessage sUserName, sFromMsg, sChatMsg
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/DXVBMessenger/Server/frmServer.frx Normal file
View File

Binary file not shown.

457
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/modDBase.bas Normal file
View File

@@ -0,0 +1,457 @@
Attribute VB_Name = "modDBase"
Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDBase.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Type FriendOnlineType
sFriendName As String
fOnline As Boolean
fFriend As Boolean
End Type
Public Enum LogonTypes
LogonSuccess
InvalidPassword
AccountDoesNotExist
End Enum
Public goDOM As DOMDocument 'The main xml document
Public Sub OpenClientDatabase()
On Error GoTo ErrOut
Dim sMedia As String
sMedia = AddDirSep(GetDXSampleFolder) & "vbsamples\media\vbMsgSrv.xml"
Set goDOM = New DOMDocument
'Create a new XML Doc
goDOM.async = False
goDOM.Load sMedia 'This will load the xml document, if it's available, otherwise it will create a new one
If Not goDOM.hasChildNodes Then 'This is an empty XML file
MsgBox "The default XML data structure could not be found. Creating a new one.", vbOKOnly Or vbInformation, "New XML."
'Create our default file
CreateDefaultXMLStructure
End If
Exit Sub
ErrOut:
MsgBox "There was an error trying to load the XML file. Creating a new one.", vbOKOnly Or vbInformation, "New XML."
Set goDOM = Nothing
Set goDOM = New DOMDocument
'Create our default file
CreateDefaultXMLStructure
End Sub
Public Sub CloseDownDB()
MarkEveryoneLoggedOff
SaveXMLStructure
Set goDOM = Nothing
End Sub
'Check to see if this user already exists. If they do, then we can't create a new account
'with this username.
Public Function DoesUserExist(ByVal sUserName As String) As Boolean
'Let's see if this user exists
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/ClientName")
For Each oNode In oNodes
'See if we are in that list
'We use the childnodes(0) since the only member of the 'ClientName' node
'is the text that contains the name
If oNode.childNodes(0).nodeTypedValue = sUserName Then
DoesUserExist = True
Exit Function
End If
Next
DoesUserExist = False
End Function
Public Function LogonUser(ByVal sUserName As String, ByVal sPwd As String) As LogonTypes
Dim oNode As IXMLDOMNode
Dim sPassword As String
Set oNode = ReturnUserNode(sUserName)
If oNode Is Nothing Then
LogonUser = AccountDoesNotExist
Exit Function
End If
'Ok, this user does exist. First lets decrypt the password sent from the client
sPassword = EncodePassword(sPwd, glClientSideEncryptionKey)
'Now check this password against what's listed in the db.
'The next sibling of the 'ClientName' node is the password node.
'The first child of that node is the actual text value of the password
If oNode.nextSibling.childNodes(0).nodeTypedValue = EncodePassword(sPassword, glServerSideEncryptionKey) Then
'The passwords match, logon was successful
LogonUser = LogonSuccess
Exit Function
Else
'Invalid password, let the user know
LogonUser = InvalidPassword
Exit Function
End If
End Function
Public Sub AddUser(ByVal sUserName As String, ByVal sPwd As String, ByVal lCurrentDPlayID As Long)
Dim sPassword As String
'First decrypt the password
sPassword = EncodePassword(sPwd, glClientSideEncryptionKey)
'Now add this user to our xml structure
AddUserXML sUserName, EncodePassword(sPassword, glServerSideEncryptionKey), True, lCurrentDPlayID
End Sub
Public Sub UpdateDBToShowLogon(ByVal sPlayer As String, ByVal lCurrentDPlayID As Long)
'Set the flag to show that we are currently logged on, and keep our current DPlay ID
Dim oNode As IXMLDOMNode
Dim oUpdate As IXMLDOMNode
Set oNode = ReturnUserNode(sPlayer)
Set oUpdate = GetNode(oNode, "CurrentlyLoggedIn")
oUpdate.childNodes(0).nodeTypedValue = -1
Set oUpdate = GetNode(oNode, "CurrentDPlayID")
oUpdate.childNodes(0).nodeTypedValue = lCurrentDPlayID
End Sub
Public Sub UpdateDBToShowLogoff(ByVal lCurrentDPlayID As Long)
'Set the flag to show that we are currently logged off, and lose our current DPlay ID
Dim oNode As IXMLDOMNode
Dim oUpdate As IXMLDOMNode
Set oNode = ReturnUserNodeFromDPlayID(lCurrentDPlayID)
Set oUpdate = GetNode(oNode, "CurrentlyLoggedIn")
oUpdate.childNodes(0).nodeTypedValue = 0
Set oUpdate = GetNode(oNode, "CurrentDPlayID")
oUpdate.childNodes(0).nodeTypedValue = 0
End Sub
Public Sub NotifyFriends(ByVal sPlayer As String, ByVal lNotifyMsg As Long)
Dim lMsg As Long
Dim oBuf() As Byte, lOffset As Long
Dim oNodes As IXMLDOMNodeList, oTemp As IXMLDOMNode
Dim oNode As IXMLDOMNode, oNodeFriend As IXMLDOMNode
'See if I'm anyone's friends
Set oNodes = goDOM.selectNodes("MessengerServerDB/FriendList/Row/FriendName")
For Each oNode In oNodes
If oNode.childNodes(0).nodeTypedValue = sPlayer Then 'Yup, I am. Notify each of them that I just logged on
'First check to see if they are logged on
Set oNodeFriend = ReturnUserNode(oNode.previousSibling.childNodes(0).nodeTypedValue)
Set oTemp = GetNode(oNodeFriend, "CurrentDPlayID")
If Not (oTemp Is Nothing) Then
lMsg = lNotifyMsg
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sPlayer, lOffset
dps.SendTo CLng(oTemp.childNodes(0).nodeTypedValue), oBuf, 0, 0
End If
Set oNodeFriend = Nothing
Set oTemp = Nothing
End If
Next
End Sub
Public Sub GetFriendsOfMineOnline(ByVal sPlayer As String)
Dim lMsg As Long
Dim oBuf() As Byte, lOffset As Long
Dim oNodes As IXMLDOMNodeList
Dim oNode As IXMLDOMNode, oNodeFriend As IXMLDOMNode
Dim lSendID As Long
Dim oFriends() As FriendOnlineType
Dim lCount As Long
'First we need to find out if I have any friends in my list
Set oNodes = goDOM.selectNodes("MessengerServerDB/FriendList/Row/ClientName")
ReDim oFriends(0)
For Each oNode In oNodes
If oNode.childNodes(0).nodeTypedValue = sPlayer Then 'Yup, I do. Lets save them so I can notify them
'Get the friend node
Set oNodeFriend = ReturnUserNode(oNode.nextSibling.childNodes(0).nodeTypedValue)
'First check to see if they are logged on
ReDim Preserve oFriends(UBound(oFriends) + 1)
With oFriends(UBound(oFriends))
.sFriendName = oNodeFriend.childNodes(0).nodeTypedValue
.fOnline = GetNode(oNodeFriend, "CurrentDPlayID").childNodes(0).nodeTypedValue <> 0
.fFriend = oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue
End With
Set oNodeFriend = Nothing
End If
Next
'Get my DPlayID
lSendID = GetCurrentDPlayID(sPlayer)
'Now see if I have any friends
lMsg = Msg_SendClientFriends
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, CLng(UBound(oFriends)), SIZE_LONG, lOffset
For lCount = 1 To UBound(oFriends)
AddDataToBuffer oBuf, oFriends(lCount).fFriend, LenB(oFriends(lCount).fFriend), lOffset
AddStringToBuffer oBuf, oFriends(lCount).sFriendName, lOffset
Next
dps.SendTo lSendID, oBuf, 0, 0
For lCount = 1 To UBound(oFriends)
If oFriends(lCount).fOnline Then
ReDim oBuf(0)
lMsg = Msg_FriendLogon
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, oFriends(lCount).sFriendName, lOffset
dps.SendTo lSendID, oBuf, 0, 0
End If
Next
End Sub
'If fFriend is True, then this person is a friend. If it is False, then the person is blocked
Public Function AddFriend(ByVal lPlayerID As Long, ByVal sFriendName As String, ByVal fFriend As Boolean) As Boolean
Dim oMyNode As IXMLDOMNode
Dim oFriendNode As IXMLDOMNode
Dim oNodeList As IXMLDOMNodeList, oNode As IXMLDOMNode, fFoundNode As Boolean
AddFriend = False
fFoundNode = False
Set oFriendNode = ReturnUserNode(sFriendName)
'Is this friend currently logged in?
If GetNode(oFriendNode, "CurrentDPlayID").childNodes(0).nodeTypedValue <> 0 Then AddFriend = True
Set oMyNode = ReturnUserNodeFromDPlayID(lPlayerID)
Set oNodeList = goDOM.selectNodes("MessengerServerDB/FriendList/Row/ClientName")
For Each oNode In oNodeList
If (oNode.childNodes(0).nodeTypedValue = oMyNode.childNodes(0).nodeTypedValue) And _
oNode.nextSibling.childNodes(0).nodeTypedValue = sFriendName Then
fFoundNode = True
'We found the node, update it
oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue = fFriend
Exit For
End If
Next
If Not fFoundNode Then 'We need to add this node
AddFriendXML oMyNode.childNodes(0).nodeTypedValue, sFriendName, fFriend
End If
End Function
Public Function AmIBlocked(ByVal sMe As String, ByVal sFriend As String) As Boolean
Dim oMyNode As IXMLDOMNode
Dim oFriendNode As IXMLDOMNode
Dim oNodeList As IXMLDOMNodeList, oNode As IXMLDOMNode
AmIBlocked = False
Set oFriendNode = ReturnUserNode(sFriend)
'Is this friend currently logged in?
Set oMyNode = ReturnUserNode(sMe)
Set oNodeList = goDOM.selectNodes("MessengerServerDB/FriendList/Row/ClientName")
For Each oNode In oNodeList
If (oNode.childNodes(0).nodeTypedValue = oMyNode.childNodes(0).nodeTypedValue) And _
oNode.nextSibling.childNodes(0).nodeTypedValue = sFriend Then
'We found the node, update it
AmIBlocked = (oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue = False)
Exit For
End If
Next
End Function
Public Function GetCurrentDPlayID(ByVal sPlayer As String) As Long
Dim oNode As IXMLDOMNode
Set oNode = ReturnUserNode(sPlayer)
'We need to get the current dplay id of this person
GetCurrentDPlayID = CLng(GetNode(oNode, "CurrentDPlayID").childNodes(0).nodeTypedValue)
End Function
Private Sub CreateDefaultXMLStructure()
Dim root As IXMLDOMNode
Dim clientNode As IXMLDOMNode, friendNode As IXMLDOMNode
'Create a 'root' node
Set root = goDOM.createNode(NODE_ELEMENT, "MessengerServerDB", vbNullString)
goDOM.appendChild root
Set clientNode = goDOM.createNode(NODE_ELEMENT, "ClientInfo", vbNullString)
root.appendChild clientNode
Set friendNode = goDOM.createNode(NODE_ELEMENT, "FriendList", vbNullString)
root.appendChild friendNode
End Sub
Private Sub AddUserXML(ByVal sUserName As String, ByVal sPassword As String, ByVal fLoggedOn As Boolean, ByVal lCurrentDPlayID As Long)
Dim oClientNode As IXMLDOMNode, lCount As Long
Dim oRowNode As IXMLDOMNode, oTableField As IXMLDOMNode
Dim oText As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Ok, we need to add a user, first check to see if there are any nodes in our xml doc, if so, add them to those
'if not, create new ones (we already did this when we created the file, just in case tho)
If Not goDOM.hasChildNodes Then 'This is an empty XML file
'Create our default file
CreateDefaultXMLStructure
End If
'We know the first item is the main node
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo")
For Each oClientNode In oNodes
If oClientNode.nodeName = "ClientInfo" Then
Set oRowNode = goDOM.createNode(NODE_ELEMENT, "Row", vbNullString)
'now the Client name
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "ClientName", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sUserName
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the Client pwd
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "ClientPassword", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sPassword
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the currently logged in state
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "CurrentlyLoggedIn", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = fLoggedOn
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the currently logged in state
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "CurrentDPlayID", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = lCurrentDPlayID
oTableField.appendChild oText
oRowNode.appendChild oTableField
'Now actually add the row
oClientNode.appendChild oRowNode
End If
Next
End Sub
Private Sub AddFriendXML(ByVal sUserName As String, ByVal sFriend As String, ByVal fFriend As Boolean)
Dim oFriendNode As IXMLDOMNode, lCount As Long
Dim oRowNode As IXMLDOMNode, oTableField As IXMLDOMNode
Dim oText As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Ok, we need to add a user, first check to see if there are any nodes in our xml doc, if so, add them to those
'if not, create new ones (we already did this when we created the file, just in case tho)
If Not goDOM.hasChildNodes Then 'This is an empty XML file
'Create our default file
CreateDefaultXMLStructure
End If
Set oNodes = goDOM.selectNodes("MessengerServerDB/FriendList")
For Each oFriendNode In oNodes
If oFriendNode.nodeName = "FriendList" Then
Set oRowNode = goDOM.createNode(NODE_ELEMENT, "Row", vbNullString)
'now the Client name
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "ClientName", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sUserName
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the friend name
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "FriendName", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sFriend
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the friend state
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "Friend", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = fFriend
oTableField.appendChild oText
oRowNode.appendChild oTableField
'Now actually add the row
oFriendNode.appendChild oRowNode
End If
Next
End Sub
Private Function ReturnUserNode(ByVal sUserName As String) As IXMLDOMNode
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/ClientName")
For Each oNode In oNodes
'See if we are in that list
'We use the childnodes(0) since the only member of the 'ClientName' node
'is the text that contains the name
If oNode.childNodes(0).nodeTypedValue = sUserName Then
Set ReturnUserNode = oNode
Exit Function
End If
Next
Set ReturnUserNode = Nothing
End Function
Private Function ReturnUserNodeFromDPlayID(ByVal lID As Long) As IXMLDOMNode
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/CurrentDPlayID")
For Each oNode In oNodes
'See if we are in that list
'We use the childnodes(0) since the only member of the 'CurrentDPlayID' node
'is the text that contains the id
If oNode.childNodes(0).nodeTypedValue = lID Then
'The user node is 3 siblings before the DPlayID node
Set ReturnUserNodeFromDPlayID = oNode.previousSibling.previousSibling.previousSibling
Exit Function
End If
Next
Set ReturnUserNodeFromDPlayID = Nothing
End Function
Private Function GetNode(ByVal oNode As IXMLDOMNode, ByVal sNodeName As String) As IXMLDOMNode
Dim oUpdate As IXMLDOMNode
On Error GoTo ExitFunc
Set oUpdate = oNode.nextSibling
Do
If oUpdate.nodeName = sNodeName Then
Set GetNode = oUpdate
Exit Function
End If
Set oUpdate = oUpdate.nextSibling
Loop
ExitFunc:
Set GetNode = Nothing
End Function
Private Function MarkEveryoneLoggedOff()
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/ClientName")
For Each oNode In oNodes
'Mark everyone as logged off
oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue = 0
oNode.nextSibling.nextSibling.nextSibling.childNodes(0).nodeTypedValue = 0
Next
End Function
Public Sub SaveXMLStructure()
'Save the XML structure out to a file
goDOM.Save AddDirSep(GetDXSampleFolder) & "vbsamples\media\vbMsgSrv.xml"
End Sub

81
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/modDPlayServer.bas Normal file
View File

@@ -0,0 +1,81 @@
Attribute VB_Name = "modDPlayServer"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlayServer.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Public vars for the app
Public dx As New DirectX8
Public dps As DirectPlay8Server
Public dpa As DirectPlay8Address
Public glNumPlayers As Long
Public Sub Main()
If App.PrevInstance Then
MsgBox "You can only run one instance of this server at a time.", vbOKOnly Or vbInformation, "Close other instance"
Exit Sub
End If
'Set up the default DPlay objects
InitDPlay
'Show the form (which will start the server)
frmServer.Show
End Sub
Public Sub InitDPlay()
Set dps = dx.DirectPlayServerCreate
Set dpa = dx.DirectPlayAddressCreate
End Sub
Public Sub Cleanup()
'Shut down our message handler
If Not dps Is Nothing Then dps.UnRegisterMessageHandler
'Close down our session
If Not dps Is Nothing Then dps.Close
Set dps = Nothing
Set dpa = Nothing
Set dx = Nothing
End Sub
'Send a message to a player
Public Function SendMessage(ByVal sUser As String, ByVal sFrom As String, ByVal sChat As String) As Boolean
Dim lSendID As Long, lMsg As Long
Dim oBuf() As Byte, lOffset As Long
'Before we send this message check to see if this user is blocked
If AmIBlocked(sUser, sFrom) Then
lSendID = GetCurrentDPlayID(sFrom)
lMsg = Msg_UserBlocked
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sUser, lOffset
dps.SendTo lSendID, oBuf, 0, 0
Else
lSendID = GetCurrentDPlayID(sUser)
If lSendID = 0 Then 'This person isn't logged on
lSendID = GetCurrentDPlayID(sFrom)
lMsg = Msg_UserUnavailable
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sUser, lOffset
AddStringToBuffer oBuf, sChat, lOffset
Else
lMsg = Msg_ReceiveMessage
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sFrom, lOffset
AddStringToBuffer oBuf, sChat, lOffset
End If
dps.SendTo lSendID, oBuf, 0, 0
End If
SendMessage = True
End Function

37
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/readme.txt Normal file
View File

@@ -0,0 +1,37 @@
//-----------------------------------------------------------------------------
//
// Sample Name: DXVB Messenger Server Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
DXVB Messenger Server is the server portion of a client/server instant
messaging application. This sample requires the use of XML to maintain the
data needed. You must have at least IE5 installed on your machine to compile
or run this sample.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\DXVBMessenger\Server
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Log onto a server, add friends, and send instant messages.
Programming Notes
=================
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
- Upon Receive event (the following messages can be received):
'Login messages
Msg_Login - Get login information, verify against the database
Msg_CreateNewAccount - A new account needs to be created, try to create in database
Msg_AddFriend - Add a friend to this users list
Msg_BlockFriend - Block someone in this users list
Msg_SendMessage - User is sending a message to someone, pass it on

40
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/vb_MsgServer.vbp Normal file
View File

@@ -0,0 +1,40 @@
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
Reference=*\G{D63E0CE2-A0A2-11D0-9C02-00C04FC99C8E}#2.0#0#msxml.dll#Microsoft XML, version 2.0
Object={86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCT2.OCX
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCTL.OCX
Form=frmServer.frm
Module=modDPlayServer; modDPlayServer.bas
Module=modMsgShared; ..\modMsgShared.bas
Module=modDBase; modDBase.bas
Module=MediaDir; ..\..\..\common\media.bas
IconForm="frmServer"
Startup="Sub Main"
HelpFile=""
Title="vbMessengerServer"
Command32=""
Name="vbMessengerServer"
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

82
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/modMsgShared.bas Normal file
View File

@@ -0,0 +1,82 @@
Attribute VB_Name = "modMsgShared"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modMsgShared.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Constant encryption keys for both the server and client
Public Const glClientSideEncryptionKey As Long = 169
Public Const glServerSideEncryptionKey As Long = 131
'Unique GUID for the app (used by DPlay)
Public Const AppGuid = "{0AC3AAC4-5470-4cc0-ABBE-6EF0B614E52A}"
'Host and connect on this port
Public Const glDefaultPort As Long = 9123
'System Tray Declares/Constants/Types
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
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
Public sysIcon As NOTIFYICONDATA
Public Enum vbMessengerMsgTypes
'Login messages
Msg_Login 'Login information
Msg_LoginSuccess 'Logged in successfully
Msg_CreateNewAccount 'A new account needs to be created
Msg_InvalidPassword 'The password for this account is invalid
Msg_InvalidUser 'This user doesn't exist
Msg_UserAlreadyExists 'This user already exists (only can be received after a CreateNewAcct msg)
'Friend Controls
Msg_AddFriend 'Add a friend to my list
Msg_FriendAdded 'User was added
Msg_FriendDoesNotExist 'Tried to add a friend that doesn't exist
Msg_BlockUserDoesNotExist 'Tried to block a user that doesn't exist
Msg_BlockFriend 'Block someone from contacting me
Msg_FriendBlocked 'User was blocked
Msg_DeleteFriend 'Delete this user from my list of friends
Msg_SendClientFriends 'The Server will send the client it's list of friends
'Messages
Msg_SendMessage 'Send a message to someone
Msg_UserBlocked 'Can't send a message to this person, they've blocked you
Msg_ReceiveMessage 'Received a message
Msg_UserUnavailable 'The user you are trying to send a message to is no longer logged on
'Friend Logon messages
Msg_FriendLogon 'A friend has just logged on
Msg_FriendLogoff 'A friend has just logged off
End Enum
'Here we will use a very basic encrytion scheme. We will encrypt the password
'on the client side, before we send it over to the server, and then decrypt it
'on the server side, and encrypt it once more before checking it against the database
Public Function EncodePassword(sOldStr As String, ByVal lEncryptKey) As String
Dim lCount As Long, sNew As String
'Do a simple replace on each character in the string
For lCount = 1 To Len(sOldStr)
sNew = sNew & Chr$(Asc(Mid$(sOldStr, lCount, 1)) Xor lEncryptKey)
Next
EncodePassword = sNew
End Function

732
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DataRelay/frmDataRelay.frm Normal file
View File

@@ -0,0 +1,732 @@
VERSION 5.00
Begin VB.Form frmDataRelay
BorderStyle = 3 'Fixed Dialog
Caption = "vbData Relay"
ClientHeight = 6255
ClientLeft = 645
ClientTop = 930
ClientWidth = 7755
Icon = "frmDataRelay.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6255
ScaleWidth = 7755
StartUpPosition = 3 'Windows Default
Begin VB.Frame Frame5
Caption = "Connection Information"
Height = 2715
Left = 3240
TabIndex = 23
Top = 960
Width = 4455
Begin VB.TextBox txtInfo
BackColor = &H8000000F&
Height = 1935
Left = 120
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 26
Top = 660
Width = 4155
End
Begin VB.ComboBox cboInfoTarget
Height = 315
Left = 1380
Style = 2 'Dropdown List
TabIndex = 25
Top = 240
Width = 2655
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "Info Target: "
Height = 195
Index = 6
Left = 300
TabIndex = 24
Top = 300
Width = 1035
End
End
Begin VB.Timer tmrReceivedData
Interval = 1
Left = 180
Top = 3060
End
Begin VB.Timer tmrSendData
Interval = 1
Left = 720
Top = 3060
End
Begin VB.Frame Frame4
Caption = "Statistics"
Height = 915
Left = 60
TabIndex = 18
Top = 2760
Width = 3135
Begin VB.Label lblReceive
BackStyle = 0 'Transparent
Caption = "0.0"
Height = 195
Left = 2160
TabIndex = 22
Top = 480
Width = 855
End
Begin VB.Label lblSendRate
BackStyle = 0 'Transparent
Caption = "0.0"
Height = 195
Left = 2160
TabIndex = 21
Top = 240
Width = 795
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "Received Rate (bytes/sec) :"
Height = 195
Index = 8
Left = 60
TabIndex = 20
Top = 480
Width = 2055
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "Send Rate (bytes/sec) :"
Height = 195
Index = 7
Left = 60
TabIndex = 19
Top = 240
Width = 2055
End
End
Begin VB.Frame Frame3
Caption = "Send"
Height = 1755
Left = 60
TabIndex = 9
Top = 960
Width = 3135
Begin VB.ComboBox cboTimeout
Height = 315
Left = 1200
Style = 2 'Dropdown List
TabIndex = 17
Top = 1320
Width = 1815
End
Begin VB.ComboBox cboTarget
Height = 315
Left = 1200
Style = 2 'Dropdown List
TabIndex = 16
Top = 240
Width = 1815
End
Begin VB.ComboBox cboSize
Height = 315
Left = 1200
Style = 2 'Dropdown List
TabIndex = 15
Top = 600
Width = 1815
End
Begin VB.ComboBox cboRate
Height = 315
Left = 1200
Style = 2 'Dropdown List
TabIndex = 14
Top = 960
Width = 1815
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Timeout (ms) :"
Height = 195
Index = 5
Left = 120
TabIndex = 13
Top = 1380
Width = 1035
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "Target :"
Height = 195
Index = 4
Left = 120
TabIndex = 12
Top = 300
Width = 1035
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "Size (bytes) :"
Height = 195
Index = 3
Left = 120
TabIndex = 11
Top = 660
Width = 1035
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "Rate (ms) :"
Height = 195
Index = 2
Left = 120
TabIndex = 10
Top = 1020
Width = 1035
End
End
Begin VB.Frame Frame2
Caption = "Log"
Height = 2415
Left = 60
TabIndex = 7
Top = 3720
Width = 7635
Begin VB.TextBox txtLog
BackColor = &H8000000F&
Height = 2055
Left = 120
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 8
Top = 240
Width = 7395
End
End
Begin VB.Frame Frame1
Caption = "Game Status"
Height = 855
Left = 60
TabIndex = 0
Top = 60
Width = 7635
Begin VB.CommandButton cmdExit
Cancel = -1 'True
Caption = "Exit"
Height = 375
Left = 5880
TabIndex = 6
Top = 300
Width = 1575
End
Begin VB.CommandButton cmdSend
Caption = "Push to send"
Enabled = 0 'False
Height = 375
Left = 4200
TabIndex = 5
Top = 300
Width = 1575
End
Begin VB.Label lblPlayers
BackStyle = 0 'Transparent
Caption = "0"
Height = 255
Left = 2340
TabIndex = 4
Top = 480
Width = 195
End
Begin VB.Label lblPlayer
BackStyle = 0 'Transparent
Caption = "TestPlayer"
Height = 255
Left = 1560
TabIndex = 3
Top = 240
Width = 1635
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Number of Players in session:"
Height = 195
Index = 1
Left = 120
TabIndex = 2
Top = 480
Width = 2175
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Local Player Name:"
Height = 195
Index = 0
Left = 120
TabIndex = 1
Top = 240
Width = 1455
End
End
End
Attribute VB_Name = "frmDataRelay"
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: frmDataRelay.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Declare for timeGetTime
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Implements DirectPlay8Event
Private Const mlTextSize As Long = 32768
Private Type PacketInfo
lPacketID As Long
lDataSize As Long
End Type
Private mfSending As Boolean
Private mlRate As Long
Private mlToPlayerID As Long
Private mlTimeOut As Long
Private mlSize As Long
Private mlSending As Long
Private mlLastSendTime As Long
Private mlDataReceived As Long
Private mlDataSent As Long
Private mfInSend As Boolean
Private mfInReceive As Boolean
Private moByte() As Byte, moBuf() As Byte 'DirectPlayBuffer
Private moReceived As New Collection
Private Sub cmdExit_Click()
'We're done, unload
Unload Me
End Sub
Private Sub cmdSend_Click()
If mfSending Then
'Stop sending now
cmdSend.Caption = "Push to send"
Else
'Start sending now
cmdSend.Caption = "Push to stop"
ReadCombos
End If
EnableComboUI mfSending
mfSending = Not mfSending
End Sub
Private Sub Form_Load()
'First lets populate our combo boxes
PopulateBoxes
'Here we will init our DPlay objects
InitDPlay
'Now we can create a new Connection Form (which will also be our message pump)
Set DPlayEventsForm = New DPlayConnect
'Start the connection form (it will either create or join a session)
If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 20, Me) Then
Cleanup
End
Else 'We did choose to play a game
gsUserName = DPlayEventsForm.UserName
lblPlayer.Caption = gsUserName
If DPlayEventsForm.IsHost Then Me.Caption = Me.Caption & " (HOST)"
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.Hide
'Here we need to turn off our timers
If mfSending Then cmdSend_Click
mfSending = False
Do While moReceived.Count > 0
DPlayEventsForm.DoSleep 50
Loop
tmrReceivedData.Enabled = False
tmrSendData.Enabled = False
Cleanup
End Sub
Private Sub PopulateBoxes()
With cboTarget
.AddItem "Everyone"
.ListIndex = 0
End With
With cboRate
.AddItem "1000"
.AddItem "500"
.AddItem "250"
.AddItem "100"
.AddItem "50"
.ListIndex = 0
End With
With cboSize
.AddItem "512"
.AddItem "256"
.AddItem "128"
.AddItem "64"
.AddItem "32"
.AddItem "16"
.ListIndex = 0
End With
With cboTimeout
.AddItem "5"
.AddItem "10"
.AddItem "20"
.AddItem "50"
.AddItem "100"
.AddItem "250"
.AddItem "500"
.ListIndex = 0
End With
With cboInfoTarget
.AddItem "None"
.ListIndex = 0
End With
End Sub
Private Sub EnableComboUI(ByVal fEnable As Boolean)
cboRate.Enabled = fEnable
cboTarget.Enabled = fEnable
cboTimeout.Enabled = fEnable
cboSize.Enabled = fEnable
End Sub
Private Sub ReadCombos()
mlRate = CLng(cboRate.List(cboRate.ListIndex))
mlSize = CLng(cboSize.List(cboSize.ListIndex))
mlTimeOut = CLng(cboTimeout.List(cboTimeout.ListIndex))
mlToPlayerID = cboTarget.ItemData(cboTarget.ListIndex) 'The ItemData for everyone is 0
End Sub
Private Sub AppendText(ByVal sString As String)
'Update the chat window first
txtLog.Text = txtLog.Text & sString & vbCrLf
'Now limit the text in the window to be 16k
If Len(txtLog.Text) > mlTextSize Then
txtLog.Text = Right$(txtLog.Text, mlTextSize)
End If
'Autoscroll the text
txtLog.SelStart = Len(txtLog.Text)
End Sub
Private Function GetName(ByVal lID As Long) As String
Dim lCount As Long
'Here we will get the name of the player sending us info from the combo box
GetName = vbNullString
For lCount = 0 To cboTarget.ListCount - 1
If cboTarget.ItemData(lCount) = lID Then 'This is the player
GetName = cboTarget.List(lCount)
Exit For
End If
Next
End Function
Private Sub tmrReceivedData_Timer()
Dim oBuf() As Byte, lNewMsg As Long, lNewOffset As Long
Dim sItems() As String, oPacket As PacketInfo
'If mfInReceive Then Exit Sub
'We use a timer control here because we don't want to ever
'block DirectPlay.
Do While moReceived.Count > 0
mfInReceive = True
sItems = Split(moReceived.Item(1), ";")
AppendText "Received packet #" & sItems(1) & " from " & GetName(CLng(sItems(0))) & " - Size:" & sItems(2)
'now let this user know we received the packet
lNewMsg = MSG_PacketReceive
lNewOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lNewMsg, LenB(lNewMsg), lNewOffset
oPacket.lDataSize = CLng(sItems(2))
oPacket.lPacketID = CLng(sItems(1))
mlDataReceived = mlDataReceived + oPacket.lDataSize
AddDataToBuffer oBuf, oPacket, LenB(oPacket), lNewOffset
'We don't care to see the receive callback.
dpp.SendTo CLng(sItems(0)), oBuf, mlTimeOut, DPNSEND_NOLOOPBACK
Erase oBuf
moReceived.Remove 1
Loop
mfInReceive = False
End Sub
Private Sub tmrSendData_Timer()
Dim lMsg As Long, lOffset As Long
Dim oPacket As PacketInfo
'We use a timer control here because we don't want to ever
'block DirectPlay.
'If mfInSend Then Exit Sub
If mfSending Then 'We are sending
If Abs(timeGetTime - mlLastSendTime) > mlRate Then 'We should send another packet now
mfInSend = True
lMsg = MSG_GamePacket
lOffset = NewBuffer(moBuf)
AddDataToBuffer moBuf, lMsg, LenB(lMsg), lOffset
mlSending = mlSending + 1
oPacket.lPacketID = mlSending
oPacket.lDataSize = mlSize
mlDataSent = mlDataSent + mlSize
AddDataToBuffer moBuf, oPacket, LenB(oPacket), lOffset
ReDim moByte(mlSize)
AddDataToBuffer moBuf, moByte(0), mlSize, lOffset
'We will send the NOLOOPBACK flag so we do not get a 'Receive' event for
'this message.
'The NOCOPY flag tells DPlay not to copy our buffer. We will erase the buffer in the
'SendComplete event
dpp.SendTo mlToPlayerID, moBuf, mlTimeOut, DPNSEND_NOLOOPBACK Or DPNSEND_NOCOPY
mlLastSendTime = timeGetTime
End If
End If
'Regardless of what's going on, we should update our ui
UpdateStats
End Sub
Private Sub UpdateStats()
Dim lNumMsgs As Long, lNumBytes As Long
Dim lCurTime As Long
Dim sText As String, dpnInfo As DPN_CONNECTION_INFO
Dim lNumMsgHigh As Long, lNumByteHigh As Long
Dim lNumMsgNormal As Long, lNumByteNormal As Long
Dim lNumMsgLow As Long, lNumByteLow As Long
Dim lDrops As Long, lSends As Long
Dim lPlayerID As Long
On Error Resume Next
Static lLastTime As Long
If lLastTime = 0 Then lLastTime = timeGetTime
lCurTime = timeGetTime
If (lCurTime - lLastTime) < 1000 Then Exit Sub 'We don't need to update more than once a second
Dim nSecondsPassed As Single, nDataIn As Single
Dim nDataOut As Single
nSecondsPassed = (lCurTime - lLastTime) / 1000
nDataIn = mlDataReceived / nSecondsPassed
nDataOut = mlDataSent / nSecondsPassed
lLastTime = lCurTime
mlDataReceived = 0
mlDataSent = 0
lblSendRate.Caption = Format$(CStr(nDataOut), "0.0#")
lblReceive.Caption = Format$(CStr(nDataIn), "0.0#")
If cboInfoTarget.ListIndex >= 0 Then
lPlayerID = cboInfoTarget.ItemData(cboInfoTarget.ListIndex)
If lPlayerID <> 0 Then
'Update the connection info
dpnInfo = dpp.GetConnectionInfo(lPlayerID, 0)
dpp.GetSendQueueInfo lPlayerID, lNumMsgHigh, lNumByteHigh, DPNGETSENDQUEUEINFO_PRIORITY_HIGH
dpp.GetSendQueueInfo lPlayerID, lNumMsgLow, lNumByteLow, DPNGETSENDQUEUEINFO_PRIORITY_LOW
dpp.GetSendQueueInfo lPlayerID, lNumMsgNormal, lNumByteNormal, DPNGETSENDQUEUEINFO_PRIORITY_NORMAL
lDrops = dpnInfo.lPacketsDropped + dpnInfo.lPacketsRetried
lDrops = lDrops * 10000
lSends = dpnInfo.lPacketsSentGuaranteed + dpnInfo.lPacketsSentNonGuaranteed
If lSends > 0 Then lDrops = lDrops \ lSends
sText = "Send Queue Messages High Priority=" & CStr(lNumMsgHigh) & vbCrLf
sText = sText & "Send Queue Bytes High Priority=" & CStr(lNumByteHigh) & vbCrLf
sText = sText & "Send Queue Messages Normal Priority=" & CStr(lNumMsgNormal) & vbCrLf
sText = sText & "Send Queue Bytes Normal Priority=" & CStr(lNumByteNormal) & vbCrLf
sText = sText & "Send Queue Messages Low Priority=" & CStr(lNumMsgLow) & vbCrLf
sText = sText & "Send Queue Bytes Low Priority=" & CStr(lNumByteLow) & vbCrLf
sText = sText & "Round Trip Latency MS=" & CStr(dpnInfo.lRoundTripLatencyMS) & " ms" & vbCrLf
sText = sText & "Throughput BPS=" & CStr(dpnInfo.lThroughputBPS) & vbCrLf
sText = sText & "Peak Throughput BPS=" & CStr(dpnInfo.lPeakThroughputBPS) & vbCrLf
sText = sText & "Bytes Sent Guaranteed=" & CStr(dpnInfo.lBytesSentGuaranteed) & vbCrLf
sText = sText & "Packets Sent Guaranteed=" & CStr(dpnInfo.lPacketsSentGuaranteed) & vbCrLf
sText = sText & "Bytes Sent Non-Guaranteed=" & CStr(dpnInfo.lBytesSentNonGuaranteed) & vbCrLf
sText = sText & "Packets Sent Non-Guaranteed=" & CStr(dpnInfo.lPacketsSentNonGuaranteed) & vbCrLf
sText = sText & "Bytes Retried Guaranteed=" & CStr(dpnInfo.lBytesRetried) & vbCrLf
sText = sText & "Packets Retried Guaranteed=" & CStr(dpnInfo.lPacketsRetried) & vbCrLf
sText = sText & "Bytes Dropped Non-Guaranteed=" & CStr(dpnInfo.lBytesDropped) & vbCrLf
sText = sText & "Packets Dropped Non-Guaranteed=" & CStr(dpnInfo.lPacketsDropped) & vbCrLf
sText = sText & "Messages Transmitted High Priority=" & CStr(dpnInfo.lMessagesTransmittedHighPriority) & vbCrLf
sText = sText & "Messages Timed Out High Priority=" & CStr(dpnInfo.lMessagesTimedOutHighPriority) & vbCrLf
sText = sText & "Messages Transmitted Normal Priority=" & CStr(dpnInfo.lMessagesTransmittedNormalPriority) & vbCrLf
sText = sText & "Messages Timed Out Normal Priority=" & CStr(dpnInfo.lMessagesTimedOutNormalPriority) & vbCrLf
sText = sText & "Messages Transmitted Low Priority=" & CStr(dpnInfo.lMessagesTransmittedLowPriority) & vbCrLf
sText = sText & "Messages Timed Out Low Priority=" & CStr(dpnInfo.lMessagesTimedOutLowPriority) & vbCrLf
sText = sText & "Bytes Received Guaranteed=" & CStr(dpnInfo.lBytesReceivedGuaranteed) & vbCrLf
sText = sText & "Packets Received Guaranteed=" & CStr(dpnInfo.lPacketsReceivedGuaranteed) & vbCrLf
sText = sText & "Bytes Received Non-Guaranteed=" & CStr(dpnInfo.lBytesReceivedNonGuaranteed) & vbCrLf
sText = sText & "Packets Received Non-Guaranteed=" & CStr(dpnInfo.lPacketsReceivedNonGuaranteed) & vbCrLf
sText = sText & "Messages Received=" & CStr(dpnInfo.lMessagesReceived) & vbCrLf
sText = sText & "Loss Rate=" & CStr(lDrops \ 100) & "." & CStr(lDrops Mod 100) & vbCrLf
txtInfo.Text = sText
Else
txtInfo.Text = vbNullString
End If
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)
If dpnotify.hResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
End If
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)
Dim lCount As Long
Dim dpPeer As DPN_PLAYER_INFO
'When someone joins add them to the 'Target' combo box
'and update the number of players list
dpPeer = dpp.GetPeerInfo(lPlayerID)
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = 0 Then 'This isn't me add this user
cboTarget.AddItem dpPeer.Name
cboTarget.ItemData(cboTarget.ListCount - 1) = lPlayerID
cboInfoTarget.AddItem dpPeer.Name
cboInfoTarget.ItemData(cboInfoTarget.ListCount - 1) = lPlayerID
End If
'Update our player count,and enable the send button (if need be)
lblPlayers.Caption = CStr(cboTarget.ListCount)
cmdSend.Enabled = (cboTarget.ListCount > 1)
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
Dim dpPeer As DPN_PLAYER_INFO
'Remove this player from our list
For lCount = 0 To cboTarget.ListCount - 1
If cboTarget.ItemData(lCount) = lPlayerID Then 'This is the player
cboTarget.RemoveItem lCount
Exit For
End If
Next
For lCount = 0 To cboInfoTarget.ListCount - 1
If cboInfoTarget.ItemData(lCount) = lPlayerID Then 'This is the player
cboInfoTarget.RemoveItem lCount
Exit For
End If
Next
'Update our player count,and enable the send button (if need be)
lblPlayers.Caption = CStr(cboTarget.ListCount)
cmdSend.Enabled = (cboTarget.ListCount > 1)
'If we are sending, and there is no one left to send to, or the person we were sending too left, stop sending
If (mfSending) And ((cboTarget.ListCount = 0) Or (mlToPlayerID = lPlayerID)) Then cmdSend_Click
If cboInfoTarget.ListIndex < 0 Then cboInfoTarget.ListIndex = 0
If cboTarget.ListIndex < 0 Then cboTarget.ListIndex = 0
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)
Dim dpPeer As DPN_PLAYER_INFO
dpPeer = dpp.GetPeerInfo(lNewHostID)
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then 'I am the new host
Me.Caption = Me.Caption & " (HOST)"
End If
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 demo is what msgs we receive.
Dim lMsg As Long, lOffset As Long
Dim oPacket As PacketInfo
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case MSG_GamePacket 'We received a packet
'Update the UI showing we received the packet
GetDataFromBuffer .ReceivedData, oPacket, LenB(oPacket), lOffset
moReceived.Add CStr(dpnotify.idSender) & ";" & CStr(oPacket.lPacketID) & ";" & CStr(oPacket.lDataSize)
Case MSG_PacketReceive 'They received a packet we sent
'Update the UI showing we received the packet
GetDataFromBuffer .ReceivedData, oPacket, LenB(oPacket), lOffset
AppendText "Sent packet #" & CStr(oPacket.lPacketID) & " to " & GetName(dpnotify.idSender) & " - Size:" & CStr(oPacket.lDataSize)
End Select
End With
End Sub
Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
If dpnotify.hResultCode = DPNERR_TIMEDOUT Then 'our packet timed out
AppendText "Packet Timed Out... "
End If
'The send has completed, so DPlay no longer has a need for our
'buffer, so we can get rid of it now.
Erase moByte
Erase moBuf
'Allow the next send to happen
mfInSend = False
End Sub
Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
'This connection has been terminated.
If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
MsgBox "The host has terminated this session. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
Else
MsgBox "This session has been lost. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
End If
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DataRelay/frmDataRelay.frx Normal file
View File

Binary file not shown.

50
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DataRelay/modDplay.bas Normal file
View File

@@ -0,0 +1,50 @@
Attribute VB_Name = "modDplay"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDplay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Sleep declare
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Enum vbDplayDataRelayMsgType
MSG_GamePacket
MSG_PacketReceive
End Enum
'Constants
Public Const AppGuid = "{0A947595-45D1-48f0-AEE2-E7CF851A1EEE}"
Public dx As DirectX8
Public dpp As DirectPlay8Peer
'App specific variables
Public gsUserName As String
'Our connection form and message pump
Public DPlayEventsForm As DPlayConnect
Public Sub InitDPlay()
'Create our DX/DirectPlay objects
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
End Sub
Public Sub Cleanup()
If Not (DPlayEventsForm Is Nothing) Then
'Get rid of our message pump
DPlayEventsForm.GoUnload
dpp.UnRegisterMessageHandler
'Close down our session
DPlayEventsForm.DoSleep 50
If Not (dpp Is Nothing) Then dpp.Close
'Lose references to peer and dx objects
Set dpp = Nothing
Set dx = Nothing
End If
End Sub

61
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DataRelay/readme.txt Normal file
View File

@@ -0,0 +1,61 @@
//-----------------------------------------------------------------------------
//
// Sample Name: DataRelay Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
The DataRelay is similar to SimplePeer but differs by sending a single
target (or everyone) a packet of data with options specified in the
dialog's UI.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\DataRelay
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Host or connect to a session in the same manner as explained in SimplePeer.
When the main dialog appears select the target, size, rate, and timeout values.
Then click "Push to Send". This will send a packet of data to the target as
the rate specified with the specified size.
Programming Notes
=================
The DataRelay sample is very similar in form to the SimplePeer sample. For
detailed programming notes on the basics this sample, refer to Programming
Notes section of the SimplePeer sample.
The DataRelay differs by sending a single target (or everyone) a packet of
data with options specified in the dialog's UI.
When the "Push to Send" button is clicked, a timer goes off every number of
ms according to the UI and sends data.
* When the timer notices it's time to send data, it does the following:
1. Creates a byte array with the options specified in the UI.
2. DirectPlay8Peer.SendTo is called passing in the byte array. We
call SendTo with the flags DPNSEND_NOLOOPBACK. DPNSEND_NOLOOPBACK tells
DirectPlay to not to send the buffer to us.
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
The DataRelay handles the typical messages as described in the
SimplePeer programming notes, and in addition:
- Upon Receive event
1. Gets the message type from the received byte array.
2. It then selects off the message type.
3. If its a MSG_GamePacket, then it adds the data to a collection,
where a timer will notice the data and process it. This is important
so the DirectPlay threads stay working atfull speed.
- Upon DPN_MSGID_SEND_COMPLETE
1. It checks the dpnotify.hResultCode for DPNERR_TIMEDOUT.
2. If this occurs then it updates the UI.

32
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DataRelay/vb_DataRelay.vbp Normal file
View File

@@ -0,0 +1,32 @@
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=frmDataRelay.frm
Form=..\..\common\DplayCon.frm
Module=modDplay; modDplay.bas
Startup="frmDataRelay"
Command32=""
Name="vbDataRelay"
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

188
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/PicForm.frm Normal file
View File

@@ -0,0 +1,188 @@
VERSION 5.00
Begin VB.Form frmPics
Caption = "PicForm"
ClientHeight = 4035
ClientLeft = 60
ClientTop = 345
ClientWidth = 7485
LinkTopic = "Form2"
ScaleHeight = 4035
ScaleWidth = 7485
StartUpPosition = 3 'Windows Default
Begin VB.Image Image1
Height = 1005
Index = 0
Left = 240
Picture = "PicForm.frx":0000
Stretch = -1 'True
Top = 120
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 1
Left = 1440
Picture = "PicForm.frx":018A
Stretch = -1 'True
Top = 120
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 2
Left = 2640
Picture = "PicForm.frx":0314
Stretch = -1 'True
Top = 120
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 6
Left = 240
Picture = "PicForm.frx":049E
Stretch = -1 'True
Top = 1440
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 7
Left = 1440
Picture = "PicForm.frx":0628
Stretch = -1 'True
Top = 1440
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 8
Left = 2640
Picture = "PicForm.frx":07B2
Stretch = -1 'True
Top = 1440
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 9
Left = 3840
Picture = "PicForm.frx":093C
Stretch = -1 'True
Top = 1440
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 10
Left = 5040
Picture = "PicForm.frx":0AC6
Stretch = -1 'True
Top = 1440
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 11
Left = 6240
Picture = "PicForm.frx":0C50
Stretch = -1 'True
Top = 1440
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 5
Left = 6240
Picture = "PicForm.frx":0DDA
Stretch = -1 'True
Top = 120
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 4
Left = 5040
Picture = "PicForm.frx":0F64
Stretch = -1 'True
Top = 120
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 3
Left = 3840
Picture = "PicForm.frx":10EE
Stretch = -1 'True
Top = 120
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 12
Left = 240
Picture = "PicForm.frx":1278
Stretch = -1 'True
Top = 2760
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 13
Left = 1440
Picture = "PicForm.frx":1402
Stretch = -1 'True
Top = 2760
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 14
Left = 2640
Picture = "PicForm.frx":158C
Stretch = -1 'True
Top = 2760
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 15
Left = 3840
Picture = "PicForm.frx":1716
Stretch = -1 'True
Top = 2760
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 16
Left = 5040
Picture = "PicForm.frx":18A0
Stretch = -1 'True
Top = 2760
Width = 1005
End
Begin VB.Image Image1
Height = 1005
Index = 17
Left = 6240
Picture = "PicForm.frx":1A2A
Stretch = -1 'True
Top = 2760
Width = 1005
End
End
Attribute VB_Name = "frmPics"
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: picForm.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/PicForm.frx Normal file
View File

Binary file not shown.

1005
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/PlayForm.frm Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/PlayForm.frx Normal file
View File

Binary file not shown.

98
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/frmIntro.frm Normal file
View File

@@ -0,0 +1,98 @@
VERSION 5.00
Begin VB.Form frmIntro
BorderStyle = 3 'Fixed Dialog
Caption = "VB Memory - A DirectPlay Sample"
ClientHeight = 1515
ClientLeft = 45
ClientTop = 330
ClientWidth = 2745
Icon = "frmIntro.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1515
ScaleWidth = 2745
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdSingle
Caption = "Solitaire"
Height = 375
Left = 315
TabIndex = 2
Top = 1020
Width = 975
End
Begin VB.CommandButton cmdMulti
Caption = "Multiplayer"
Default = -1 'True
Height = 375
Left = 1455
TabIndex = 0
Top = 1020
Width = 975
End
Begin VB.Label lbl
BackStyle = 0 'Transparent
Caption = "This sample will show a developer a simplistic game (Memory). Please choose how you would like to play this game."
Height = 1035
Left = 60
TabIndex = 1
Top = 60
Width = 2475
End
End
Attribute VB_Name = "frmIntro"
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: frmIntro.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdMulti_Click()
Dim StagingArea As New frmStage
'Oh good, we want to play a multiplayer game.
'First lets get the dplay connection started
'Here we will init our DPlay objects
InitDPlay
Set DPlayEventsForm = New DPlayConnect
Load StagingArea
EnableButtons False
'We only want to have a maximum of 4 players
If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 4, StagingArea) Then
Cleanup
EnableButtons True
Else 'We did choose to play a game
gsUserName = DPlayEventsForm.UserName
Me.Hide
StagingArea.Show vbModeless
gfHost = DPlayEventsForm.IsHost
End If
End Sub
Private Sub cmdSingle_Click()
'We don't want to use DPlay, close down our objects
Cleanup
gbNumPlayers = 1
EnableButtons False
Me.Hide
frmGameBoard.Show
End Sub
Private Sub Form_Unload(Cancel As Integer)
Cleanup
End
End Sub
Public Sub EnableButtons(ByVal fEnable As Boolean)
cmdMulti.Enabled = fEnable
cmdSingle.Enabled = fEnable
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/frmIntro.frx Normal file
View File

Binary file not shown.

274
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/frmStage.frm Normal file
View File

@@ -0,0 +1,274 @@
VERSION 5.00
Begin VB.Form frmStage
BorderStyle = 3 'Fixed Dialog
Caption = "VB Memory Staging Area..."
ClientHeight = 1575
ClientLeft = 45
ClientTop = 330
ClientWidth = 3060
Icon = "frmStage.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1575
ScaleWidth = 3060
StartUpPosition = 3 'Windows Default
Begin VB.Frame Frame1
Caption = "Session Status"
Height = 735
Left = 120
TabIndex = 2
Top = 120
Width = 2775
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Current number of players:"
Height = 195
Left = 120
TabIndex = 4
Top = 300
Width = 1935
End
Begin VB.Label lblPlayer
BorderStyle = 1 'Fixed Single
Height = 315
Left = 2160
TabIndex = 3
Top = 240
Width = 495
End
End
Begin VB.CommandButton cmdLeave
Cancel = -1 'True
Caption = "Leave"
Height = 435
Left = 600
TabIndex = 1
Top = 960
Width = 1095
End
Begin VB.CommandButton cmdStart
Caption = "Start"
Default = -1 'True
Enabled = 0 'False
Height = 435
Left = 1800
TabIndex = 0
Top = 960
Width = 1095
End
End
Attribute VB_Name = "frmStage"
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: frmStage.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private fStartGame As Boolean
Private Sub cmdLeave_Click()
'We don't want to play. Exit
frmIntro.Visible = True
frmIntro.EnableButtons True
Unload Me
End Sub
Private Sub cmdStart_Click()
Dim oSendBuffer() As Byte
Dim lCount As Long, lOffset As Long
Dim lClient As Long
'Dim oPBuf() As Byte
'Ok we're ready to start the game now.
'First how many players do we have?
gbNumPlayers = dpp.GetCountPlayersAndGroups(DPNENUM_PLAYERS)
' Initialize game state
SetupBoard
lOffset = NewBuffer(oSendBuffer)
AddDataToBuffer oSendBuffer, CByte(MSG_SETUPBOARD), SIZE_BYTE, lOffset
AddDataToBuffer oSendBuffer, CByte(gbNumPlayers), SIZE_BYTE, lOffset
'Add each player's id now (this will determine the order of play)
For lCount = 1 To gbNumPlayers
lClient = dpp.GetPlayerOrGroup(lCount)
AddDataToBuffer oSendBuffer, lClient, LenB(lClient), lOffset
'Keep track of the order ourselves
glPlayerIDs(lCount - 1) = lClient
Next
'Keep track of the offset in our byte array of where the data for the board starts
For lCount = 1 To NumCells
AddDataToBuffer oSendBuffer, gbPicArray(lCount - 1), LenB(gbPicArray(lCount - 1)), lOffset
Next lCount
'Now that we've created our byte array of data to start the game
'We can actually send that msg, and start the game
SendMessage oSendBuffer
fStartGame = True
Unload Me
frmGameBoard.Show vbModeless
End Sub
Private Sub Form_Load()
Dim lCount As Long
Dim lFlags As Long
If dpp Is Nothing Then Exit Sub
'Register me as the message handler
DPlayEventsForm.RegisterCallback Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Not fStartGame Then
'make sure the intro form is visible again
frmIntro.Visible = True
frmIntro.EnableButtons True
If Not (DPlayEventsForm Is Nothing) Then DPlayEventsForm.DoSleep 50
Cleanup
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)
If dpnotify.hResultCode = DPNERR_HOSTREJECTEDCONNECTION Then
MsgBox "The host would not allow you to join the game. The game has already started.", vbOKOnly Or vbInformation, "Started"
DPlayEventsForm.CloseForm Me
ElseIf dpnotify.hResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
End If
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)
Dim lCount As Long
gbNumPlayers = gbNumPlayers + 1
lblPlayer.Caption = CStr(gbNumPlayers)
If gbNumPlayers > 1 Then
cmdStart.Enabled = gfHost
Else
cmdStart.Enabled = False
End If
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)
gbNumPlayers = gbNumPlayers - 1
lblPlayer.Caption = CStr(gbNumPlayers)
If gbNumPlayers > 1 Then
cmdStart.Enabled = gfHost
Else
cmdStart.Enabled = False
End If
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)
Dim dpPeer As DPN_PLAYER_INFO
dpPeer = dpp.GetPeerInfo(lNewHostID)
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then 'I am the new host
gfHost = True
MsgBox "Congratulations, You are the new host.", vbOKOnly Or vbInformation, "New host."
End If
If gbNumPlayers > 1 Then
cmdStart.Enabled = gfHost
Else
cmdStart.Enabled = False
End If
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)
Dim lCount As Long, lOffset As Long
Dim bMsg As Byte, lNumPlayers As Byte
'Here we will go through the messages
'The first item in our byte array is the MSGID we passed in
With dpnotify
GetDataFromBuffer .ReceivedData, bMsg, LenB(bMsg), lOffset
Select Case bMsg
Case MSG_SETUPBOARD
' Number of players
GetDataFromBuffer .ReceivedData, gbNumPlayers, LenB(gbNumPlayers), lOffset
' Play IDs, in play order. Unused players have ID of 0.
For lCount = 0 To gbNumPlayers - 1
GetDataFromBuffer .ReceivedData, glPlayerIDs(lCount), LenB(glPlayerIDs(lCount)), lOffset
'If glPlayerIDs(lCount) = gMyPlayerID Then gMyTurn = lCount
Next lCount
' Tile arrangment
For lCount = 0 To NumCells - 1
GetDataFromBuffer .ReceivedData, gbPicArray(lCount), LenB(gbPicArray(lCount)), lOffset
Next lCount
' Show the game board. The scoreboard is initialized in the Load method.
fStartGame = True
Unload Me
frmGameBoard.Show vbModeless
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)
If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
MsgBox "The host has terminated this session. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
Else
MsgBox "This session has been lost. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
End If
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/frmStage.frx Normal file
View File

Binary file not shown.

98
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/modDPlay.bas Normal file
View File

@@ -0,0 +1,98 @@
Attribute VB_Name = "modDPlay"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDplay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Here are our msgs
Public Enum Const_MemoryMsgs
MSG_SETUPBOARD
MSG_SHOWPIECE
MSG_HIDEPIECES
MSG_TURNEND
MSG_CHAT
MSG_MATCHED
End Enum
'Constants
Public Const NumCells = 36
Public Const MaxPlayers = 4
Public Const AppGuid = "{31368C80-341E-4365-BD80-66D203D367BE}"
Public dx As DirectX8
Public dpp As DirectPlay8Peer
'App vars
Public gbNumPlayers As Byte
Public gsUserName As String
Public gbPicArray(NumCells) As Byte
Public gfMatchedCells(NumCells) As Boolean
Public glCurrentPlayer As Long
Public gbPlayerScores(MaxPlayers) As Byte
Public glPlayerIDs(MaxPlayers) As Long ' Indexed by order of play
Public glMyPlayerID As Long
Public gfHost As Boolean
Public DPlayEventsForm As DPlayConnect
Public Sub InitDPlay()
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
End Sub
Public Sub Cleanup()
'Terminate our session if there is one
gbNumPlayers = 0
If Not (DPlayEventsForm Is Nothing) Then
'Turn off our message handler
If Not (dpp Is Nothing) Then dpp.UnRegisterMessageHandler
'Close down our session
If Not (dpp Is Nothing) Then dpp.Close
'Lose references to peer and dx objects
Set dpp = Nothing
Set dx = Nothing
'Get rid of our message pump
DPlayEventsForm.GoUnload
End If
End Sub
' Assign pieces to cells and initialize the state. Done only by the host
' in the multiplayer game. In single-player, can be called to restart.
Public Sub SetupBoard()
Dim lCount As Integer
Dim Pic As Integer
Dim PicInstance As Integer
Dim RandCell As Integer
' Empty the image index array
For lCount = 0 To NumCells - 1
gbPicArray(lCount) = 0
Next lCount
' Assign pictures to cells
' For every picture except #0, find two empty cells. The two leftover cells
' have picture #0 by default.
' PicArray indexes the play cells into the image cells stored on the invisible form.
For Pic = 1 To NumCells \ 2 - 1
For PicInstance = 1 To 2
Randomize
Do
RandCell = Fix(Rnd * NumCells)
Loop Until gbPicArray(RandCell) = 0
gbPicArray(RandCell) = Pic
Next PicInstance
Next Pic
End Sub
Public Sub SendMessage(oBuf() As Byte)
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
End Sub

54
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/readme.txt Normal file
View File

@@ -0,0 +1,54 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Memory Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
Memory is a simple game in which you match 'tiles' and try to score the most
points.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Memory
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Choose Multiplayer or Solitaire, and then just select images and try to
get a match. Score one point for every match. In multiplayer mode try to
get more matches than your opponent(s). In solitaire mode, try to clear the
board in as few attempts as possible.
Programming Notes
=================
The Memory sample is very similar in form to the SimplePeer sample. For
detailed programming notes on the basics this sample, refer to Programming
Notes section of the SimplePeer sample.
* An image is clicked.
1. If it's your turn, show the picture.
2. Fills out a byte array telling everyone else to show the picture.
3. Calls DirectPlay8Peer.SendTo with the byte array. It passes
DPNID_ALL_PLAYERS_GROUP so this message goes to everyone.
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
The Chat sample handles the typical messages as described in the
SimplePeer programming notes, and in addition:
- Upon Receive event:
*Checks the type of this message.
*Selects off of the message type.
*If MSG_SETUPBOARD, retreive board information and udpate local state.
*If MSG_SHOWPIECE, show the indicated piece.
*If MSG_HIDEPIECES, hide all pieces that aren't currently matched.
*If MSG_TURNEND, advance to the next players turn.
*If MSG_CHAT, receive a text string, and update the UI.
*If MSG_MATCHED, set the state so these two pictures are matched.

35
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/Memory/vb_Memory.vbp Normal file
View File

@@ -0,0 +1,35 @@
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=frmIntro.frm
Module=modDPlay; modDPlay.bas
Form=PicForm.frm
Form=PlayForm.frm
Form=..\..\common\DplayCon.frm
Form=frmStage.frm
Startup="frmIntro"
ExeName32="vb_Memory.exe"
Command32=""
Name="vbMemory"
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
ThreadPerObject=0
MaxNumberOfThreads=1

238
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleClient/frmClient.frm Normal file
View File

@@ -0,0 +1,238 @@
VERSION 5.00
Begin VB.Form frmClient
BorderStyle = 3 'Fixed Dialog
Caption = "vbSimple Client"
ClientHeight = 4470
ClientLeft = 45
ClientTop = 330
ClientWidth = 5400
Icon = "frmClient.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4470
ScaleWidth = 5400
StartUpPosition = 3 'Windows Default
Begin VB.Frame Rules
Caption = "Rules"
Height = 855
Left = 60
TabIndex = 6
Top = 120
Width = 5295
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = $"frmClient.frx":0442
Height = 615
Index = 1
Left = 60
TabIndex = 7
Top = 180
Width = 5055
End
End
Begin VB.CommandButton cmdExit
Cancel = -1 'True
Caption = "Exit"
Height = 375
Left = 3143
TabIndex = 5
Top = 4020
Width = 1215
End
Begin VB.CommandButton cmdFace
Caption = "Make Faces"
Default = -1 'True
Height = 375
Left = 1043
TabIndex = 4
Top = 4020
Width = 1215
End
Begin VB.TextBox txtUserInfo
BackColor = &H8000000F&
Height = 1935
Left = 60
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 1
Top = 1980
Width = 5295
End
Begin VB.Frame Frame1
Caption = "User Stats"
Height = 915
Left = 60
TabIndex = 0
Top = 1020
Width = 5235
Begin VB.Label lblSession
BackStyle = 0 'Transparent
Height = 255
Left = 120
TabIndex = 3
Top = 240
Width = 4935
End
Begin VB.Label lblStats
BackStyle = 0 'Transparent
Height = 255
Left = 120
TabIndex = 2
Top = 540
Width = 4995
End
End
End
Attribute VB_Name = "frmClient"
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: frmClient.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private Enum MsgTypes
Msg_NoOtherPlayers
Msg_NumPlayers
Msg_SendWave
End Enum
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdFace_Click()
'Now we just need to 'make faces'
Dim oMsg() As Byte, lOffset As Long
lOffset = NewBuffer(oMsg)
AddDataToBuffer oMsg, CByte(1), SIZE_BYTE, lOffset
dpc.Send oMsg, 0, DPNSEND_NOLOOPBACK
End Sub
Private Sub Form_Load()
Set DPlayEventsForm = New DPlayConnect
'First lets get the dplay connection started
If Not DPlayEventsForm.StartClientConnectWizard(dx, dpc, AppGuid, 10, Me) Then
Cleanup
End
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.Hide
DPlayEventsForm.DoSleep 50
Cleanup
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)
Dim AppDesc As DPN_APPLICATION_DESC
If dpnotify.hResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
Else
AppDesc = dpc.GetApplicationDesc(0)
Me.Caption = AppDesc.SessionName
lblSession = "Session Name: " & AppDesc.SessionName
lblStats.Caption = "Total clients: " & CStr(AppDesc.lCurrentPlayers) & "/" & CStr(AppDesc.lMaxPlayers)
End If
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)
'The server is telling us something. What?
Dim sPlayer As String, lOffset As Long
Dim lMsg As Long, lNum As Long, lMax As Long
GetDataFromBuffer dpnotify.ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case Msg_NumPlayers
GetDataFromBuffer dpnotify.ReceivedData, lNum, LenB(lNum), lOffset
GetDataFromBuffer dpnotify.ReceivedData, lMax, LenB(lMax), lOffset
lblStats.Caption = "Total clients: " & CStr(lNum) & "/" & CStr(lMax)
Case Msg_NoOtherPlayers
txtUserInfo.Text = txtUserInfo.Text & "There are no other players to make funny faces at!" & vbCrLf
txtUserInfo.SelStart = Len(txtUserInfo.Text)
Case Msg_SendWave
'The only data we will receive is player info
sPlayer = GetStringFromBuffer(dpnotify.ReceivedData, lOffset)
'Append the data to the end of the line, and autoscroll there
txtUserInfo.Text = txtUserInfo.Text & sPlayer & " is making faces at you!" & vbCrLf
txtUserInfo.SelStart = Len(txtUserInfo.Text)
End Select
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)
If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
MsgBox "The host has terminated this session. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
Else
MsgBox "This session has been lost. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
End If
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleClient/frmClient.frx Normal file
View File

Binary file not shown.

39
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleClient/modDplayClient.bas Normal file
View File

@@ -0,0 +1,39 @@
Attribute VB_Name = "modDplayClient"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlayClient.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const AppGuid = "{5726CF1F-702B-4008-98BC-BF9C95F9E288}"
Public dx As New DirectX8
Public dpc As DirectPlay8Client
Public DPlayEventsForm As DPlayConnect
Public Sub Main()
InitDPlay
frmClient.Show
End Sub
Public Sub InitDPlay()
Set dpc = dx.DirectPlayClientCreate
End Sub
Public Sub Cleanup()
'Stop our message handler
If Not dpc Is Nothing Then dpc.UnRegisterMessageHandler
'Close down our session
If Not dpc Is Nothing Then dpc.Close
Set dpc = Nothing
Set dx = Nothing
'Get rid of our message pump
DPlayEventsForm.GoUnload
End Sub

41
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleClient/readme.txt Normal file
View File

@@ -0,0 +1,41 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Simple Client Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
A very simplistic Client application that can only connect to a server, and
make funny faces to other players on that server.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\SimpleClient
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Connect to a server, and make funny faces.
Programming Notes
=================
The SimpleClient sample allows players to make funny faces at anyone else on the server.
* The "Make Faces" button is pressed. See cmdFace_Click.
1. Fills out a byte array using nothing, since all we can do is make faces.
2. Calls DirectPlay8Client.Send with the byte array. The server will receive
this message and handle it.
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
- Upon Receive event:
Checks message type, and if the following:
Msg_NumPlayers - Change the number of current and max players in this session, update UI
Msg_NoOtherPlayers - Notify the client there are no other players in the session
Msg_SendWave - Notify that someone made a funny face at us.

34
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleClient/vb_SimpleClient.vbp Normal file
View File

@@ -0,0 +1,34 @@
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=frmClient.frm
Module=modDplayClient; modDplayClient.bas
Form=..\..\common\DplayCon.frm
IconForm="frmClient"
Startup="Sub Main"
HelpFile=""
Title="vbSimpleClient"
Command32=""
Name="vbSimpleClient"
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
ThreadPerObject=0
MaxNumberOfThreads=1

266
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimplePeer/frmApp.frm Normal file
View File

@@ -0,0 +1,266 @@
VERSION 5.00
Begin VB.Form frmApp
BorderStyle = 3 'Fixed Dialog
Caption = "Session"
ClientHeight = 4470
ClientLeft = 45
ClientTop = 330
ClientWidth = 5400
Icon = "frmApp.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4470
ScaleWidth = 5400
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdExit
Cancel = -1 'True
Caption = "Exit"
Height = 315
Left = 3383
TabIndex = 9
Top = 4020
Width = 1035
End
Begin VB.Frame Rules
Caption = "Rules"
Height = 735
Left = 60
TabIndex = 5
Top = 60
Width = 5295
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = $"frmApp.frx":0442
Height = 435
Index = 1
Left = 60
TabIndex = 6
Top = 180
Width = 5175
End
End
Begin VB.TextBox txtFace
BackColor = &H8000000F&
Height = 2295
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 4
Top = 1620
Width = 5235
End
Begin VB.CommandButton cmdMakeFace
Caption = "Make Face"
Default = -1 'True
Height = 315
Left = 983
TabIndex = 1
Top = 4020
Width = 1035
End
Begin VB.Frame Frame1
Caption = "Game Status"
Height = 735
Left = 60
TabIndex = 0
Top = 840
Width = 5295
Begin VB.Label lblPlayerName
BackStyle = 0 'Transparent
Height = 255
Left = 1980
TabIndex = 8
Top = 180
Width = 3135
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Local Player Name:"
Height = 195
Index = 2
Left = 120
TabIndex = 7
Top = 180
Width = 1935
End
Begin VB.Label lblPlayer
BackStyle = 0 'Transparent
Height = 255
Left = 2040
TabIndex = 3
Top = 420
Width = 3075
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Current number of players:"
Height = 195
Index = 0
Left = 120
TabIndex = 2
Top = 420
Width = 1935
End
End
End
Attribute VB_Name = "frmApp"
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: frmApp.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private Const gbMSGFACE As Byte = 1
Private msName As String
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdMakeFace_Click()
Dim Buf() As Byte, lOffSet As Long
'For the purpose of this sample we don't care what the contents of the buffer
'will be. Since there is only one application defined msg in this sample
'sending anything will suffice.
If glNumPlayers > 1 Then 'Go ahead and send this to someone
lOffSet = NewBuffer(Buf)
AddDataToBuffer Buf, gbMSGFACE, SIZE_BYTE, lOffSet
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, Buf, 0, DPNSEND_NOLOOPBACK
Else
UpdateText "There is no one to make faces at!!!"
End If
End Sub
Private Sub Form_Load()
'Init our vars
InitDPlay
Set DPlayEventsForm = New DPlayConnect
'First lets get the dplay connection started
If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 10, Me) Then
Cleanup
End
End If
gfHost = DPlayEventsForm.IsHost
msName = DPlayEventsForm.UserName
lblPlayerName.Caption = msName
If gfHost Then
Me.Caption = DPlayEventsForm.SessionName & " (HOST)"
End If
lblPlayer.Caption = CStr(glNumPlayers)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Cleanup
End Sub
Private Sub UpdateText(ByVal sString As String)
'Update the chat window first
txtFace.Text = txtFace.Text & sString & vbCrLf
'Now limit the text in the window to be 16k
If Len(txtFace.Text) > 16384 Then
txtFace.Text = Right$(txtFace.Text, 16384)
End If
'Autoscroll the text
txtFace.SelStart = Len(txtFace.Text)
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)
Dim AppDesc As DPN_APPLICATION_DESC
'Go ahead and put the session name in the title bar
AppDesc = dpp.GetApplicationDesc
Me.Caption = AppDesc.SessionName
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)
'Someone joined, increment the count
glNumPlayers = glNumPlayers + 1
lblPlayer.Caption = CStr(glNumPlayers)
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)
'Someone left, decrement the count
glNumPlayers = glNumPlayers - 1
lblPlayer.Caption = CStr(glNumPlayers)
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)
Dim dpPeer As DPN_PLAYER_INFO
dpPeer = dpp.GetPeerInfo(lNewHostID)
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then 'I am the new host
Me.Caption = Me.Caption & " (HOST)"
End If
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)
'There is only one msg that can be sent in this sample
Dim sPeer As String
sPeer = dpp.GetPeerInfo(dpnotify.idSender).Name
UpdateText sPeer & " is making funny faces at you, " & msName
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)
If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
MsgBox "The host has terminated this session. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
Else
MsgBox "This session has been lost. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
End If
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimplePeer/frmApp.frx Normal file
View File

Binary file not shown.

38
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimplePeer/modDPlay.bas Normal file
View File

@@ -0,0 +1,38 @@
Attribute VB_Name = "modDPlay"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Win32 declares
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'Constants
Public Const AppGuid = "{74377695-900D-4fdb-98F7-AC6BCAD2C631}"
Public dx As DirectX8
Public dpp As DirectPlay8Peer
Public glNumPlayers As Long
Public gfHost As Boolean
Public DPlayEventsForm As DPlayConnect
Public Sub InitDPlay()
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
End Sub
Public Sub Cleanup()
If Not dpp Is Nothing Then dpp.UnRegisterMessageHandler 'Stop taking messages
'Close our peer connection
If Not dpp Is Nothing Then dpp.Close
'Lose references to peer and dx objects
Set dpp = Nothing
Set dx = Nothing
DPlayEventsForm.GoUnload
End Sub

38
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimplePeer/readme.txt Normal file
View File

@@ -0,0 +1,38 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Simple Peer Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
Once a player hosts or connects to a session, the players can make funny faces.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\SimplePeer
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Select the protocol to use, enter your name. Choose to search for sessions or create
your own, or to wait for a lobby session. Once connected, make funny faces.
Programming Notes
=================
* The "Make Face" key is pressed. See cmdMakeFace_Click.
1. Fills out a byte array using 1 since this is the only message to send.
2. Calls DirectPlay8Peer.SendTo with the byte array. It passes
DPNID_ALL_PLAYERS_GROUP so this message goes to everyone.
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
The Chat sample handles the typical messages as described in the
SimplePeer programming notes, and in addition:
- Upon Receive event:
*Get the name of the person sending the event, and update UI

32
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimplePeer/vb_SimplePeer.vbp Normal file
View File

@@ -0,0 +1,32 @@
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
Module=modDPlay; modDPlay.bas
Form=frmApp.frm
Form=..\..\common\DplayCon.frm
Startup="frmApp"
HelpFile=""
Command32=""
Name="vbSimplePeer"
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
ThreadPerObject=0
MaxNumberOfThreads=1

414
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleServer/frmServer.frm Normal file
View File

@@ -0,0 +1,414 @@
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmServer
BorderStyle = 3 'Fixed Dialog
Caption = "DirectPlay Simple Server"
ClientHeight = 4875
ClientLeft = 45
ClientTop = 330
ClientWidth = 3660
Icon = "frmServer.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4875
ScaleWidth = 3660
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdStartServer
Caption = "Start Server"
Default = -1 'True
Height = 375
Left = 1283
TabIndex = 9
Top = 4080
Width = 1095
End
Begin VB.ListBox lstUser
Height = 1815
Left = 120
TabIndex = 8
Top = 2160
Width = 3375
End
Begin MSComctlLib.StatusBar sBar
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 7
Top = 4500
Width = 3660
_ExtentX = 6456
_ExtentY = 661
Style = 1
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
Begin MSComCtl2.UpDown udUsers
Height = 315
Left = 3180
TabIndex = 5
Top = 1740
Width = 240
_ExtentX = 423
_ExtentY = 556
_Version = 393216
Value = 50
BuddyControl = "txtUsers"
BuddyDispid = 196611
OrigLeft = 1800
OrigTop = 660
OrigRight = 2040
OrigBottom = 975
Max = 1000
Min = 1
SyncBuddy = -1 'True
BuddyProperty = 65547
Enabled = -1 'True
End
Begin VB.TextBox txtUsers
Height = 315
Left = 2760
Locked = -1 'True
TabIndex = 4
Text = "50"
Top = 1740
Width = 435
End
Begin VB.TextBox txtSession
Height = 315
Left = 120
TabIndex = 3
Text = "vbDirectPlaySession"
Top = 1320
Width = 3315
End
Begin VB.ListBox lstSP
Height = 645
Left = 120
TabIndex = 1
Top = 420
Width = 3375
End
Begin VB.Label lbl
BackStyle = 0 'Transparent
Caption = "Select the server's service provider"
Height = 195
Index = 2
Left = 120
TabIndex = 6
Top = 120
Width = 3435
End
Begin VB.Label lbl
BackStyle = 0 'Transparent
Caption = "Session Name"
Height = 195
Index = 1
Left = 120
TabIndex = 2
Top = 1080
Width = 1275
End
Begin VB.Label lbl
BackStyle = 0 'Transparent
Caption = "Maximum users:"
Height = 255
Index = 0
Left = 240
TabIndex = 0
Top = 1800
Width = 2415
End
Begin VB.Menu mnuPop
Caption = "PopUp"
Visible = 0 'False
Begin VB.Menu mnuShow
Caption = "Show"
End
Begin VB.Menu mnuStart
Caption = "Start Server"
End
Begin VB.Menu mnuSep
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "Exit"
End
End
End
Attribute VB_Name = "frmServer"
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: frmServer.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private mfExit As Boolean
Private Enum MsgTypes
Msg_NoOtherPlayers
Msg_NumPlayers
Msg_SendWave
End Enum
Private Sub cmdStartServer_Click()
Dim AppDesc As DPN_APPLICATION_DESC
If gfStarted Then Exit Sub
If Val(txtUsers.Text) < 1 Then
MsgBox "I'm sorry, you must allow at least 1 user to join your server.", vbOKOnly Or vbInformation, "Increase users"
Exit Sub
End If
If txtSession.Text = vbNullString Then
MsgBox "I'm sorry, you must enter a session name.", vbOKOnly Or vbInformation, "No session name"
Exit Sub
End If
'Save our current session name for later runs
SaveSetting "VBDirectPlay", "Defaults", "ServerGameName", txtSession.Text
'Now set up the app description
With AppDesc
.guidApplication = AppGuid
.lMaxPlayers = Val(txtUsers.Text)
.SessionName = txtSession.Text
.lFlags = DPNSESSION_CLIENT_SERVER 'We must pass the client server flags if we are a server
End With
'Now set up our address value
dpa.SetSP dps.GetServiceProvider(lstSP.ListIndex + 1).Guid
'Now start the server
dps.Host AppDesc, dpa
gfStarted = True
sBar.SimpleText = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
'modify our icon text
sysIcon.sTip = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
cmdStartServer.Enabled = False
End Sub
Private Sub Form_Load()
Dim lCount As Long
Dim dpn As DPN_SERVICE_PROVIDER_INFO
dps.RegisterMessageHandler Me
'First load our list of Service Providers into our box
For lCount = 1 To dps.GetCountServiceProviders
dpn = dps.GetServiceProvider(lCount)
lstSP.AddItem dpn.Name
'Pick the TCP/IP connection by default
If InStr(dpn.Name, "TCP") Then lstSP.ListIndex = lstSP.ListCount - 1
Next
If lstSP.ListIndex < 0 Then lstSP.ListIndex = 0
txtSession.Text = GetSetting("VBDirectPlay", "Defaults", "ServerGameName", "vbDirectPlayServer")
sBar.SimpleText = "Server not running..."
'Lets put an icon in the system tray
With sysIcon
.cbSize = LenB(sysIcon)
.hwnd = Me.hwnd
.uFlags = NIF_DOALL
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.sTip = "vbDirectPlayServer - Server not running" & 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
mnuShow_Click
Case WM_RBUTTONUP
'Show the menu
If gfStarted Then mnuStart.Enabled = False
PopupMenu mnuPop, , , , mnuShow
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)
Shell_NotifyIcon NIM_DELETE, sysIcon
Cleanup
End Sub
Private Sub mnuExit_Click()
mfExit = True
Unload Me
End Sub
Private Sub mnuShow_Click()
Me.Visible = True
Me.SetFocus
End Sub
Private Sub mnuStart_Click()
cmdStartServer_Click
End Sub
Private Sub udUsers_Change()
Dim AppDesc As DPN_APPLICATION_DESC
If gfStarted Then
'We need to reset our max users
AppDesc = dps.GetApplicationDesc(0)
AppDesc.lMaxPlayers = udUsers.Value
dps.SetApplicationDesc AppDesc, 0
sBar.SimpleText = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
'modify our icon text
sysIcon.sTip = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
NotifyEveryoneOfNumPlayers
End If
End Sub
Private Sub NotifyEveryoneOfNumPlayers()
Dim oBuf() As Byte
Dim lMsg As Long, lOffset As Long
'Here we will notify everyone currently in the session about the number of players in the session
lOffset = NewBuffer(oBuf)
lMsg = Msg_NumPlayers
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, glNumPlayers, LenB(glNumPlayers), lOffset
AddDataToBuffer oBuf, CLng(udUsers.Value), SIZE_LONG, lOffset
dps.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
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)
On Error Resume Next
Dim dpPeer As DPN_PLAYER_INFO
dpPeer = dps.GetClientInfo(lPlayerID)
If Err Then Exit Sub
glNumPlayers = glNumPlayers + 1
sBar.SimpleText = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
sysIcon.sTip = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
'Add this player to the list
lstUser.AddItem dpPeer.Name & " DPlay ID: 0x" & Hex$(lPlayerID)
lstUser.ItemData(lstUser.ListCount - 1) = lPlayerID
NotifyEveryoneOfNumPlayers
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
For lCount = lstUser.ListCount - 1 To 0 Step -1
If lstUser.ItemData(lCount) = lPlayerID Then 'remove this player from the list
lstUser.RemoveItem lCount
End If
Next
glNumPlayers = glNumPlayers - 1
sBar.SimpleText = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)"
sysIcon.sTip = "Server running... (" & CStr(glNumPlayers) & "/" & txtUsers.Text & " clients connected.)" & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
NotifyEveryoneOfNumPlayers
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)
Dim oNewMsg() As Byte, lOffset As Long
Dim lMsg As Long
'The only message we will receive from our client is one to make faces to everyone
'else on the server, if there is someone else to make faces at, do it, otherwise let
'them know
If glNumPlayers > 1 Then
lOffset = NewBuffer(oNewMsg)
lMsg = Msg_SendWave
AddDataToBuffer oNewMsg, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oNewMsg, dps.GetClientInfo(dpnotify.idSender).Name, lOffset
dps.SendTo DPNID_ALL_PLAYERS_GROUP, oNewMsg, 0, DPNSEND_NOLOOPBACK
Else
lOffset = NewBuffer(oNewMsg)
lMsg = Msg_NoOtherPlayers
AddDataToBuffer oNewMsg, lMsg, LenB(lMsg), lOffset
dps.SendTo DPNID_ALL_PLAYERS_GROUP, oNewMsg, 0, DPNSEND_NOLOOPBACK
End If
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/SimpleServer/frmServer.frx Normal file
View File

Binary file not shown.

66
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleServer/modDPlayServer.bas Normal file
View File

@@ -0,0 +1,66 @@
Attribute VB_Name = "modDPlayServer"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlayServer.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const AppGuid = "{5726CF1F-702B-4008-98BC-BF9C95F9E288}"
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
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
Public dx As New DirectX8
Public dps As DirectPlay8Server
Public dpa As DirectPlay8Address
Public glNumPlayers As Long
Public gfStarted As Boolean
Public sysIcon As NOTIFYICONDATA
Public Sub Main()
InitDPlay
frmServer.Show
End Sub
Public Sub InitDPlay()
Set dps = dx.DirectPlayServerCreate
Set dpa = dx.DirectPlayAddressCreate
End Sub
Public Sub Cleanup()
'Shut down our message handler
If Not dps Is Nothing Then dps.UnRegisterMessageHandler
'Close down our session
If Not dps Is Nothing Then dps.Close
Set dps = Nothing
Set dpa = Nothing
Set dx = Nothing
End Sub

34
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleServer/readme.txt Normal file
View File

@@ -0,0 +1,34 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Simple Server Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
A very simplistic Server application that can only connect route client messages.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\SimpleServer
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Connect to a server, and make funny faces.
Programming Notes
=================
The SimpleServer sample allows players to make funny faces at anyone else on the server.
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
- Upon Receive event:
Checks to see if there is more than one player in the session. If there is, notify
everyone that a funny face was made. Otherwsie notify the client that they are
the only player in the session.

36
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleServer/vb_SimpleServer.vbp Normal file
View File

@@ -0,0 +1,36 @@
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=frmServer.frm
Module=modDPlayServer; modDPlayServer.bas
Object={86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0; Mscomct2.ocx
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; Mscomctl.ocx
IconForm="frmServer"
Startup="Sub Main"
HelpFile=""
Title="vb_SimpleServer"
Command32=""
Name="vbSimpleServer"
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

402
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleVoice/frmApp.frm Normal file
View File

@@ -0,0 +1,402 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmApp
BorderStyle = 3 'Fixed Dialog
Caption = "Simple Voice"
ClientHeight = 3465
ClientLeft = 45
ClientTop = 330
ClientWidth = 4755
Icon = "frmApp.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3465
ScaleWidth = 4755
StartUpPosition = 3 'Windows Default
Begin MSComctlLib.ListView lvMembers
Height = 3075
Left = 120
TabIndex = 0
Top = 300
Width = 4575
_ExtentX = 8070
_ExtentY = 5424
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 2
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "Name"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "Status"
Object.Width = 2469
EndProperty
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "Members of this conversation:"
Height = 255
Left = 180
TabIndex = 1
Top = 60
Width = 3855
End
End
Attribute VB_Name = "frmApp"
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: frmApp.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Implements DirectPlayVoiceEvent8
Private Sub Form_Load()
'Init our vars
InitDPlay
'Now we can create a new Connection Form (which will also be our message pump)
Set DPlayEventsForm = New DPlayConnect
'First lets get the dplay connection started
If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 10, Me) Then
Unload Me
End If
'Am I the host?
fAmHost = DPlayEventsForm.IsHost
'First let's set up the DirectPlayVoice stuff since that's the point of this demo
If fAmHost Then
'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
Dim oSound As DVSOUNDDEVICECONFIG
Dim oClient As DVCLIENTCONFIG
'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.StartClientNotification Me
dvClient.Initialize dpp, 0
'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 = Me.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, Me.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 must exit.", vbOKOnly Or vbInformation, "No Voice"
Cleanup
Unload Me
End
End If
If Err.Number = DVERR_USERCANCEL Then
MsgBox "Could not start DirectPlayVoice. The Voice Networking wizard has been cancelled. This sample must exit.", vbOKOnly Or vbInformation, "No Voice"
Cleanup
Unload Me
End
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 must exit." & vbCrLf & "Error:" & CStr(Err.Number), vbOKOnly Or vbCritical, "Exiting"
Cleanup
Unload Me
End
End If
End If
End Sub
Private Sub UpdateList(ByVal lPlayerID As Long, fTalking As Boolean)
Dim lCount As Long
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
'Change this guys status
If fTalking Then
lvMembers.ListItems.Item(lCount).SubItems(1) = "Talking"
Else
lvMembers.ListItems.Item(lCount).SubItems(1) = "Silent"
End If
End If
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.Hide
DPlayEventsForm.DoSleep 50
Cleanup
End Sub
Public Sub UpdatePlayerList()
'Get everyone who is currently in the session and add them if we don't have them currently.
Dim lCount As Long
Dim Player As DPN_PLAYER_INFO
' Enumerate players
For lCount = 1 To dpp.GetCountPlayersAndGroups(DPNENUM_PLAYERS)
If Not (AmIInList(dpp.GetPlayerOrGroup(lCount))) Then 'Add this player
Dim lItem As ListItem, sName As String
Player = dpp.GetPeerInfo(dpp.GetPlayerOrGroup(lCount))
sName = Player.Name
If sName = vbNullString Then sName = "Unknown"
If (Player.lPlayerFlags And DPNPLAYER_LOCAL = DPNPLAYER_LOCAL) Then glMyID = dpp.GetPlayerOrGroup(lCount)
Set lItem = lvMembers.ListItems.Add(, "K" & CStr(dpp.GetPlayerOrGroup(lCount)), sName)
lItem.SubItems(1) = "Silent"
End If
Next lCount
End Sub
Private Function AmIInList(ByVal lPlayerID As Long) As Boolean
Dim lCount As Long, fInThis As Boolean
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
fInThis = True
End If
Next
AmIInList = fInThis
End Function
Private Sub RemovePlayer(ByVal lPlayerID As Long)
Dim lCount As Long
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
lvMembers.ListItems.Remove 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)
'Now we're connected, start our voice session
Dim oSound As DVSOUNDDEVICECONFIG
Dim oClient As DVCLIENTCONFIG
If dpnotify.hResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
Else
'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.StartClientNotification Me
dvClient.Initialize dpp, 0
'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 = Me.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, Me.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 must exit.", vbOKOnly Or vbInformation, "No Voice"
DPlayEventsForm.CloseForm Me
End If
If Err.Number = DVERR_USERCANCEL Then
MsgBox "Could not start DirectPlayVoice. The Voice Networking wizard has been cancelled. This sample must exit.", vbOKOnly Or vbInformation, "No Voice"
DPlayEventsForm.CloseForm Me
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 must exit." & vbCrLf & "Error:" & CStr(Err.Number), vbOKOnly Or vbCritical, "Exiting"
DPlayEventsForm.CloseForm Me
Exit Sub
End If
End If
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)
'VB requires that we must implement *every* member of this interface
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
Private Sub DirectPlayVoiceEvent8_ConnectResult(ByVal ResultCode As Long)
Dim lTargets(0) As Long
If ResultCode = 0 Then
lTargets(0) = DVID_ALLPLAYERS
dvClient.SetTransmitTargets lTargets, 0
'Update the list
UpdatePlayerList
Else
MsgBox "Could not start DirectPlayVoice. This sample must exit." & vbCrLf & "Error:" & CStr(Err.Number), vbOKOnly Or vbCritical, "Exiting"
DPlayEventsForm.CloseForm Me
End If
End Sub
Private Sub DirectPlayVoiceEvent8_CreateVoicePlayer(ByVal playerID As Long, ByVal flags As Long)
'Someone joined, update the player list
UpdatePlayerList
End Sub
Private Sub DirectPlayVoiceEvent8_DeleteVoicePlayer(ByVal playerID As Long)
'Someone quit, remove them from the session
RemovePlayer playerID
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 playerID As Long, ByVal PeakLevel As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_PlayerVoiceStart(ByVal playerID As Long)
'Someone is talking, update the list
UpdateList playerID, True
End Sub
Private Sub DirectPlayVoiceEvent8_PlayerVoiceStop(ByVal playerID As Long)
'Someone stopped talking, update the list
UpdateList playerID, False
End Sub
Private Sub DirectPlayVoiceEvent8_RecordStart(ByVal PeakVolume As Long)
'I am talking, update the list
UpdateList glMyID, True
End Sub
Private Sub DirectPlayVoiceEvent8_RecordStop(ByVal PeakVolume As Long)
'I have quit talking, update the list
UpdateList glMyID, False
End Sub
Private Sub DirectPlayVoiceEvent8_SessionLost(ByVal ResultCode As Long)
'The voice session has exited, let's quit
MsgBox "The DirectPlayVoice session was lost. This sample is exiting.", vbOKOnly Or vbInformation, "Session lost."
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleVoice/frmApp.frx Normal file
View File

Binary file not shown.

56
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleVoice/modDplay.bas Normal file
View File

@@ -0,0 +1,56 @@
Attribute VB_Name = "modDplay"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Constants
Public Const AppGuid = "{F5230441-9B71-88DA-998C-00207547A14C}"
'Types
Public Type PlayerInfo
lPlayerID As Long
fSilent As Boolean
End Type
'DirectX Variables
Public dvServer As DirectPlayVoiceServer8
Public dvClient As DirectPlayVoiceClient8
Public dx As DirectX8
Public dpp As DirectPlay8Peer
Public glMyID As Long
'Our connection form and message pump
Public DPlayEventsForm As DPlayConnect
'Misc Vars
Public fAmHost As Boolean
' Get the DirectPlay objects
Public Sub InitDPlay()
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
End Sub
' Shut down the DPlay objects
Public Sub Cleanup()
On Error Resume Next
'Turn off our error handling
If Not (dpp Is Nothing) Then dpp.UnRegisterMessageHandler
If Not (dvClient Is Nothing) Then dvClient.UnRegisterMessageHandler
If Not (dvServer Is Nothing) Then dvServer.UnRegisterMessageHandler
dvClient.Disconnect DVFLAGS_SYNC
If fAmHost Then dvServer.StopSession 0
'Destroy the objects
Set dvClient = Nothing
Set dvServer = Nothing
If Not dpp Is Nothing Then dpp.Close
DPlayEventsForm.GoUnload
'Destroy the objects
Set dpp = Nothing
Set dx = Nothing
End Sub

29
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleVoice/readme.txt Normal file
View File

@@ -0,0 +1,29 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Simple Voice Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
Simple Voice is similar in form to SimplePeer. Once a player hosts or connects
to a session, the players can chat with either other.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\SimpleVoice
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Refer to User's Guide section of the SimplePeer sample.
Programming Notes
=================
The SimpleVoice differs by letting clients send audio data to all players
connected to the session.

33
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/SimpleVoice/vb_SimpleVoice.vbp Normal file
View File

@@ -0,0 +1,33 @@
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=frmApp.frm
Form=..\..\common\DplayCon.frm
Module=modDplay; modDplay.bas
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; Mscomctl.ocx
Startup="frmApp"
ExeName32="vb_SimpleVoice.exe"
Command32=""
Name="vbSimpleVoice"
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
ThreadPerObject=0
MaxNumberOfThreads=1

192
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/StagedPeer/frmApp.frm Normal file
View File

@@ -0,0 +1,192 @@
VERSION 5.00
Begin VB.Form frmApp
BorderStyle = 3 'Fixed Dialog
Caption = "Make a face..."
ClientHeight = 3135
ClientLeft = 45
ClientTop = 330
ClientWidth = 4530
Icon = "frmApp.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3135
ScaleWidth = 4530
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtFaces
BackColor = &H8000000F&
Height = 1815
Left = 60
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 4
Top = 840
Width = 4395
End
Begin VB.Frame Frame1
Caption = "Session Status"
Height = 735
Left = 60
TabIndex = 1
Top = 60
Width = 4395
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Current number of players:"
Height = 195
Left = 120
TabIndex = 3
Top = 300
Width = 1935
End
Begin VB.Label lblPlayer
BorderStyle = 1 'Fixed Single
Height = 315
Left = 3780
TabIndex = 2
Top = 240
Width = 495
End
End
Begin VB.CommandButton cmdMakeFace
Caption = "Make Face"
Height = 315
Left = 3420
TabIndex = 0
Top = 2760
Width = 1035
End
End
Attribute VB_Name = "frmApp"
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: frmApp.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private mlNumPlayers As Long
Public Sub LoadGame(ByVal lNumPlayers As Long)
mlNumPlayers = lNumPlayers
lblPlayer.Caption = CStr(lNumPlayers)
DPlayEventsForm.RegisterCallback Me
Me.Show vbModeless
End Sub
Private Sub cmdMakeFace_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'It's time to start the game
lMsg = MsgMakeFace
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send this message to everyone
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
End Sub
Private Sub Form_Load()
If DPlayEventsForm.IsHost Then Me.Caption = Me.Caption & " (HOST)"
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.Hide
DPlayEventsForm.DoSleep 50
Cleanup
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)
'No one can join, but people can leave
mlNumPlayers = mlNumPlayers - 1
lblPlayer.Caption = CStr(mlNumPlayers)
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)
'No one can connect now, we've already started.
fRejectMsg = True
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)
'There is only one msg that can be sent in this demo
Dim sPeer As String
Dim lMsg As Long, lOffset As Long
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case MsgMakeFace
sPeer = dpp.GetPeerInfo(dpnotify.idSender).Name
UpdateChat sPeer & " is making funny faces at you.", txtFaces
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)
If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
MsgBox "The host has terminated this session. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
Else
MsgBox "This session has been lost. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
End If
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/StagedPeer/frmApp.frx Normal file
View File

Binary file not shown.

849
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/StagedPeer/frmStagePeer.frm Normal file
View File

@@ -0,0 +1,849 @@
VERSION 5.00
Begin VB.Form frmStagePeer
BorderStyle = 3 'Fixed Dialog
Caption = "Staging Area"
ClientHeight = 4545
ClientLeft = 465
ClientTop = 435
ClientWidth = 8850
Icon = "frmStagePeer.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4545
ScaleWidth = 8850
StartUpPosition = 3 'Windows Default
Begin VB.Timer tmrUpdate
Interval = 50
Left = 90
Top = 4125
End
Begin VB.CommandButton cmdCancel
Caption = "Cancel"
Height = 315
Left = 7560
TabIndex = 26
Top = 4140
Width = 1215
End
Begin VB.CommandButton cmdStartGame
Caption = "Start Game"
Enabled = 0 'False
Height = 315
Left = 6240
TabIndex = 25
Top = 4140
Width = 1275
End
Begin VB.Frame Frame1
Caption = "Chat"
Height = 3975
Left = 2520
TabIndex = 22
Top = 120
Width = 6255
Begin VB.TextBox txtSend
Height = 315
Left = 60
TabIndex = 0
Top = 3420
Width = 6135
End
Begin VB.TextBox txtChat
Height = 3135
Left = 60
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 23
TabStop = 0 'False
Top = 240
Width = 6075
End
End
Begin VB.Frame fra
Caption = "Players"
Height = 3975
Left = 60
TabIndex = 1
Top = 120
Width = 2415
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 9
Left = 2040
TabIndex = 21
Top = 3540
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 8
Left = 2040
TabIndex = 20
Top = 3180
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 7
Left = 2040
TabIndex = 19
Top = 2820
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 6
Left = 2040
TabIndex = 18
Top = 2460
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 5
Left = 2040
TabIndex = 17
Top = 2100
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 4
Left = 2040
TabIndex = 16
Top = 1740
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 3
Left = 2040
TabIndex = 15
Top = 1380
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 2
Left = 2040
TabIndex = 14
Top = 1020
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 1
Left = 2040
TabIndex = 13
Top = 660
Visible = 0 'False
Width = 255
End
Begin VB.CheckBox chkReady
Enabled = 0 'False
Height = 255
Index = 0
Left = 2040
TabIndex = 12
Top = 300
Visible = 0 'False
Width = 255
End
Begin VB.ComboBox cboUser
Height = 315
Index = 0
Left = 120
Style = 2 'Dropdown List
TabIndex = 11
Top = 300
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 9
Left = 120
Style = 2 'Dropdown List
TabIndex = 10
Top = 3540
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 8
Left = 120
Style = 2 'Dropdown List
TabIndex = 9
Top = 3180
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 7
Left = 120
Style = 2 'Dropdown List
TabIndex = 8
Top = 2820
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 6
Left = 120
Style = 2 'Dropdown List
TabIndex = 7
Top = 2460
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 5
Left = 120
Style = 2 'Dropdown List
TabIndex = 6
Top = 2100
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 4
Left = 120
Style = 2 'Dropdown List
TabIndex = 5
Top = 1740
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 3
Left = 120
Style = 2 'Dropdown List
TabIndex = 4
Top = 1380
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 2
Left = 120
Style = 2 'Dropdown List
TabIndex = 3
Top = 1020
Visible = 0 'False
Width = 1815
End
Begin VB.ComboBox cboUser
Height = 315
Index = 1
Left = 120
Style = 2 'Dropdown List
TabIndex = 2
Top = 660
Visible = 0 'False
Width = 1815
End
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "Click the check box when you're ready"
Height = 435
Left = 2580
TabIndex = 24
Top = 4140
Width = 3075
End
End
Attribute VB_Name = "frmStagePeer"
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: frmStagePeer.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Type userJoinPart
fJoin As Boolean
lDplayID As Long
fIsHost As Boolean
sUserName As String
lSlotID As Long
End Type
Implements DirectPlay8Event
Private mlNumUserEvents As Long
Private moUsers() As userJoinPart
Dim fLoadingGame As Boolean
Private Sub cboUser_Click(Index As Integer)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'First check to see if this is my combo box.. If it is, then enable my check box
If cboUser(Index).ItemData(0) = glMyPlayerID And (glMyPlayerID > 0) Then
chkReady(Index).Enabled = True
End If
If DPlayEventsForm.IsHost Then
If cboUser(Index).ListIndex = cboUser(Index).ListCount - 1 Then 'This slot is now closed
'If we're the host kick the user in this slot out
If cboUser(Index).ItemData(0) <> 0 And cboUser(Index).ItemData(0) <> -1 Then 'There is already a user in this slot, kick them out
dpp.DestroyPeer cboUser(Index).ItemData(0), 0, ByVal 0&, 0
End If
'Notify everyone that we switched this one to closed
lMsg = MsgCloseSlot
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send the SlotID of this slot
AddDataToBuffer oBuf, CLng(Index), SIZE_LONG, lOffset
'Send this message to the joining player
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
'Set the item data to -1 to signify this slot is closed
cboUser(Index).ItemData(0) = -1
ElseIf cboUser(Index).ListIndex = cboUser(Index).ListCount - 2 Then 'This slot is now open
If cboUser(Index).ListCount > 2 Then 'There is already someone in this slot
cboUser(Index).ListIndex = 0
Exit Sub
End If
cboUser(Index).ItemData(0) = 0
lMsg = MsgOpenSlot
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send the SlotID of this slot
AddDataToBuffer oBuf, CLng(Index), SIZE_LONG, lOffset
'Send this message to the joining player
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
End If
End If
'Lets see if we can start now
UpdateStartButton
End Sub
Private Sub chkReady_Click(Index As Integer)
'We can only click our own check box, so if we do, notify everyone else
Dim lOffset As Long
Dim lMsg As Long
Dim oBuf() As Byte
On Error Resume Next
lOffset = NewBuffer(oBuf)
lMsg = MsgClickReady
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send the index
AddDataToBuffer oBuf, Index, LenB(Index), lOffset
'Send the value
AddDataToBuffer oBuf, CLng(chkReady(Index).Value), SIZE_LONG, lOffset
'Send the buffer
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
'Lets see if we can start now
UpdateStartButton
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdStartGame_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'It's time to start the game
lMsg = MsgStartGame
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send this message to everyone
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
'Now load the actual game form
fLoadingGame = True
frmApp.LoadGame GetNumPlayers
Unload Me
End Sub
Private Sub Form_Load()
Dim lCount As Long
'Add a 'Open' and 'Closed' item to each box
'Then make sure the box is visible along with the 'ready' check box
For lCount = 0 To 9
cboUser(lCount).AddItem "Open"
cboUser(lCount).AddItem "Closed"
Next
'Oh good, we want to play a multiplayer game.
'First lets get the dplay connection started
'Here we will init our DPlay objects
InitDPlay
'Now we can create a new Connection Form (which will also be our message pump)
Set DPlayEventsForm = New DPlayConnect
'Start the connection form (it will either create or join a session)
If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 10, Me, False) Then
Cleanup
End
Else 'We did choose to play a game
gsUserName = DPlayEventsForm.UserName
'Add a 'Open' and 'Closed' item to each box
'Then make sure the box is visible along with the 'ready' check box
For lCount = 0 To 9
If DPlayEventsForm.NumPlayers > lCount Then
If Not DPlayEventsForm.IsHost Then
cboUser(lCount).Enabled = False
End If
cboUser(lCount).ListIndex = 0
cboUser(lCount).Visible = True
chkReady(lCount).Visible = True
End If
Next
If DPlayEventsForm.IsHost Then Me.Caption = Me.Caption & " (HOST)"
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
DPlayEventsForm.DoSleep 50
If Not fLoadingGame Then
Me.Hide
Cleanup
End If
End Sub
Private Function GetName(ByVal lID As Long) As String
Dim lCount As Long
'Rather than call GetPeerInfo everytime, we will just use our text in
'our combo box.
GetName = vbNullString
For lCount = 0 To 9
If cboUser(lCount).ItemData(0) = lID Then 'This is the player
GetName = cboUser(lCount).Text
Exit For
End If
Next
End Function
Private Sub tmrUpdate_Timer()
Dim lCount As Long
Dim lMsg As Long, oBuf() As Byte
Dim lOffset As Long
If mlNumUserEvents = 0 Then Exit Sub
Dim oTemp As userJoinPart
'Get a copy of the event
oTemp = moUsers(mlNumUserEvents)
'Decrement the count
mlNumUserEvents = mlNumUserEvents - 1
'Get rid of our array if it's no longer necessary
If mlNumUserEvents = 0 Then Erase moUsers
With oTemp
Debug.Print "Got here.. Info:"; .fIsHost; .fJoin; .lDplayID; .lSlotID; .sUserName
If .fJoin Then
If DPlayEventsForm.IsHost Then 'If we are the host
If Not .fIsHost Then 'Don't notify ourselves
'We are the host, let this person join, and then tell everyone which slot to put them in
'Find the first open slot
'We ignore Slot 0 since that's the host's slot
For lCount = 1 To 9
If cboUser(lCount).ItemData(0) = 0 Then
Exit For
End If
Next
'Add this user to our list
cboUser(lCount).AddItem .sUserName, 0
cboUser(lCount).ItemData(0) = .lDplayID
cboUser(lCount).ListIndex = 0
'Ok, lCount now holds the first open slot
lMsg = MsgPutPlayerInSlot
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Now add the slot number this player is in
AddDataToBuffer oBuf, lCount, LenB(lCount), lOffset
'Now add the player id
AddDataToBuffer oBuf, .lDplayID, LenB(.lDplayID), lOffset
'Send this message to everyone
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
'Now that everyone knows what slot to put them in, we need to tell this person
'that just joined where everyone else already is.
For lCount = 0 To 9
If (cboUser(lCount).ItemData(0) <> 0) And (cboUser(lCount).ItemData(0) <> -1) Then
If cboUser(lCount).ItemData(0) <> .lDplayID Then 'No need to pass this person twice
lMsg = MsgPutPlayerInSlot
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Now add the slot number this player is in
AddDataToBuffer oBuf, lCount, LenB(lCount), lOffset
'Now add the player id
AddDataToBuffer oBuf, cboUser(lCount).ItemData(0), SIZE_LONG, lOffset
'Send this message to the joining player
dpp.SendTo .lDplayID, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
'Send the state of the Ready checkbox
lOffset = NewBuffer(oBuf)
lMsg = MsgClickReady
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send the index
AddDataToBuffer oBuf, CInt(lCount), SIZE_INTEGER, lOffset
'Send the value
AddDataToBuffer oBuf, CLng(chkReady(lCount).Value), SIZE_LONG, lOffset
'Send the buffer
dpp.SendTo .lDplayID, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
End If
ElseIf cboUser(lCount).ItemData(0) = 0 Then
'Open this slot on the client machine
lMsg = MsgOpenSlot
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send the SlotID of this slot
AddDataToBuffer oBuf, lCount, LenB(lCount), lOffset
'Send this message to the joining player
dpp.SendTo .lDplayID, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
ElseIf cboUser(lCount).ItemData(0) = -1 Then
'Close this slot on the client machine
lMsg = MsgCloseSlot
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
'Send the SlotID of this slot
AddDataToBuffer oBuf, lCount, LenB(lCount), lOffset
'Send this message to the joining player
dpp.SendTo .lDplayID, oBuf, 0, DPNSEND_NOLOOPBACK Or DPNSEND_GUARANTEED
End If
Next
Else
'Add ourselves to our list
cboUser(0).AddItem .sUserName, 0
cboUser(0).ItemData(0) = .lDplayID
'Lock our box so we don't change anything
cboUser(0).Locked = True
chkReady(0).Enabled = True
End If
Else
'add this user to our list
cboUser(.lSlotID).AddItem .sUserName, 0
cboUser(.lSlotID).ItemData(0) = .lDplayID
cboUser(.lSlotID).ListIndex = 0
If (.lDplayID = glMyPlayerID) Then chkReady(.lSlotID).Enabled = True
End If
Else 'This is a disconnect
For lCount = 0 To 9
'Basically here we will scroll through each of the combo boxes.
'For each box that we find that has a user in it, see if that user
'is the one who just left
If cboUser(lCount).ItemData(0) = .lDplayID Then
'Remove this person
cboUser(lCount).RemoveItem 0
cboUser(lCount).ItemData(0) = 0
cboUser(lCount).ListIndex = 0
chkReady(lCount).Value = vbUnchecked
Exit For
End If
Next
End If
End With
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
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
KeyAscii = 0
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
UpdateChat "<" & gsUserName & ">" & sChatMsg, txtChat
End If
End Sub
Private Sub UpdateStartButton()
Dim lCount As Long
Dim fReady As Boolean
Dim lNumPlayers As Long
'Here we will update the start button and any text to let the user know
'what is going on
lNumPlayers = 0
If DPlayEventsForm.IsHost Then
'The host can enable the start button when everyone is ready.
'Assume we're ready
fReady = True
For lCount = 0 To 9
'Basically here we will scroll through each of the combo boxes.
'For each box that we find that has a user in it, see if that user
'has clicked the Ready box.
If (cboUser(lCount).ItemData(0) <> 0) And (cboUser(lCount).ItemData(0) <> -1) Then
If chkReady(lCount).Value <> vbChecked Then
'We are not ready
fReady = False
End If
'Increment the number of players
lNumPlayers = lNumPlayers + 1
End If
Next
'Are we ready?
If lNumPlayers < 2 Then
lblInfo.Caption = "Waiting for more players to join..."
Else
cmdStartGame.Enabled = fReady
If fReady Then
lblInfo.Caption = "You can start the session anytime..."
Else
lblInfo.Caption = "Waiting for everyone to click ready..."
End If
End If
Else
'The only thing we can do is update the text here. It is not possible
'for someone who is not the host to start the session.
'Assume we're ready
fReady = True
For lCount = 0 To 9
'Basically here we will scroll through each of the combo boxes.
'For each box that we find that has a user in it, see if that user
'has clicked the Ready box.
If (cboUser(lCount).ItemData(0) <> 0) And (cboUser(lCount).ItemData(0) <> -1) Then
If chkReady(lCount).Value <> vbChecked Then
'We are not ready
fReady = False
Exit For
End If
End If
Next
'Are we ready?
If fReady Then
lblInfo.Caption = "Waiting for the host to start the session..."
Else
lblInfo.Caption = "Waiting for everyone to click ready..."
End If
End If
End Sub
Private Function GetNumPlayers() As Long
Dim lCount As Long
For lCount = 0 To 9
'Basically here we will scroll through each of the combo boxes.
If (cboUser(lCount).ItemData(0) <> 0) And (cboUser(lCount).ItemData(0) <> -1) Then
'Increment the number of players
GetNumPlayers = GetNumPlayers + 1
End If
Next
End Function
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)
If dpnotify.hResultCode = DPNERR_HOSTREJECTEDCONNECTION Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "All available slots in this session were closed by the host.", vbOKOnly Or vbInformation, "No open slot"
DPlayEventsForm.CloseForm Me
ElseIf dpnotify.hResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
End If
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)
Dim dpPeer As DPN_PLAYER_INFO
'Get the peer info for this player and see if it's us..
dpPeer = dpp.GetPeerInfo(lPlayerID)
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then
glMyPlayerID = lPlayerID
End If
If (DPlayEventsForm.IsHost) Then
Dim lTemp As Long
lTemp = mlNumUserEvents + 1
ReDim Preserve moUsers(lTemp)
With moUsers(lTemp)
.fJoin = True
.lDplayID = lPlayerID
.sUserName = dpPeer.Name
.fIsHost = (dpPeer.lPlayerFlags And DPNPLAYER_HOST) = DPNPLAYER_HOST
End With
mlNumUserEvents = lTemp
End If
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)
'Someone just left, remove there slot and make it open again
Dim lTemp As Long
lTemp = mlNumUserEvents + 1
ReDim Preserve moUsers(lTemp)
With moUsers(lTemp)
.fJoin = False
.lDplayID = lPlayerID
End With
mlNumUserEvents = lTemp
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)
'Here we will check to see if there are any open slots for the user to join
Dim lCount As Long
Dim fFoundOpenSlot As Boolean
fFoundOpenSlot = False
For lCount = 0 To 9
If CLng(cboUser(lCount).ItemData(0)) = 0 Then
fFoundOpenSlot = True
Exit For
End If
Next
If Not fFoundOpenSlot Then 'There are no open slots
fRejectMsg = True 'Reject the message and do not let them join.
End If
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)
Dim lMsg As Long, lOffset As Long
Dim dpPeer As DPN_PLAYER_INFO, sName As String
Dim sChat As String
Dim lPlayerID As Long, lSlotID As Long
Dim iIndex As Integer, lValue As Long
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case MsgPutPlayerInSlot
GetDataFromBuffer .ReceivedData, lSlotID, LenB(lSlotID), lOffset
GetDataFromBuffer .ReceivedData, lPlayerID, LenB(lPlayerID), lOffset
dpPeer = dpp.GetPeerInfo(lPlayerID)
Dim lTemp As Long
lTemp = mlNumUserEvents + 1
ReDim Preserve moUsers(lTemp)
With moUsers(lTemp)
.fJoin = True
.lDplayID = lPlayerID
.sUserName = dpPeer.Name
.fIsHost = False
.lSlotID = lSlotID
End With
mlNumUserEvents = lTemp
Case MsgOpenSlot 'Open this slot
GetDataFromBuffer .ReceivedData, lSlotID, LenB(lSlotID), lOffset
cboUser(lSlotID).ListIndex = cboUser(lSlotID).ListCount - 2
Case MsgCloseSlot 'Close this slot
GetDataFromBuffer .ReceivedData, lSlotID, LenB(lSlotID), lOffset
If cboUser(lSlotID).ListCount > 2 Then 'There is someone in this slot that just got kicked
cboUser(lSlotID).RemoveItem 0
End If
chkReady(lSlotID).Value = vbUnchecked
cboUser(lSlotID).ListIndex = cboUser(lSlotID).ListCount - 1
Case MsgChat
sName = GetName(.idSender)
sChat = GetStringFromBuffer(.ReceivedData, lOffset)
UpdateChat "<" & sName & "> " & sChat, txtChat
Case MsgClickReady
GetDataFromBuffer .ReceivedData, iIndex, LenB(iIndex), lOffset
GetDataFromBuffer .ReceivedData, lValue, LenB(lValue), lOffset
chkReady(iIndex).Value = lValue
Case MsgStartGame
fLoadingGame = True
frmApp.LoadGame GetNumPlayers
Unload Me
Exit Sub
End Select
End With
'Lets see if we can start now
UpdateStartButton
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)
'The session just ended for some reason. We may have been kicked out.
If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
MsgBox "The host has closed the slot you were in. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
Else
MsgBox "This session has been lost. This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
End If
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/StagedPeer/frmStagePeer.frx Normal file
View File

Binary file not shown.

64
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/StagedPeer/modDplay.bas Normal file
View File

@@ -0,0 +1,64 @@
Attribute VB_Name = "modDplay"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Enum vbDPlayStagerMsgType
MsgChat
MsgClickReady
MsgOpenSlot
MsgCloseSlot
MsgKickUser
MsgStartGame
MsgPutPlayerInSlot
MsgMakeFace
End Enum
'Constants
Public Const AppGuid = "{D66EC208-1BF0-48cb-AB20-18C321F31E1E}"
Public dx As DirectX8
Public dpp As DirectPlay8Peer
'App specific variables
Public gsUserName As String
Public glMyPlayerID As Long
'Our connection form and message pump
Public DPlayEventsForm As DPlayConnect
Public Sub InitDPlay()
'Create our DX/DirectPlay objects
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
End Sub
Public Sub Cleanup()
If Not (DPlayEventsForm Is Nothing) Then
dpp.UnRegisterMessageHandler
'Close down our session
If Not (dpp Is Nothing) Then dpp.Close
'Lose references to peer and dx objects
DPlayEventsForm.DoSleep 50
Set dpp = Nothing
Set dx = Nothing
'Get rid of our message pump
DPlayEventsForm.GoUnload
End If
End Sub
Public Sub UpdateChat(ByVal sString As String, oText As TextBox)
'Update the window first
oText.Text = oText.Text & sString & vbCrLf
'Now limit the text in the window to be 16k
If Len(oText.Text) > 16384 Then
oText.Text = Right$(oText.Text, 16384)
End If
'Autoscroll the text
oText.SelStart = Len(oText.Text)
End Sub

27
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/StagedPeer/readme.txt Normal file
View File

@@ -0,0 +1,27 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Staged Peer Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
[To be added.]
Path
====
Source: DXSDK\Samples\Multimedia\DirectPlay\StagedPeer
Executable: DXSDK\Samples\Multimedia\DirectPlay\Bin
User's Guide
============
[To be added.]
Programming Notes
=================
[To be added.]

34
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/StagedPeer/vb_StagedPeer.vbp Normal file
View File

@@ -0,0 +1,34 @@
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=frmStagePeer.frm
Module=modDplay; modDplay.bas
Form=..\..\common\DplayCon.frm
Form=frmApp.frm
Startup="frmStagePeer"
ExeName32="vb_StagedPeer.exe"
Command32=""
Name="vbStagedPeer"
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

96
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/VoiceGroup/Dplay.bas Normal file
View File

@@ -0,0 +1,96 @@
Attribute VB_Name = "DplayModule"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: dplay.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Enum DPLAY_MSGS
MSG_CHANGEGROUP
MSG_CHANGETALK
MSG_SERVERCHANGEGROUP
End Enum
'Constants
Public Const AppGuid = "{F5230441-9B71-88DA-998C-00207547A14D}"
'DirectX Variables
Public dvServer As DirectPlayVoiceServer8
Public dvClient As DirectPlayVoiceClient8
Public dx As DirectX8
Public dpp As DirectPlay8Peer
Public oSession As DVSESSIONDESC
Public oSound As DVSOUNDDEVICECONFIG
Public oClient As DVCLIENTCONFIG
Public glGroupID(1 To 5) As Long
'Misc Vars
Public glMyPlayerID As Long
Public fGotSettings As Boolean
Public DPlayEventsForm As DPlayConnect
Public Sub InitDPlay()
Set dx = New DirectX8
Set dpp = dx.DirectPlayPeerCreate
Set dvServer = dx.DirectPlayVoiceServerCreate
Set dvClient = dx.DirectPlayVoiceClientCreate
End Sub
Public Sub Cleanup()
On Error Resume Next
'Turn off our error handling
If Not (DPlayEventsForm Is Nothing) Then
If Not (dpp Is Nothing) Then dpp.UnRegisterMessageHandler
If Not (dvClient Is Nothing) Then dvClient.UnRegisterMessageHandler
If Not (dvServer Is Nothing) Then dvServer.UnRegisterMessageHandler
dvClient.Disconnect 0
DPlayEventsForm.DoSleep 50
If DPlayEventsForm.IsHost Then dvServer.StopSession 0
If Not dpp Is Nothing Then dpp.Close
DPlayEventsForm.GoUnload
'Destroy the objects
Set dvClient = Nothing
Set dvServer = Nothing
Set dpp = Nothing
Set dx = Nothing
End If
End Sub
Private Sub Main()
'Here is where we will start
InitDPlay
Set DPlayEventsForm = New DPlayConnect
If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 20) Then
Cleanup
Else 'We did choose to play a game
If Not (DPlayEventsForm.IsHost) Then frmVoiceSettings.ClientOnly
frmVoiceSettings.Show vbModal
If Not fGotSettings Then 'We quit for some unknown reason.
Cleanup
Exit Sub
End If
frmVoice.Show vbModeless
If DPlayEventsForm.IsHost Then frmVoice.Caption = frmVoice.Caption & " (HOST)"
End If
End Sub
Public Sub RemovePlayerFromAllGroups(lPlayerID As Long)
On Error Resume Next 'We don't care about any errors..
Dim lCount As Long
For lCount = 1 To 5
dpp.RemovePlayerFromGroup glGroupID(lCount), lPlayerID, 0
Next
Err.Clear
'Ignore the errors about Player not in group
End Sub

561
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/VoiceGroup/frmVoice.frm Normal file
View File

@@ -0,0 +1,561 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmVoice
BorderStyle = 3 'Fixed Dialog
Caption = "DirectPlay Voice Sample"
ClientHeight = 3285
ClientLeft = 45
ClientTop = 330
ClientWidth = 5985
Icon = "frmVoice.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3285
ScaleWidth = 5985
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdClient
Caption = "Settings"
Default = -1 'True
Height = 375
Left = 4680
TabIndex = 7
Top = 300
Width = 1215
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Exit"
Height = 375
Left = 4680
TabIndex = 6
Top = 780
Width = 1215
End
Begin VB.ComboBox cboTalkingGroup
Height = 315
ItemData = "frmVoice.frx":0442
Left = 1980
List = "frmVoice.frx":0458
Style = 2 'Dropdown List
TabIndex = 5
Top = 2880
Width = 2595
End
Begin VB.ComboBox cboMyGroup
Height = 315
ItemData = "frmVoice.frx":0498
Left = 1980
List = "frmVoice.frx":04AE
Style = 2 'Dropdown List
TabIndex = 3
Top = 2520
Width = 2595
End
Begin MSComctlLib.ListView lvMembers
Height = 2175
Left = 60
TabIndex = 1
Top = 300
Width = 4515
_ExtentX = 7964
_ExtentY = 3836
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 4
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "Name"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "Status"
Object.Width = 1235
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "Group"
Object.Width = 2117
EndProperty
BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 3
Text = "Target"
Object.Width = 1764
EndProperty
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "I'm talking to this group:"
Height = 255
Index = 2
Left = 60
TabIndex = 4
Top = 2940
Width = 1815
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "I'm currently in the group:"
Height = 255
Index = 1
Left = 60
TabIndex = 2
Top = 2580
Width = 1815
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "Members of this conversation:"
Height = 255
Index = 0
Left = 120
TabIndex = 0
Top = 60
Width = 3855
End
End
Attribute VB_Name = "frmVoice"
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: frmVoice.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlayVoiceEvent8
Implements DirectPlay8Event
Private Sub UpdateList(ByVal lPlayerID As Long, fTalking As Boolean)
Dim lCount As Long
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
'Change this guys status
If fTalking Then
lvMembers.ListItems.Item(lCount).SubItems(1) = "Talking"
Else
lvMembers.ListItems.Item(lCount).SubItems(1) = "Silent"
End If
End If
Next
End Sub
Private Sub cboMyGroup_Click()
On Error Resume Next
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Ok, I don't want to be in this group anymore.. let's change..
UpdateGroup glMyPlayerID, cboMyGroup.ListIndex
'Now send a message to everyone telling them
If DPlayEventsForm.IsHost Then
If cboMyGroup.ListIndex = 0 Then
RemovePlayerFromAllGroups glMyPlayerID
Else
RemovePlayerFromAllGroups glMyPlayerID
'Add myself to the new group
dpp.AddPlayerToGroup glGroupID(cboMyGroup.ListIndex), glMyPlayerID, 0
End If
Else
lMsg = MSG_SERVERCHANGEGROUP
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, CLng(cboMyGroup.ListIndex), SIZE_LONG, lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_GUARANTEED Or DPNSEND_NOLOOPBACK
End If
lMsg = MSG_CHANGEGROUP
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, CLng(cboMyGroup.ListIndex), SIZE_LONG, lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_GUARANTEED Or DPNSEND_NOLOOPBACK
End Sub
Private Sub cboTalkingGroup_Click()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
Dim lTargets(0) As Long
'Who do I want to talk to?
If cboTalkingGroup.ListIndex = 0 Then 'Talk to everyone
lTargets(0) = DVID_ALLPLAYERS
dvClient.SetTransmitTargets lTargets, 0
Else
If DPlayEventsForm.IsHost Then
lTargets(0) = glGroupID(cboTalkingGroup.ListIndex)
Else
lTargets(0) = GetGroupID(cboTalkingGroup.ListIndex)
End If
dvClient.SetTransmitTargets lTargets, 0
End If
UpdateTarget glMyPlayerID, cboTalkingGroup.ListIndex
'Now send a message to everyone telling them
lMsg = MSG_CHANGETALK
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, CLng(cboTalkingGroup.ListIndex), SIZE_LONG, lOffset
dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_GUARANTEED Or DPNSEND_NOLOOPBACK
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdClient_Click()
'Show the settings screen, and re-adjust them
frmVoiceSettings.Show vbModal
dvClient.SetClientConfig oClient
End Sub
Private Sub Form_Load()
Dim dpGroupInfo As DPN_GROUP_INFO
Dim lCount As Long
DPlayEventsForm.RegisterCallback Me
'First let's set up the DirectPlayVoice stuff since that's the point of this demo
If DPlayEventsForm.IsHost Then
'After we've created (and opened) the session and got the first player, let's start
'the DplayVoice server
If (dvServer Is Nothing) Then Set dvServer = dx.DirectPlayVoiceServerCreate
dvServer.Initialize dpp, 0
dvServer.StartSession oSession, 0
End If
'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.StartClientNotification Me
dvClient.Initialize dpp, 0
oSound.hwndAppWindow = Me.hwnd
On Error Resume Next
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, Me.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 must exit.", vbOKOnly Or vbInformation, "No Voice"
Cleanup
Unload Me
End
End If
If Err.Number = DVERR_USERCANCEL Then
MsgBox "Could not start DirectPlayVoice. The Voice Networking wizard has been cancelled. This sample must exit.", vbOKOnly Or vbInformation, "No Voice"
Cleanup
Unload Me
End
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 must exit." & vbCrLf & "Error:" & CStr(Err.Number), vbOKOnly Or vbCritical, "Exiting"
Cleanup
Unload Me
End
End If
'We need to create our 5 groups
For lCount = 1 To 5
With dpGroupInfo
.lInfoFlags = DPNINFO_NAME
.Name = "Group" & CStr(lCount)
End With
dpp.CreateGroup dpGroupInfo, 0
Next
cboMyGroup.ListIndex = 0
cboTalkingGroup.ListIndex = 0
UpdatePlayerList
End Sub
Public Sub AddPlayer(ByVal lPlayerID As Long, ByVal sName As String)
Dim lItem As ListItem
Set lItem = lvMembers.ListItems.Add(, "K" & CStr(lPlayerID), sName)
lItem.SubItems(1) = "Silent"
lItem.SubItems(2) = cboMyGroup.List(0)
lItem.SubItems(3) = cboTalkingGroup.List(0)
End Sub
Public Sub RemovePlayer(ByVal lPlayerID As Long)
Dim lCount As Long
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
'Remove this one
lvMembers.ListItems.Remove lCount
End If
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.Hide
DPlayEventsForm.DoSleep 50
Cleanup
End Sub
Public Sub UpdateTarget(ByVal lPlayerID As Long, ByVal lIndex As Long)
Dim lCount As Long
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
'Change my group
lvMembers.ListItems.Item(lCount).SubItems(3) = cboTalkingGroup.List(lIndex)
End If
Next
End Sub
Public Sub UpdateGroup(ByVal lPlayerID As Long, ByVal lIndex As Long)
Dim lCount As Long
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
'Change my group
lvMembers.ListItems.Item(lCount).SubItems(2) = cboMyGroup.List(lIndex)
End If
Next
End Sub
Private Function AmIInList(ByVal lPlayerID As Long) As Boolean
Dim lCount As Long, fInThis As Boolean
For lCount = lvMembers.ListItems.Count To 1 Step -1
If lvMembers.ListItems.Item(lCount).Key = "K" & CStr(lPlayerID) Then
fInThis = True
End If
Next
AmIInList = fInThis
End Function
Private Sub UpdatePlayerList()
'Get everyone who is currently in the session and add them if we don't have them currently.
Dim lCount As Long
Dim Player As DPN_PLAYER_INFO
' Enumerate players
For lCount = 1 To dpp.GetCountPlayersAndGroups(DPNENUM_PLAYERS)
If Not (AmIInList(dpp.GetPlayerOrGroup(lCount))) Then 'Add this player
Dim lItem As ListItem, sName As String
Player = dpp.GetPeerInfo(dpp.GetPlayerOrGroup(lCount))
sName = Player.Name
If sName = vbNullString Then sName = "Unknown"
If (Player.lPlayerFlags And DPNPLAYER_LOCAL = DPNPLAYER_LOCAL) Then glMyPlayerID = dpp.GetPlayerOrGroup(lCount)
Set lItem = lvMembers.ListItems.Add(, "K" & CStr(dpp.GetPlayerOrGroup(lCount)), sName)
lItem.SubItems(1) = "Silent"
lItem.SubItems(2) = cboMyGroup.List(0)
lItem.SubItems(3) = cboTalkingGroup.List(0)
End If
Next lCount
End Sub
Private Function GetGroupID(ByVal lIndex As Long) As Long
Dim lCount As Long
Dim dpGroup As DPN_GROUP_INFO
For lCount = 1 To dpp.GetCountPlayersAndGroups(DPNENUM_GROUPS)
dpGroup = dpp.GetGroupInfo(dpp.GetPlayerOrGroup(lCount))
If dpGroup.Name = "Group" & CStr(lIndex) Then
GetGroupID = dpp.GetPlayerOrGroup(lCount)
End If
Next lCount
End Function
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)
If dpnotify.hResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
End If
End Sub
Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
Dim lGroupNum As Long
Dim dpGroup As DPN_GROUP_INFO
dpGroup = dpp.GetGroupInfo(lGroupID)
lGroupNum = CLng(Right$(dpGroup.Name, 1))
glGroupID(lGroupNum) = lGroupID
End Sub
Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
Dim dpPeer As DPN_PLAYER_INFO
dpPeer = dpp.GetPeerInfo(lPlayerID)
AddPlayer lPlayerID, dpPeer.Name
If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then
glMyPlayerID = lPlayerID
End If
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)
RemovePlayer lPlayerID
If lPlayerID = glMyPlayerID Then
glMyPlayerID = 0
End If
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)
If lNewHostID = glMyPlayerID Then
frmVoice.Caption = frmVoice.Caption & " (HOST)"
End If
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)
Dim lCount As Long, lOffset As Long
Dim lMsg As Long
Dim lIndex As Long
'Here we will go through the messages
'The first item in our byte array is the MSGID we passed in
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg
Case MSG_CHANGEGROUP
GetDataFromBuffer .ReceivedData, lIndex, LenB(lIndex), lOffset
frmVoice.UpdateGroup dpnotify.idSender, lIndex
Case MSG_CHANGETALK
GetDataFromBuffer .ReceivedData, lIndex, LenB(lIndex), lOffset
frmVoice.UpdateTarget dpnotify.idSender, lIndex
Case MSG_SERVERCHANGEGROUP
If DPlayEventsForm.IsHost Then
RemovePlayerFromAllGroups dpnotify.idSender
GetDataFromBuffer .ReceivedData, lIndex, LenB(lIndex), lOffset
If lIndex > 0 Then dpp.AddPlayerToGroup glGroupID(lIndex), dpnotify.idSender, 0
frmVoice.UpdateGroup dpnotify.idSender, lIndex
End If
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
Private Sub DirectPlayVoiceEvent8_ConnectResult(ByVal ResultCode As Long)
If ResultCode <> 0 Then
'For some reason we could not connect. All available slots must be closed.
MsgBox "Connect Failed. Error: 0x" & CStr(Hex$(ResultCode)) & " - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
DPlayEventsForm.CloseForm Me
End If
End Sub
Private Sub DirectPlayVoiceEvent8_CreateVoicePlayer(ByVal playerID As Long, ByVal flags As Long)
'Someone joined, update the player list
UpdatePlayerList
End Sub
Private Sub DirectPlayVoiceEvent8_DeleteVoicePlayer(ByVal playerID As Long)
'Someone quit, remove them from the session
RemovePlayer playerID
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 playerID As Long, ByVal PeakLevel As Long)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlayVoiceEvent8_PlayerVoiceStart(ByVal playerID As Long)
'Someone is talking, update the list
UpdateList playerID, True
End Sub
Private Sub DirectPlayVoiceEvent8_PlayerVoiceStop(ByVal playerID As Long)
'Someone stopped talking, update the list
UpdateList playerID, False
End Sub
Private Sub DirectPlayVoiceEvent8_RecordStart(ByVal PeakVolume As Long)
'I am talking, update the list
UpdateList glMyPlayerID, True
End Sub
Private Sub DirectPlayVoiceEvent8_RecordStop(ByVal PeakVolume As Long)
'I have quit talking, update the list
UpdateList glMyPlayerID, False
End Sub
Private Sub DirectPlayVoiceEvent8_SessionLost(ByVal ResultCode As Long)
'The voice session has exited, let's quit
MsgBox "The DirectPlayVoice session was lost. This sample is exiting.", vbOKOnly Or vbInformation, "Session lost."
DPlayEventsForm.CloseForm Me
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/VoiceGroup/frmVoice.frx Normal file
View File

Binary file not shown.

509
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/VoiceGroup/frmVoiceSettings.frm Normal file
View File

@@ -0,0 +1,509 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmVoiceSettings
BorderStyle = 3 'Fixed Dialog
Caption = "Direct Play Voice Settings"
ClientHeight = 5010
ClientLeft = 45
ClientTop = 330
ClientWidth = 5835
Icon = "frmVoiceSettings.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5010
ScaleWidth = 5835
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdOk
Caption = "OK"
Default = -1 'True
Height = 375
Left = 4545
TabIndex = 36
Top = 4545
Width = 1215
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Cancel"
Height = 375
Left = 3255
TabIndex = 35
Top = 4545
Width = 1215
End
Begin VB.Frame fraServer
Caption = "Server Options (set only when creating a new session) "
Height = 1020
Left = 60
TabIndex = 1
Top = 3420
Width = 5700
Begin VB.Frame fraCompression
Caption = " Compression Codec "
Height = 660
Left = 120
TabIndex = 33
Top = 240
Width = 5475
Begin VB.ComboBox cboCompressionTypes
Height = 315
Left = 135
Style = 2 'Dropdown List
TabIndex = 34
Top = 255
Width = 5220
End
End
End
Begin VB.Frame Frame1
Caption = "Client Options (may be adjusted at any time) "
Height = 3195
Left = 60
TabIndex = 0
Top = 60
Width = 5715
Begin VB.Frame Frame3
Caption = " Aggressiveness "
Height = 1335
Index = 4
Left = 3000
TabIndex = 27
Top = 1740
Width = 1755
Begin VB.OptionButton optAggressivenessSet
Caption = "Set"
Height = 255
Left = 1020
TabIndex = 29
Top = 300
Width = 675
End
Begin VB.OptionButton optAgressivenessDefault
Caption = "Default"
Height = 195
Left = 60
TabIndex = 28
Top = 300
Value = -1 'True
Width = 855
End
Begin MSComctlLib.Slider sldAggressiveness
Height = 195
Left = 60
TabIndex = 30
Top = 780
Width = 1635
_ExtentX = 2884
_ExtentY = 344
_Version = 393216
Min = 1
Max = 100
SelStart = 1
TickFrequency = 10
Value = 1
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Max"
Height = 195
Index = 9
Left = 1320
TabIndex = 32
Top = 1080
Width = 315
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Min"
Height = 195
Index = 8
Left = 60
TabIndex = 31
Top = 1080
Width = 315
End
End
Begin VB.Frame Frame3
Caption = " Quality "
Height = 1335
Index = 3
Left = 1020
TabIndex = 21
Top = 1740
Width = 1755
Begin VB.OptionButton optQualityDefault
Caption = "Default"
Height = 195
Left = 60
TabIndex = 24
Top = 300
Value = -1 'True
Width = 855
End
Begin VB.OptionButton OptQualitySet
Caption = "Set"
Height = 255
Left = 1020
TabIndex = 23
Top = 300
Width = 675
End
Begin MSComctlLib.Slider sldQuality
Height = 195
Left = 60
TabIndex = 22
Top = 780
Width = 1635
_ExtentX = 2884
_ExtentY = 344
_Version = 393216
Min = 1
Max = 100
SelStart = 1
TickFrequency = 10
Value = 1
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Min"
Height = 195
Index = 7
Left = 60
TabIndex = 26
Top = 1080
Width = 315
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Max"
Height = 195
Index = 6
Left = 1320
TabIndex = 25
Top = 1080
Width = 315
End
End
Begin VB.Frame Frame3
Caption = "Threshold"
Height = 1335
Index = 2
Left = 3840
TabIndex = 14
Top = 300
Width = 1755
Begin VB.OptionButton optSensitivityDefault
Caption = "Default"
Height = 255
Left = 840
TabIndex = 17
Top = 300
Width = 855
End
Begin VB.OptionButton optnSensitivityAuto
Caption = "Auto"
Height = 195
Left = 60
TabIndex = 16
Top = 300
Value = -1 'True
Width = 735
End
Begin VB.OptionButton optSensitivitySet
Caption = "Set"
Height = 255
Left = 420
TabIndex = 15
Top = 540
Width = 855
End
Begin MSComctlLib.Slider sldSensitivity
Height = 195
Left = 60
TabIndex = 18
Top = 780
Width = 1635
_ExtentX = 2884
_ExtentY = 344
_Version = 393216
Max = 99
TickFrequency = 10
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Max"
Height = 195
Index = 5
Left = 1320
TabIndex = 20
Top = 1080
Width = 315
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Min"
Height = 195
Index = 4
Left = 60
TabIndex = 19
Top = 1080
Width = 315
End
End
Begin VB.Frame Frame3
Caption = " Record Volume "
Height = 1335
Index = 1
Left = 1980
TabIndex = 7
Top = 300
Width = 1755
Begin VB.OptionButton optRecordSet
Caption = "Set"
Height = 255
Left = 420
TabIndex = 13
Top = 540
Width = 855
End
Begin VB.OptionButton optRecordAuto
Caption = "Auto"
Height = 195
Left = 60
TabIndex = 10
Top = 300
Value = -1 'True
Width = 735
End
Begin VB.OptionButton optRecordDefault
Caption = "Default"
Height = 255
Left = 840
TabIndex = 9
Top = 300
Width = 855
End
Begin MSComctlLib.Slider sldRecord
Height = 195
Left = 60
TabIndex = 8
Top = 780
Width = 1635
_ExtentX = 2884
_ExtentY = 344
_Version = 393216
LargeChange = 500
SmallChange = 100
Min = -10000
Max = 0
TickFrequency = 1000
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Min"
Height = 195
Index = 3
Left = 60
TabIndex = 12
Top = 1080
Width = 315
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Max"
Height = 195
Index = 2
Left = 1320
TabIndex = 11
Top = 1080
Width = 315
End
End
Begin VB.Frame Frame3
Caption = " Playback Volume "
Height = 1335
Index = 0
Left = 120
TabIndex = 2
Top = 300
Width = 1755
Begin VB.OptionButton optVolumeSet
Caption = "Set"
Height = 255
Left = 1020
TabIndex = 4
Top = 300
Width = 675
End
Begin VB.OptionButton optVolumeDefault
Caption = "Default"
Height = 195
Left = 60
TabIndex = 3
Top = 300
Value = -1 'True
Width = 855
End
Begin MSComctlLib.Slider sldVolume
Height = 195
Left = 60
TabIndex = 37
Top = 780
Width = 1635
_ExtentX = 2884
_ExtentY = 344
_Version = 393216
LargeChange = 500
SmallChange = 100
Min = -10000
Max = 0
TickFrequency = 1000
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Max"
Height = 195
Index = 1
Left = 1320
TabIndex = 6
Top = 1080
Width = 315
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Min"
Height = 195
Index = 0
Left = 60
TabIndex = 5
Top = 1080
Width = 315
End
End
End
End
Attribute VB_Name = "frmVoiceSettings"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmVoiceSettings.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdCancel_Click()
fGotSettings = False
Unload Me
End Sub
Private Sub cmdOk_Click()
fGotSettings = True
'Setup up the clients stuff
If optAgressivenessDefault.Value Then
oClient.lBufferAggressiveness = DVBUFFERAGGRESSIVENESS_DEFAULT
oSession.lBufferAggressiveness = DVBUFFERAGGRESSIVENESS_DEFAULT
Else
oClient.lBufferAggressiveness = sldAggressiveness.Value
oSession.lBufferAggressiveness = sldAggressiveness.Value
End If
If optQualityDefault Then
oClient.lBufferQuality = DVBUFFERQUALITY_DEFAULT
oSession.lBufferQuality = DVBUFFERQUALITY_DEFAULT
Else
oClient.lBufferQuality = sldQuality.Value
oSession.lBufferQuality = sldQuality.Value
End If
If optnSensitivityAuto.Value Then
oClient.lThreshold = DVTHRESHOLD_UNUSED
ElseIf optSensitivitySet Then
oClient.lThreshold = sldSensitivity.Value
oClient.lFlags = oClient.lFlags Or DVCLIENTCONFIG_MANUALVOICEACTIVATED
ElseIf optSensitivityDefault.Value Then
oClient.lThreshold = DVTHRESHOLD_DEFAULT
oClient.lFlags = oClient.lFlags Or DVCLIENTCONFIG_MANUALVOICEACTIVATED
End If
If optRecordAuto.Value Then
oClient.lFlags = oClient.lFlags Or DVCLIENTCONFIG_AUTOVOICEACTIVATED
ElseIf optRecordDefault.Value Then
oClient.lRecordVolume = 0
ElseIf optRecordSet.Value Then
oClient.lRecordVolume = sldRecord.Value
End If
If optVolumeDefault Then
oClient.lPlaybackVolume = DVPLAYBACKVOLUME_DEFAULT
ElseIf optVolumeSet Then
oClient.lPlaybackVolume = sldVolume.Value
End If
oClient.lNotifyPeriod = 0
'Now set up the server stuff
oSession.lSessionType = DVSESSIONTYPE_PEER
Dim oData As DVCOMPRESSIONINFO
dvServer.GetCompressionType cboCompressionTypes.ListIndex + 1, oData, 0
oSession.guidCT = oData.guidType
Unload Me
End Sub
Public Sub ClientOnly()
fraServer.Enabled = False
fraCompression.Enabled = False
End Sub
Private Sub Form_Load()
Dim lIndex As Long
'Set up the defaults
sldAggressiveness.Min = DVBUFFERAGGRESSIVENESS_MIN
sldAggressiveness.Max = DVBUFFERAGGRESSIVENESS_MAX
sldAggressiveness.LargeChange = (DVBUFFERAGGRESSIVENESS_MAX - DVBUFFERAGGRESSIVENESS_MIN) \ 10
sldAggressiveness.TickFrequency = sldAggressiveness.LargeChange
sldQuality.Min = DVBUFFERQUALITY_MIN
sldQuality.Max = DVBUFFERQUALITY_MAX
sldQuality.LargeChange = (DVBUFFERQUALITY_MAX - DVBUFFERQUALITY_MIN) \ 10
sldQuality.TickFrequency = sldQuality.LargeChange
sldSensitivity.Min = DVTHRESHOLD_MIN
sldSensitivity.Max = DVTHRESHOLD_MAX
sldSensitivity.LargeChange = (DVTHRESHOLD_MAX - DVTHRESHOLD_MIN) \ 10
sldSensitivity.TickFrequency = sldSensitivity.LargeChange
Dim lCount As Long, oData As DVCOMPRESSIONINFO
If (dvServer Is Nothing) Then Set dvServer = dx.DirectPlayVoiceServerCreate
For lCount = 1 To dvServer.GetCompressionTypeCount
dvServer.GetCompressionType lCount, oData, 0
cboCompressionTypes.AddItem oData.strName
If InStr(oData.strName, "sc03") Then
lIndex = lCount - 1
End If
Next
cboCompressionTypes.ListIndex = lIndex
End Sub
Private Sub optRecordAuto_Click()
If optRecordAuto.Value Then
If optSensitivityDefault.Value Then optnSensitivityAuto.Value = True
End If
End Sub
Private Sub optSensitivityDefault_Click()
If optSensitivityDefault.Value Then
If optRecordAuto.Value Then optRecordSet.Value = True
End If
End Sub
Private Sub optSensitivitySet_Click()
If optSensitivitySet.Value = True Then
optRecordDefault.Value = True
End If
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/VoiceGroup/frmVoiceSettings.frx Normal file
View File

Binary file not shown.

29
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/VoiceGroup/readme.txt Normal file
View File

@@ -0,0 +1,29 @@
//-----------------------------------------------------------------------------
//
// Sample Name: VB Voice Group Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
VoiceGroup is similar in form to SimpleVoice. Once a player hosts or connects
to a session, the players can chat with either other.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\VoiceGroup
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Refer to User's Guide section of the SimpleVoice sample.
Programming Notes
=================
The Voice differs by letting clients send audio data to all players
connected to the session, or to specify which group to send to.

37
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/VoiceGroup/vb_VoiceGroup.VBp Normal file
View File

@@ -0,0 +1,37 @@
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
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; mscomctl.ocx
Form=frmVoice.frm
Module=DplayModule; Dplay.bas
Form=frmVoiceSettings.frm
Form=..\..\common\DplayCon.frm
IconForm="frmVoice"
Startup="Sub Main"
HelpFile=""
Title="vb_VoiceGroup"
Command32=""
Name="vbVoiceGroup"
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