Author Topic: Shapes to Excel  (Read 10135 times)

0 Members and 1 Guest are viewing this topic.

Thomas Winkel

  • Full Member
  • ***
  • Posts: 239
Shapes to Excel
« on: March 15, 2021, 03:24:07 PM »
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

  • Full Member
  • ***
  • Posts: 239
Re: Shapes to Excel
« Reply #1 on: September 21, 2022, 05:38:47 AM »
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
« Last Edit: September 21, 2022, 06:16:07 AM by Thomas Winkel »