InlineShapes exported as image add border

Question

Using below code for saving MS Word images and converting into base64.

When exporting the image it adds some borders.
Original Image

after export

If singleline.Range.InlineShapes.Count > 0 Then
    Dim shp1 As InlineShape
    Dim mchart1 As Shape
    Set shp1 = singleline.Range.InlineShapes(1)
    shp1.Select
    Selection.Copy
    Set mchart1 = ActiveDocument.Shapes.AddChart(xl3DAreaStacked, , , shp1.Width, shp1.Height)
    mchart1.Chart.ChartData.Workbook.Application.Quit
    mchart1.Chart.Paste
    mchart1.Chart.Export ("c:\here\" + CStr(i) + ".png")
    mchart1.Chart.Delete
    b64strng = ConvertFileToBase64("c:\here\" + CStr(i) + ".png")
    Kill "c:\here\" + CStr(i) + ".png"
End If

Is there any fix or Alternative to export images?

Answer 1

I don't see any difference between your screenshots, possibly because of the dark browser background. Is the border visible after the Export command, or after the ConvertFileToBase64 function?

It appears you're trying to export a non-chart graphic by using a chart kludge. You'll get better results by enlisting PowerPoint to do the graphics export. Here's a sample macro that shows how to export Word graphics from PowerPoint. You can modify this to export a single Shape or ShapeRange (your graphic) instead of a complete slide.

Public Sub ExportMap()
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShapeRange As PowerPoint.ShapeRange
Dim Path$, File$
Dim oRange As Range


  Application.ScreenUpdating = False
  If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
    ActiveDocument.Unprotect
  End If
  myDate$ = Format(Date, "m-d-yyyy")
  Set pptApp = CreateObject("PowerPoint.Application")
  Path$ = ActiveDocument.Path & Application.PathSeparator
  File$ = "WorldMap " & myDate$ & ".png"
  Set pptPres = pptApp.Presentations.Add(msoFalse)
  
  Set oRange = ActiveDocument.Bookmarks("WholeMap").Range
  oRange.CopyAsPicture
  
  Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
  On Error Resume Next
  With pptPres.PageSetup
    .SlideSize = 7
    .SlideWidth = 1150
    .SlideHeight = 590
  End With
  Set pptShapeRange = pptSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoFalse)
  With pptShapeRange
    .Top = .Top + 6
'    .Left = .Left + 510
  End With
  
  pptSlide.Export Path$ & File$, "PNG"
  
  pptApp.Quit
  
  Set pptPres = Nothing
  Set pptApp = Nothing
  Set pptSlide = Nothing
  If ActiveDocument.ProtectionType = wdNoProtection Then
    ActiveDocument.Protect Type:=wdAllowOnlyFormFields, noreset:=True
  End If
  Application.ScreenUpdating = True
  MsgBox "All done! Check the folder containing this template for a file called '" & File$ & "'."
End Sub