Convert to Bitmap and Retain Selection

Sub B_PMWR()
    Dim groups As ShapeRange
    Dim group As Shape
    Dim groupname As String, path As String
    Set groups = ActiveSelectionRange
    Dim i As Long
    Dim pctdone As Single
    Dim doc As Document
    Set doc = ActiveDocument
    
    'Optimize True
    
    ActiveDocument.BeginCommandGroup "Quantity"
    
    Quantity.Show
    
    ActiveDocument.EndCommandGroup
    
'Display Progress Bar
    ufProgress.LabelProgress.Width = 0
    ufProgress.Show

    For i = 1 To groups.Count
    
'Update progress bar
    pctdone = i / groups.Count
    With ufProgress
        .LabelCaption.Caption = "Printing " & i & " of " & groups.Count
        .LabelProgress.Width = pctdone * (.FrameProgress.Width)
    End With
    DoEvents
    
'-------the rest of your macro goes below here-------

    If Quantity.BitmapChk = True Then
'        Set groups = ActiveSelectionRange.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, False, False)
        ActiveSelectionRange.ConvertToBitmapEx cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, False, False
        groups.Selected = True
        'ActivePage.Layers("1 (CMYK)").Activate  'Converting to Bitmap removes the active selection. Code stops.
    End If

    groupname = groups.Shapes(i).Name
    groups.Shapes(i).CreateSelection
    

    
    'FIT TO PAGE:
    GMSManager.RunMacro "JQ_Fit_Page_To_Content", "JQ.Fit_Page_To_Content_No_Form"
    
    If ActivePage.SizeWidth > 129 Then
        If ActivePage.SizeHeight <= 36 Then
            With doc
                With .PrintSettings
                     .SelectPrinter "B PMWR"
                     .UsePPD = True
                     .PPDFile = "C:\Program Files\Fiery\Fiery XF Universal Driver\Release\WinDll\i386x64\EFIUnidrv.PPD"
                     .PageMatchingMode = prnPageMatchSizeAndOrientation
                     .Copies = ActiveShape.Name
                End With
                .PrintOut
            End With
        End If
    
    Else
    
    If ActivePage.SizeHeight > 129 Then
        If ActivePage.SizeWidth <= 36 Then
            With doc
                With .PrintSettings
                     .SelectPrinter "B PMWR"
                     .UsePPD = True
                     .PPDFile = "C:\Program Files\Fiery\Fiery XF Universal Driver\Release\WinDll\i386x64\EFIUnidrv.PPD"
                     .PageMatchingMode = prnPageMatchSizeAndOrientation
                     .Copies = ActiveShape.Name
                End With
                .PrintOut
            End With
        End If
    
    Else
    
    
    If ActivePage.SizeWidth <= 36 Or ActivePage.SizeHeight <= 36 Then
        With doc
            With .PrintSettings
                 .PrintRange = prnSelection
                 .SelectPrinter "B PMWR" 'enter printer name in between quotes to use that printer.
                 .PageMatchingMode = prnPageMatchSizeAndOrientation
                 .Copies = ActiveShape.Name
            End With
            .PrintOut
        End With
    End If
    End If
    End If
    
    'For Prints on 60" Media
    If ActivePage.SizeWidth > 129 Then
        If ActivePage.SizeHeight > 36 Then
            With doc
                With .PrintSettings
                     .SelectPrinter "C PMWR 60"
                     .UsePPD = True
                     .PPDFile = "C:\Program Files\Fiery\Fiery XF Universal Driver\Release\WinDll\i386x64\EFIUnidrv.PPD"
                     .PageMatchingMode = prnPageMatchSizeAndOrientation
                     .Copies = ActiveShape.Name
                End With
                .PrintOut
            End With
        End If
    
    Else
    
    If ActivePage.SizeWidth > 36 Then
        If ActivePage.SizeHeight > 36 Then
            With doc
                With .PrintSettings
                     .PrintRange = prnSelection
                     .SelectPrinter "C PMWR 60" 'enter printer name in between quotes to use that printer.
                     .PageMatchingMode = prnPageMatchSizeAndOrientation
                     .Copies = ActiveShape.Name
                End With
                .PrintOut
            End With
        End If
    End If
    End If
    
'----------------------------------------------------
'Close Progress Bar
    Next i
    Unload ufProgress

'Zoom Out To All Objects
    ActiveWindow.ActiveView.ToFitAllObjects
    
'Undo
    For Each group In groups
    ActiveDocument.Undo
    Next group
    
    ActiveDocument.Undo
    
    'Optimize False
    
End Sub