MapForums

Private Sub CopyShapes()
   'general variables
   Dim srcFile As String
   Dim targFile As String
   Dim selItem As Variant
 '  Dim mpYellow As Long
   'mappoint variables
   Dim MPApp1 As MapPoint.Application
   Dim MPApp2 As MapPoint.Application
   Dim MPMap1 As MapPoint.Map
   Dim MPMap2 As MapPoint.Map
   Dim MPShape As MapPoint.Shape
   'application variables
   Dim FD As FileDialog
   
  ' mpYellow = &HFFFF&
   
   'set up file dialog and get source file name
   Set FD = Application.FileDialog(msoFileDialogFilePicker)
   FD.AllowMultiSelect = False
   FD.Filters.Clear
   
   FD.Filters.Add "MapPoint Files", "*.ptm"
   
   'select target file
   With FD
      .Title = "Select the file to which you want to copy:"
      If .Show = -1 Then
          For Each selItem In FD.SelectedItems
             targFile = selItem
          Next
      Else
        'user pressed cancel, no file to process so exit
        Exit Sub
      End If
   End With
   
   'initialize target map
   Set MPApp1 = CreateObject("Mappoint.Application")
   Set MPMap1 = MPApp1.OpenMap(targFile, False)
 
   'you might want to put this at the end
   'the map spins and moves around a lot as the
   'copy work is being done
   'disadvantage to moving to the end is if an error occurs
   'MapPoint will run in the background unless you kill it in the 
   'task manager
   MPApp1.Visible = True
   MPApp1.UserControl = True
   
   Application.Activate
   'select source files
   With FD
      .AllowMultiSelect = True
      .Title = "Copy shapes from:"
      If .Show = -1 Then
          For Each selItem In FD.SelectedItems
             srcFile = selItem
 
   
          Set MPApp2 = CreateObject("Mappoint.Application")
          Set MPMap2 = MPApp2.OpenMap(srcFile, True)
          MPApp2.Visible = True
          MPApp2.UserControl = True

          'this part will make you dizzy if you choose to 
          'make the applications visible
          For Each MPShape In MPMap2.Shapes
             If MPShape.Type = geoFreeform Or geoAutoShape Then
                MPShape.Copy
                MPMap1.Paste
             End If
          Next

            Next
      Else
        'user pressed cancel, no file to process so exit
        Exit Sub
      End If
   End With
   'clean up
   
   Set MPApp1 = Nothing
   Set MPApp2 = Nothing
   
   Set MPMap1 = Nothing
   Set MPMap2 = Nothing
   
   Set MPShape = Nothing
   Set FD = Nothing
End Sub

Public Sub CopyShapes()

If MPShape.Type = geoFreeform Or geoAutoShape Then

 If MPShape.Fill.ForeColor = mpYellow And (MPShape.Type = geoFreeform Or geoAutoShape) Then