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
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
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:
' 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