Shapes to Excel

[Thomas Winkel]

This code exports selected shapes as picture to Excel cells and comments (visible on mouse over).
Even the auto-filter is functional and will filter / sort the pictures with the table.

I played with the file formats and found the best results as:
* SVG for cell pictures
* EMF for comments

Notes:
* Limited file formats for comment pictures (e.g. no SVG)
* No text in SVG exports (maybe this depends on font, or text size)
* Pixel formats give good results for big shapes, only
* EMF exports have annoying transparent frames
* SVG exports fits the actual size
* File exports will not cause disc load because Windows memory / disc management keeps files in RAM until they are replaced or deleted.
* Nevertheless very slow for many shapes

Code

Option Explicit

Private Const xlSrcRange As Integer = 1
Private Const xlYes As Integer = 1
Private Const xlMoveAndSize As Integer = 1

Sub ExportArticles()
    Dim shp As Shape
    Dim i As Integer
    Dim xlsApp As Object 'Excel.Application
    Dim xlsWb As Object 'Excel.Workbook
    Dim xlsWs As Object 'Excel.Worksheet
    Dim xlsLo As Object 'Excel.ListObject
    
    Set xlsApp = CreateObject("Excel.Application")
    xlsApp.Visible = False
    Set xlsWb = xlsApp.Workbooks.Add
    Set xlsWs = xlsWb.Worksheets(1)
    xlsWs.Name = "Articles"
    Set xlsLo = xlsWs.ListObjects.Add(xlSrcRange, xlsWs.Cells(1, 1), , xlYes)
    xlsLo.Name = "Articles"
    xlsWs.Cells(1, 1).Value2 = "No"
    xlsWs.Cells(1, 2).Value2 = "Article"
    xlsWs.Cells(1, 3).Value2 = "Picture"
    xlsWs.Columns(3).ColumnWidth = 3 * xlsWs.Columns(3).ColumnWidth
    
    For Each shp In ActiveWindow.Selection
        i = i + 1
        xlsWs.Rows(i + 1).RowHeight = 3 * xlsWs.Rows(i + 1).RowHeight
        xlsWs.Cells(i + 1, 1).Value2 = i
        xlsWs.Cells(i + 1, 2).Value2 = shp.Name
        
        ExcelInsertShapeAsComment shp, xlsWs.Cells(i + 1, 2)
        ExcelInsertShape shp, xlsWs.Cells(i + 1, 3)
    Next shp
    
    xlsWs.Columns(1).AutoFit
    xlsWs.Columns(2).AutoFit
    xlsApp.Visible = True
End Sub

Public Sub ExcelInsertShape(shp As Visio.Shape, cell As Object) 'Excel.Range
    Dim picPath As String
    Dim xlsShp As Object 'Excel.Shape
    
    picPath = Environ("temp") & "\article.svg"
    shp.Export picPath
    
    Set xlsShp = cell.Worksheet.Shapes.AddPicture(picPath, msoFalse, msoTrue, cell.Left + 1, cell.Top + 1, -1, -1)
    xlsShp.Placement = xlMoveAndSize
    xlsShp.LockAspectRatio = msoCTrue
    xlsShp.Height = cell.Height - 2
    If xlsShp.Width > (cell.Width - 2) Then
        xlsShp.Width = cell.Width - 2
    End If
End Sub

Public Sub ExcelInsertShapeAsComment(shp As Visio.Shape, cell As Object) 'Excel.Range
    Dim picPath As String
    Dim cmt As Object 'Excel.Comment
    Dim xlsShp As Object 'Excel.Shape
    Dim objImage As Object
    
    picPath = Environ("temp") & "\article.emf"
    shp.Export picPath
    
    cell.ClearComments
    Set cmt = cell.AddComment
    cmt.Text " "
    
    cmt.Shape.Fill.UserPicture picPath
    Set xlsShp = cmt.Shape
    
    Set objImage = CreateObject("WIA.ImageFile")
    objImage.LoadFile picPath
    
    If objImage.Width / objImage.Height <= 1 Then
        xlsShp.Height = 150
        xlsShp.Width = objImage.Width / objImage.Height * 150
    Else
        xlsShp.Width = 180
        xlsShp.Height = objImage.Height / objImage.Width * 180
    End If
End Sub

[Thomas Winkel]

Since 2010 Visio offers special settings for raster graphics exports.
I guess the code above could benefit from these settings.
I did not investigate that but I note it here for reference:

Code

' This code is just a starting point for investigation. In this combination it makes no sense.
Sub ExportSelectedShapeAsImage()
    Dim shp As Visio.Shape
    Set shp = ActiveWindow.Selection.PrimaryItem
    
    'Specifies the raster export resolution settings.
    Application.Settings.SetRasterExportResolution visRasterUseCustomResolution, 600, 600, visRasterPixelsPerInch
    
    'Sets the raster export size.
    Application.Settings.SetRasterExportSize visRasterFitToSourceSize, 600, 600, visRasterPixel
    
    'Determines the background color that is applied to the exported image.
    Application.Settings.RasterExportBackgroundColor = 16777215
    
    'Determines the color format that is applied to the exported image.
    Application.Settings.RasterExportColorFormat = visRaster24Bit
    
    'Determines the color reduction that is applied to the exported image.
    Application.Settings.RasterExportColorReduction = visRasterDiffusion
    
    'Determines the data compression algorithm that is applied to the exported image (BMP, TIFF).
    Application.Settings.RasterExportDataCompression = visRasterLZW
    
    'Determines whether the exported image is interlaced or non-interlaced (PNG, GIF).
    Application.Settings.RasterExportDataFormat = visRasterInterlace
    
    'Determines the flip that is applied to the exported image.
    Application.Settings.RasterExportFlip = visRasterNoFlip
    
    'Determines the export operation that is applied to the exported image (JPG only).
    Application.Settings.RasterExportOperation = visRasterBaseline
    
    'Determines the export quality that is applied to the exported image (JPG only).
    Application.Settings.RasterExportQuality = 100
    
    'Determines the rotation that is applied to the exported image.
    Application.Settings.RasterExportRotation = visRasterNoRotation
    
    'Determines the transparency color that is applied to the exported image (PNG, GIF).
    Application.Settings.RasterExportTransparencyColor = 13269045
    
    'Determines whether Visio applies, to the exported image, the transparency color that is specified in the RasterExportTransparencyColor property (PNG, GIF).
    Application.Settings.RasterExportUseTransparencyColor = True
    
    shp.Export "C:\Temp\pic.png"
End Sub