541 lines
16 KiB
Plaintext
541 lines
16 KiB
Plaintext
VERSION 5.00
|
|
Begin VB.Form MulticastDraw
|
|
AutoRedraw = -1 'True
|
|
Caption = "Form1"
|
|
ClientHeight = 6315
|
|
ClientLeft = 60
|
|
ClientTop = 345
|
|
ClientWidth = 6390
|
|
LinkTopic = "Form1"
|
|
ScaleHeight = 6315
|
|
ScaleWidth = 6390
|
|
StartUpPosition = 3 'Windows Default
|
|
Begin VB.Frame Frame1
|
|
Caption = "Quality of Service"
|
|
Height = 975
|
|
Left = 3600
|
|
TabIndex = 6
|
|
Top = 5280
|
|
Width = 2535
|
|
Begin VB.OptionButton Option2
|
|
Caption = "&Recoverable"
|
|
Height = 255
|
|
Index = 1
|
|
Left = 240
|
|
TabIndex = 4
|
|
Top = 600
|
|
Width = 1335
|
|
End
|
|
Begin VB.OptionButton Option1
|
|
Caption = "&Express"
|
|
Height = 255
|
|
Index = 0
|
|
Left = 240
|
|
TabIndex = 3
|
|
Top = 240
|
|
Value = -1 'True
|
|
Width = 1095
|
|
End
|
|
End
|
|
Begin VB.TextBox FriendPortNumber
|
|
Height = 285
|
|
Left = 3000
|
|
TabIndex = 1
|
|
Top = 4800
|
|
Width = 1815
|
|
End
|
|
Begin VB.TextBox FriendIPAddress
|
|
Height = 285
|
|
Left = 3000
|
|
TabIndex = 0
|
|
Top = 4320
|
|
Width = 1815
|
|
End
|
|
Begin VB.CommandButton Attach
|
|
Caption = "&Start Sending"
|
|
BeginProperty Font
|
|
Name = "MS Sans Serif"
|
|
Size = 8.25
|
|
Charset = 0
|
|
Weight = 400
|
|
Underline = 0 'False
|
|
Italic = 0 'False
|
|
Strikethrough = 0 'False
|
|
EndProperty
|
|
Height = 375
|
|
Left = 5040
|
|
TabIndex = 2
|
|
Top = 4320
|
|
Width = 1095
|
|
End
|
|
Begin VB.PictureBox Picture1
|
|
Enabled = 0 'False
|
|
Height = 3855
|
|
Left = 240
|
|
MousePointer = 1 'Arrow
|
|
ScaleHeight = 253
|
|
ScaleMode = 0 'User
|
|
ScaleWidth = 381.161
|
|
TabIndex = 5
|
|
Top = 120
|
|
Width = 5895
|
|
End
|
|
Begin VB.Label Label2
|
|
Caption = "Send drawing to port number:"
|
|
Height = 255
|
|
Left = 240
|
|
TabIndex = 8
|
|
Top = 4800
|
|
Width = 2295
|
|
End
|
|
Begin VB.Label Label1
|
|
Caption = "Send drawing to multicast IP address:"
|
|
Height = 255
|
|
Left = 240
|
|
TabIndex = 7
|
|
Top = 4320
|
|
Width = 2655
|
|
End
|
|
End
|
|
Attribute VB_Name = "MulticastDraw"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = False
|
|
Attribute VB_PredeclaredId = True
|
|
Attribute VB_Exposed = False
|
|
' ------------------------------------------------------------------------
|
|
' Copyright (C) 1999 Microsoft Corporation
|
|
'
|
|
' You have a royalty-free right to use, modify, reproduce and distribute
|
|
' the Sample Application Files (and/or any modified version) in any way
|
|
' you find useful, provided that you agree that Microsoft has no warranty,
|
|
' obligations or liability for any Sample Application Files.
|
|
' ------------------------------------------------------------------------
|
|
'
|
|
' Type Guid
|
|
'
|
|
Const guidDraw = "{151ceac0-acb5-11cf-8b51-0020af929546}"
|
|
Option Explicit
|
|
Const MaxNumLen = 7
|
|
Private Type Line
|
|
X1 As Long
|
|
Y1 As Long
|
|
X2 As Long
|
|
Y2 As Long
|
|
End Type
|
|
|
|
Dim lLastX As Long
|
|
Dim lLastY As Long
|
|
Dim Lines() As Line
|
|
Dim cLines As Integer
|
|
Dim lArraySize As Integer
|
|
Dim strScreenText As String
|
|
Dim fWasText As Integer
|
|
Dim strLogin As String
|
|
Dim q As MSMQQueue
|
|
Dim WithEvents qevent As MSMQEvent
|
|
Attribute qevent.VB_VarHelpID = -1
|
|
Dim destFriend As New MSMQDestination
|
|
Dim msgOut As MSMQMessage
|
|
Dim fDsEnabled As Boolean
|
|
|
|
|
|
|
|
'
|
|
'Locate a remote queue
|
|
'
|
|
Private Sub Attach_Click()
|
|
Dim strComputerName As String
|
|
Dim lTempPointer As Long
|
|
|
|
' enables to open a new multicast addres.
|
|
If Not destFriend Is Nothing Then
|
|
If destFriend.IsOpen Then destFriend.Close
|
|
End If
|
|
|
|
|
|
If FriendIPAddress = "" Then
|
|
MsgBox "Please fill in IP address.", , "Missing value"
|
|
Exit Sub
|
|
End If
|
|
If FriendPortNumber = "" Then
|
|
MsgBox "Please fill in port number.", , "Missing value"
|
|
Exit Sub
|
|
End If
|
|
|
|
lTempPointer = MousePointer
|
|
MousePointer = 11 'ccArrowHourglass
|
|
|
|
' setting the format name.
|
|
destFriend.FormatName = "MULTICAST=" & FriendIPAddress.Text & ":" _
|
|
& FriendPortNumber.Text
|
|
|
|
On Error GoTo open_error
|
|
' open the destination
|
|
destFriend.open
|
|
On Error GoTo 0
|
|
|
|
MousePointer = lTempPointer
|
|
Picture1.Enabled = True
|
|
|
|
Exit Sub
|
|
|
|
open_error:
|
|
|
|
' an error happend when openning the queues.
|
|
MsgBox Err.Description, , "Destination openning error"
|
|
|
|
FriendIPAddress.Text = ""
|
|
FriendPortNumber.Text = ""
|
|
|
|
MsgBox "The Multicast address was reset. Please enter the values again.", , "Queues Open Error"
|
|
End Sub
|
|
|
|
|
|
Private Sub Connection_Click()
|
|
|
|
End Sub
|
|
|
|
'
|
|
' Application Initialization
|
|
'
|
|
Private Sub Form_Load()
|
|
Dim query As New MSMQQuery
|
|
Dim qinfo As MSMQQueueInfo
|
|
Dim strDefaultQueueName As String
|
|
Dim lTempPointer As Long
|
|
Dim qinfos As MSMQQueueInfos
|
|
Dim strComputerName As String
|
|
Dim bIsNew As Boolean
|
|
bIsNew = False
|
|
|
|
|
|
Set msgOut = New MSMQMessage
|
|
|
|
|
|
' Check the value of the global IsDsEnabled
|
|
fDsEnabled = IsDsEnabled
|
|
|
|
If Not fDsEnabled Then
|
|
MulticastDefs.QueueType.Enabled = False
|
|
End If
|
|
|
|
' setting some default parameters:
|
|
|
|
strDefaultQueueName = Environ("USERNAME")
|
|
MulticastDefs.txtQueueName = strDefaultQueueName
|
|
MulticastDefs.txtIPAddress = "239.15.78.212"
|
|
MulticastDefs.txtPortNumber = "2563"
|
|
|
|
' get data regarding the input queue
|
|
MulticastDefs.Show 1
|
|
|
|
strLogin = UCase(MulticastDefs.txtQueueName)
|
|
Caption = "Listening to: " & strLogin & " ... " & MulticastDefs.txtIPAddress & ":" & _
|
|
MulticastDefs.txtPortNumber
|
|
|
|
FriendIPAddress.Text = MulticastDefs.txtIPAddress
|
|
FriendPortNumber.Text = MulticastDefs.txtPortNumber
|
|
|
|
If dDirectMode = vbNo Then 'user asked for public queue
|
|
|
|
' first, trying to locate the queue:
|
|
Set qinfos = query.LookupQueue( _
|
|
Label:=strLogin, _
|
|
ServiceTypeGuid:=guidDraw)
|
|
On Error GoTo ErrorHandler
|
|
qinfos.Reset 'Locate this queue
|
|
Set qinfo = qinfos.Next
|
|
If qinfo Is Nothing Then
|
|
' The queue was not found - creating a new queue.
|
|
Set qinfo = New MSMQQueueInfo
|
|
strComputerName = "."
|
|
qinfo.PathName = strComputerName + "\" + strLogin
|
|
qinfo.Label = strLogin
|
|
qinfo.ServiceTypeGuid = guidDraw
|
|
|
|
' setting the queue's multicast address
|
|
qinfo.MulticastAddress = MulticastDefs.txtIPAddress & ":" & _
|
|
MulticastDefs.txtPortNumber
|
|
qinfo.Create
|
|
Err.Number = 0
|
|
Else
|
|
|
|
' setting the queue's multicast address
|
|
qinfo.Refresh
|
|
qinfo.MulticastAddress = MulticastDefs.txtIPAddress & ":" & _
|
|
MulticastDefs.txtPortNumber
|
|
qinfo.Update
|
|
End If
|
|
Set q = qinfo.open(MQ_RECEIVE_ACCESS, 0)
|
|
|
|
Else
|
|
|
|
' open a private queue
|
|
' The computer is either DS Disabled or the user
|
|
' chose to open a private queue
|
|
|
|
Set qinfo = New MSMQQueueInfo
|
|
'Create and open a local private queue
|
|
qinfo.FormatName = "DIRECT=OS:.\private$\" & strLogin
|
|
qinfo.PathName = ".\private$\" & strLogin
|
|
qinfo.Label = strLogin
|
|
qinfo.ServiceTypeGuid = guidDraw
|
|
lTempPointer = MousePointer
|
|
MousePointer = 11 'ccArrowHourglass
|
|
qinfo.MulticastAddress = MulticastDefs.txtIPAddress & ":" & _
|
|
MulticastDefs.txtPortNumber
|
|
Err.Clear
|
|
|
|
On Error GoTo opening
|
|
qinfo.Create
|
|
bIsNew = True
|
|
|
|
opening:
|
|
|
|
On Error GoTo ErrorHandler
|
|
Set q = qinfo.open(MQ_RECEIVE_ACCESS, 0)
|
|
On Error GoTo 0
|
|
MousePointer = lTempPointer
|
|
|
|
|
|
' If it is not a new queue, then the multicast address set in the
|
|
' creation, was not set. Setting the Multicast address :
|
|
If Not bIsNew Then
|
|
qinfo.Refresh
|
|
qinfo.MulticastAddress = MulticastDefs.txtIPAddress & ":" & _
|
|
MulticastDefs.txtPortNumber
|
|
qinfo.Update
|
|
End If
|
|
On Error GoTo 0
|
|
|
|
End If
|
|
|
|
'All messages will be received asynchronously
|
|
' So we need an event handler
|
|
Set qevent = New MSMQEvent
|
|
q.EnableNotification qevent
|
|
|
|
Exit Sub
|
|
|
|
ErrorHandler:
|
|
MsgBox "Error locating or creating queue.", , "Multicast Draw"
|
|
End
|
|
End Sub
|
|
'
|
|
'Gets points and returns a line
|
|
'
|
|
Private Function PointsToLine(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Line
|
|
Dim lineNew As Line
|
|
lineNew.X1 = X1
|
|
lineNew.Y1 = Y1
|
|
lineNew.X2 = X2
|
|
lineNew.Y2 = Y2
|
|
PointsToLine = lineNew
|
|
End Function
|
|
'
|
|
'Draw a line in the picture control
|
|
'
|
|
Private Sub DrawLine(lineDraw As Line)
|
|
Picture1.Line (lineDraw.X1, lineDraw.Y1)-(lineDraw.X2, lineDraw.Y2)
|
|
fWasText = False
|
|
End Sub
|
|
'
|
|
'Display a line
|
|
'
|
|
Private Sub AddLine(lineNew As Line)
|
|
DrawLine lineNew
|
|
cLines = cLines + 1
|
|
If (cLines > lArraySize) Then
|
|
lArraySize = cLines * 2
|
|
ReDim Preserve Lines(lArraySize)
|
|
End If
|
|
Lines(cLines - 1) = lineNew
|
|
End Sub
|
|
'
|
|
'Clear the display
|
|
'
|
|
Private Sub ClearDraw()
|
|
cLines = 0
|
|
strScreenText = ""
|
|
Picture1.Refresh
|
|
End Sub
|
|
'
|
|
'Decode a string into a line
|
|
'
|
|
Private Function LineToString(lineIn As Line) As String
|
|
Dim strFormat As String
|
|
strFormat = String(MaxNumLen, "0")
|
|
LineToString = Format$(lineIn.X1, strFormat) + Format$(lineIn.Y1, strFormat) + Format$(lineIn.X2, strFormat) + Format$(lineIn.Y2, strFormat)
|
|
End Function
|
|
'
|
|
'Encode a line into a string
|
|
'
|
|
Private Function StringToLine(strIn As String) As Line
|
|
Dim lineOut As Line
|
|
lineOut.X1 = Val(Mid$(strIn, 1, MaxNumLen))
|
|
lineOut.Y1 = Val(Mid$(strIn, MaxNumLen + 1, MaxNumLen))
|
|
lineOut.X2 = Val(Mid$(strIn, MaxNumLen * 2 + 1, MaxNumLen))
|
|
lineOut.Y2 = Val(Mid$(strIn, MaxNumLen * 3 + 1, MaxNumLen))
|
|
StringToLine = lineOut
|
|
End Function
|
|
|
|
Private Sub Form_Unload(Cancel As Integer)
|
|
If q.IsOpen2 Then
|
|
q.Close
|
|
End If
|
|
If destFriend.IsOpen Then
|
|
destFriend.Close
|
|
End If
|
|
End
|
|
End Sub
|
|
|
|
Private Sub FriendComputer_Change()
|
|
Attach.Enabled = True
|
|
End Sub
|
|
|
|
Private Sub FriendName_Change()
|
|
Attach.Enabled = True
|
|
End Sub
|
|
|
|
Private Sub Option3_Click(Index As Integer)
|
|
dDirectMode = Index
|
|
End Sub
|
|
|
|
'
|
|
'Message Receive event
|
|
'
|
|
Private Sub qevent_Arrived(ByVal q As Object, ByVal lCursor As Long)
|
|
Dim msgIn As MSMQMessage
|
|
Dim lineNew As Line
|
|
Dim strTextIn As String
|
|
|
|
On Error GoTo ErrorHandler
|
|
Set msgIn = q.Receive(ReceiveTimeout:=100)
|
|
If Not msgIn Is Nothing Then
|
|
strTextIn = msgIn.Body 'Read the body of the message
|
|
If Len(strTextIn) = 1 Then 'If 1 byte long
|
|
TypeChar strTextIn 'it is a character - so display it
|
|
Else
|
|
lineNew = StringToLine(msgIn.Body) 'Otherwise it is a line
|
|
AddLine lineNew 'so draw it
|
|
End If
|
|
End If
|
|
ErrorHandler:
|
|
' reenable event firing
|
|
q.EnableNotification qevent
|
|
End Sub
|
|
|
|
Private Sub qevent_ArrivedError(ByVal pdispQueue As Object, ByVal lErrorCode As Long, ByVal lCursor As Long)
|
|
MsgBox Hex$(lErrorCode), , "Receive Error!"
|
|
q.EnableNotification qevent
|
|
End Sub
|
|
|
|
Private Sub Option1_Click(Index As Integer)
|
|
msgOut.Delivery = MQMSG_DELIVERY_EXPRESS
|
|
End Sub
|
|
|
|
Private Sub Option2_Click(Index As Integer)
|
|
msgOut.Delivery = MQMSG_DELIVERY_RECOVERABLE
|
|
End Sub
|
|
|
|
'
|
|
'Key press event
|
|
'
|
|
Private Sub Picture1_KeyPress(KeyAscii As Integer)
|
|
TypeChar (Chr(KeyAscii)) 'Display the character
|
|
If Not destFriend Is Nothing Then
|
|
If destFriend.IsOpen Then
|
|
msgOut.Priority = 4 'Set the priority to 4 (high)
|
|
msgOut.Body = Chr(KeyAscii) 'Fill the body with the character
|
|
msgOut.Label = "Key: " + msgOut.Body
|
|
msgOut.Send destFriend 'And send the message
|
|
End If
|
|
End If
|
|
End Sub
|
|
'
|
|
'Display a character
|
|
'(Handles backspace)
|
|
'
|
|
Private Sub TypeChar(Key As String)
|
|
If Asc(Key) = 8 Then 'BackSpace
|
|
If strScreenText <> "" Then
|
|
strScreenText = Left$(strScreenText, Len(strScreenText) - 1)
|
|
Picture1.Refresh
|
|
End If
|
|
Else
|
|
strScreenText = strScreenText + Key
|
|
If fWasText Then
|
|
Picture1.Print Key;
|
|
Else
|
|
Picture1.Refresh
|
|
End If
|
|
End If
|
|
End Sub
|
|
'
|
|
'Mouse Down Event
|
|
'
|
|
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
|
|
If Button = 1 Then 'Remember mouse location
|
|
lLastX = X
|
|
lLastY = Y
|
|
End If
|
|
End Sub
|
|
'
|
|
'Mouse Move Event
|
|
'
|
|
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
|
|
If Button = 1 And X > 0 And Y > 0 Then 'Something to draw?
|
|
Dim lineNew As Line
|
|
lineNew = PointsToLine(lLastX, lLastY, X, Y) 'Get a new line
|
|
AddLine lineNew 'And display it
|
|
If Not destFriend Is Nothing Then
|
|
If destFriend.IsOpen Then
|
|
msgOut.Priority = 3 'Set the priority to 3 (low)
|
|
msgOut.Body = LineToString(lineNew) 'Fill the body with the line
|
|
msgOut.Label = str(lLastX) + "," + str(lLastY) + " To " + str(X) + "," + str(Y)
|
|
msgOut.Send destFriend 'And send the message
|
|
End If
|
|
End If
|
|
lLastX = X
|
|
lLastY = Y
|
|
End If
|
|
End Sub
|
|
'
|
|
'2nd button click == Clear the display
|
|
'
|
|
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
|
|
If Button = 2 Then ClearDraw
|
|
End Sub
|
|
'
|
|
'Repaint the display event
|
|
'
|
|
Private Sub Picture1_Paint()
|
|
Dim I As Integer
|
|
For I = 0 To cLines - 1
|
|
DrawLine Lines(I)
|
|
Next
|
|
Picture1.CurrentX = 0
|
|
Picture1.CurrentY = 0
|
|
Picture1.Print strScreenText;
|
|
fWasText = True
|
|
End Sub
|
|
'
|
|
'Get local computer name
|
|
'
|
|
Function GetLocalComputerName() As String
|
|
Dim str As String
|
|
Dim res As Boolean
|
|
Dim maxlen As Long
|
|
|
|
maxlen = 512
|
|
str = Space(maxlen)
|
|
res = GetComputerNameA(str, maxlen)
|
|
If res = False Then
|
|
GetLocalComputerName = ""
|
|
Exit Function
|
|
End If
|
|
|
|
GetLocalComputerName = Mid(str, 1, maxlen)
|
|
End Function
|
|
|