Save / Export all Shapes on Page as Images

[sunthun]

I am sure this is already posted somewhere, but I cannot find it...

I need some code to SAVE ALL SHAPES ON PAGE AS IMAGES.  Like the post for
Export All Pages in Document  http://www.visguy.com/2006/09/18/export-all-pages-in-document/ meets the post for CallByName  http://www.visguy.com/2008/06/23/save-time-simplify-your-vba-code-with-callbyname/.

I need every shape on the page be saved as an image file, and I would really, REALLY like for each file name to be determined by a Shape Data or User-Defined field.

Any help would be tremendously appreciated!!!

Sunshine

[aledlund]

something like this
http://visguy.com/vgforum/index.php?topic=1491.0
al

[sunthun]

Well, sort of...
That is exporting the drawing; I want to export each shape on the page.

[aledlund]

As in most methods in Visio vba, the export method is actually looking for an 'object'. It should also work with shapes even though the sample code demonstrates a page.

http://msdn.microsoft.com/en-us/library/ff769010.aspx

al

[sunthun]

Right - so how would I modify that code to work for the selected shape?

Public Sub Export_Example()
Dim vsoPage As Visio.Page
Set vsoPage = ActivePage
vsoPage.Export ("C:\\myExportedPage.bmp")
End Sub

[aledlund]

something like this
al

Code Select Expand


Option Explicit

Public Sub exportPageShapesAsPNG()

Dim strFileType As String
strFileType = ".png"

Dim visPage As Visio.Page
Dim visShape As Visio.Shape
Dim strShapeText As String
Dim strFilePath As String
strFilePath = "c:\temp\"
For Each visPage In Application.ActiveDocument.Pages
    For Each visShape In visPage.Shapes
     ' assumes some text to identify the shape has been entered
     strShapeText = visShape.Text
     ' replace any spaces with underscores
     strShapeText = Replace(strShapeText, " ", "_")
     exportShapeAsPNG visShape, strFilePath & strShapeText & strFileType
    Next visShape
Next visPage

MsgBox "Macro complete"


End Sub

Private Sub exportShapeAsPNG _
    (ByVal visShape As Visio.Shape, _
    ByVal strFile As String)

    On Error GoTo ErrHandler

    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    ActiveDocument.DiagramServicesEnabled = visServiceVersion140

'Set the export resolution to the printer resolution at 600 x 600 pixels/inch
Application.Settings.SetRasterExportResolution visRasterUsePrinterResolution, 600#, 600#, visRasterPixelsPerInch
'Set the export size to custom 2 x 2 inches
Application.Settings.SetRasterExportSize visRasterFitToCustomSize, 2#, 2#, visRasterInch
'Set the data format to Interlace
Application.Settings.RasterExportDataFormat = visRasterInterlace
'Set the color format to 24-bit color
Application.Settings.RasterExportColorFormat = visRaster24Bit
'Do not rotate the image
Application.Settings.RasterExportRotation = visRasterNoRotation
'Don't flip the image
Application.Settings.RasterExportFlip = visRasterNoFlip
'Set the background color
Application.Settings.RasterExportBackgroundColor = 14798527
'Set the transparency color
Application.Settings.RasterExportTransparencyColor = 13269045
'Use the transparency color
Application.Settings.RasterExportUseTransparencyColor = True

    visShape.Export strFile
    GoTo ExitHandler

ErrHandler:
    MsgBox Err.Description
   
ExitHandler:
    'Restore diagram services
    ActiveDocument.DiagramServicesEnabled = DiagramServices

End Sub





[sunthun]

Al, you angel, that did it!
I just changed visShape.Text to visShape.Name, and instant gratification!

Your help is truly appreciate.  Thanks!!!

[aledlund]

no problem, have a great weekend
al