How To Pass a Picture Object Remotely Using COM

Option Explicit

Public Sub ReceivePic(PassedPic As Variant)
   Dim i As Integer, j As Integer
   Dim MyFile As String
   Dim tb() As Byte
   ' This public sub routine shows how to pass an object using an
   ' icon.

   On Error GoTo BadObj
   i = UBound(PassedPic)
   ' Repack the variant into the byte array for binary write.
   ReDim tb(i) As Byte

   For j = LBound(PassedPic) To UBound(PassedPic)
      tb(j) = PassedPic(j)
   Next j

   ' Write to a local file.
   MyFile = "C:\TestPass.bmp"
   Open MyFile For Binary As #1

   For j = LBound(tb) To UBound(tb)
      Put #1, , tb(j)
   Next j
   Close #1

   ' Recreate the object from a file.
   Set frmDCOMDemoClient.picPassIcon.Picture = LoadPicture(MyFile)
   Kill MyFile
   Exit Sub

BadObj:
   MsgBox Err.Number & ": " & Err.Description & _
        " - " & "Object Pass    Failed..."
End Sub
					

Option Explicit

Public mbIsConnected As Boolean
Public objMyClassInstance As Object
Private oServer As PicServer.clsPassPicture

Private Sub cmdGetObject_Click()
   ' This subroutine calls the server to initiate the icon pass.
   Dim rf As Boolean

   ' Connect to your server, selected in the Project References
   ' dialog box.
   Set oServer = New PicServer.clsPassPicture
   ServerConnect                 'Set up the callback.
   If mbIsConnected Then
      rf = oServer.ServerIcon    'Call remote server method.
      If rf Then
         MsgBox "Icon Passed Successfully..."
      Else
         MsgBox "Icon Pass Failed..."
      End If
      ServerDisconnect           ' Clean up after the callback.
   Else
      MsgBox "Callback Connection Failed"
   End If
End Sub

Public Sub ServerConnect()
   Dim bsuccess As Integer
   Dim bRetVal As Boolean
   Dim iCounter As Integer

   ' Used by the OLE Collision Handler.
   Dim nCurErrorCount As Integer
   Const MAX_ERROR_COUNT = 10

   On Error GoTo cmdButtonError
   Screen.MousePointer = vbHourglass
   Set objMyClassInstance = New clsReceivePicture
   If oServer.AddObjectReference(objMyClassInstance) Then
        mbIsConnected = True
   Else
       mbIsConnected = False
   End If
   Screen.MousePointer = vbDefault
   Exit Sub

cmdButtonError:
' When using asynchronous callbacks between two objects, you need
' this error checking code to deal with the possibility of a
' collision. This collision can occur when a client and server
' attempt to call each other at the same time. This error handler
' forces the client to wait for a random period of time and retry the
' failed operation. During this time, the server should complete its
' call to the client, allowing the client to succeed when it retries
' the call to the server. You should also include the same error
' handling code in the server object.

If Erl = 100 And Err = &H80010001 Then
   If nCurErrorCount >= MAX_ERROR_COUNT Then
      MsgBox "Unable to obtain server reference.  Retry later.", _
      vbExclamation, "Remote Server Connect Error"
      Resume EndOfError
   Else
      For iCounter = 1 To 2000 * Rnd()
         DoEvents
      Next iCounter
      Resume
   End If
End If
Screen.MousePointer = vbDefault
MsgBox Error$, vbCritical, "cmdButton Error"
EndOfError:

End Sub

Public Sub ServerDisconnect()
   Dim bsuccess As Integer
   Dim bRetVal As Boolean
   Dim iCounter As Integer

   ' Used by the OLE Collision Handler.
   Dim nCurErrorCount As Integer
   Const MAX_ERROR_COUNT = 10

   On Error GoTo cmdButtonError
   Screen.MousePointer = vbHourglass
   If oServer.DropObjectReference(objMyClassInstance) Then
      mbIsConnected = False
     'Dereference the local object.
      Set objMyClassInstance = Nothing
      Set oServer = Nothing
      MsgBox "Disconnect Successful..."
   Else
      MsgBox "Disconnect Failed..."
   End If
   Screen.MousePointer = vbDefault
   Exit Sub

cmdButtonError:
   If Erl = 100 And Err = &H80010001 Then
      If nCurErrorCount >= MAX_ERROR_COUNT Then
        MsgBox "Unable to release server reference.  Retry later.", _
        vbExclamation, "Remote Server Disconnect Error"
        Resume EndOfError
      Else
         For iCounter = 1 To 2000 * Rnd()
             DoEvents
         Next iCounter
         Resume
      End If
   End If
   Screen.MousePointer = vbDefault
   MsgBox Error$, vbCritical, "cmdButton Error"
EndOfError:
   
End Sub
					

Option Explicit

Sub Main()
  Load frmDCOMDemoClient
  frmDCOMDemoClient.Show
End Sub