Author Topic: Shapes to Excel  (Read 2472 times)

0 Members and 1 Guest are viewing this topic.

Thomas Winkel

  • Full Member
  • ***
  • Posts: 228
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