Visio VBA Export Shapedata to Excel, and copy back to Visio

[wapperdude]

Yes.  I know there is the Reports... capability within Visio.  Not sure how much it's changed since V2007.  But, some times, you want to automate the process.  Trying to run the Reports dialog using some version of runargs never seem to get to be fully automated.  However, there are a lot of options with the Reports..., and this post is not that detailed in scope.

What it does.  From the active page, will search thru all shapes on the page, gather all of the custom prop info from the shapesheet, write to Excel, then bring it back and paste it on a new page in the Visio file. 

It is broken down into 4 modules.  The main module passes the shapes collection for the active page to the shape searching module.  This 2nd module examines each shape on the page, rejects 1D shapes, and ignores shapes with no data.  Names of acceptable shapes along with the shape data is stored into a dynamic array.  Once all shapes have been interrogated, the third is called to export the data into excel and then reformat the occupied cells on the worksheet.  After all of the Excel work is done, the relevant cells are copied and pasted back onto a new page in the Visio document.  But, before it writes back, it will delete any entry that the program had previously added.

Since the code is modular, it ought to be easy to modify.  For example, have it check all pages in the document.  Presently, there is an error routine, so if you start from a page with no shapes with data, it will kick you out.  It would also be simple to forego the "write back" to Visio as this is a separate module.  Or, maybe other sections of the shapesheet are of interest.  Relatively straightforward to change the search criteria.  But, no, I decided not to make a user form with a myriad of checkable options.

The file contains three shapes.  The 3rd shape has no shapedata.  The 2nd page shows the excel file results of the above process for these 3 shapes.  The code has a lot of comments.  Hopefully that will promote understanding of the subs.

For those who want just the code:

Code Select Expand



Public Sub shpMain()
' Code only works on current, active page (window)
   shpData ActivePage.Shapes       'Calls sub to loop thru all shapes on active page
End Sub

Sub shpData(ByVal shps As Shapes)
' Loops thru all shapes on the active page.
Dim shpObj As Visio.Shape
Dim celObj As Visio.Cell
Dim shpCnt As Integer
Dim intRows As Integer, rCnt As Integer, maxRows As Integer
Dim curShpIndx As Integer
Dim propData As String
Dim prpData() As String

'Initialize parameters
shpCnt = shps.Count
intRows = 0
maxRows = 0

' Shape loop routine to look fetch custom property section info.
'It is here that code could be modified to look thru other shapesheet sections.
For curShpIndx = 1 To shpCnt
    Set shpObj = shps(curShpIndx)
    If Not shpObj.OneD Then             'Ignore 1D shapes, e.g., lines and connectors
        If shpObj.SectionExists(Visio.visSectionProp, False) Then
            intRows = shpObj.RowCount(Visio.visSectionProp)
            If intRows > maxRows Then maxRows = intRows
            ReDim Preserve prpData(shpCnt, maxRows)
            prpData(curShpIndx, 0) = shpObj.Name
            For rCnt = 0 To intRows - 1                 'iterate thru all rows
                Set celObj = shpObj.CellsSRC(Visio.visSectionProp, rCnt, visCustPropsValue)
                propData = celObj.ResultStr(Visio.visNone)
                prpData(curShpIndx, rCnt + 1) = propData
            Next
        End If
    End If
Next

' Check the active page for shapes had reportable shapedata
If shpCnt > 0 And maxRows > 0 Then
    Call ExcelReport(shpCnt, maxRows, prpData())
Else
    MsgBox "No reportable shapes on active page " & ActivePage.Name
End If

End Sub

Sub ExcelReport(ByVal shpCnt, maxCnt, ByRef shpData() As String)
' This sub exports data to Excel, then formats the Excel worksheet.
Dim i As Integer, j As Integer
Dim XlApp As Object
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim prpData(10, 10) As String

Set XlApp = CreateObject("Excel.Application")
Set XlWrkbook = XlApp.Workbooks.Add
Set XlSheet = XlWrkbook.Worksheets("Sheet1")

'Next 2 lines affect Excel window
XlApp.Visible = False
XlApp.ScreenUpdating = False

'First Row contains titles for the columns.
XlSheet.Cells(1, 1) = "Shape"
For j = 1 To maxCnt
    XlSheet.Cells(1, j + 1) = "Row" & j
Next j
   
'Beginning with 2nd row, shape and it's data or entered into Excel
For i = 1 To shpCnt
    For j = 0 To maxCnt
        XlSheet.Cells(i + 1, j + 1) = shpData(i, j)
    Next j
Next i

' END EXPORTING TO EXCEL
' ******************************************************************************************
' BEGIN ALL EXCEL FORMATTING STEPS                          All reference have been made explicit to eliminate multiple execution run errors introduced by VBA.

    Dim LastCol As Long                                  'Only variables used in this section.
    Dim LastRow As Long
    Dim p As Integer
    Dim q As Long
    Dim rowCell As Range
    Dim FirstRow As Range
    Dim myUsedRng As Range
   
    Set myUsedRng = XlSheet.UsedRange
    Set FirstRow = myUsedRng.Rows(1).Cells          'This syntax seems to work!!!
   

'Row and column index counters
    LastCol = myUsedRng.Columns.Count             'This is last populated column.
    LastRow = myUsedRng.Rows.Count                'This is last populated row.
   
    With myUsedRng
     'Cell text alignment (center, middle)
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
   
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
   
     'Add light borders around all individual used cells
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
       
     'Heavy outer border around the used worksheet region
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).Weight = xlMedium
       
     'Set used cell background fill to white
        .Interior.Color = RGB(255, 255, 255)
    End With
   
' Double line:  selection range used is top row of cells
    FirstRow.Borders(xlEdgeBottom).LineStyle = xlDouble
    FirstRow.Borders(xlEdgeBottom).Weight = xlThick
   
'Set top row upper case, font bold, cell background fill to light yellow, and set column widths
    'For Each rowCell In myExSheet.Range(myExSheet.Cells(1, 1), myExSheet.Cells(1, LastCol))
    For Each rowCell In FirstRow
        rowCell = UCase(rowCell)
        rowCell.Font.Bold = True
        rowCell.Font.Color = RGB(0, 0, 200)
        rowCell.Font.Size = 9
        rowCell.Interior.Color = RGB(255, 255, 204)
        rowCell.EntireColumn.AutoFit
    Next rowCell
   
    XlApp.ScreenUpdating = True
' FINISHED EXCEL FORMATTING

    Call VisPushBack(myUsedRng)
   
' ******************************************************************************************
' Exit Excel:  this closes the Excel window.  It doesn't realy
' save the Workbook.  Sets the parameter so it will close without
' asking any questions.
'
'To save the Excel file, you need to make the window visible, and then close it manually.  Or save via code.
' XlApp.Visible = True
'

    XlWrkbook.Saved = True                                       
    XlApp.Quit
End Sub

Sub VisPushBack(myUsedRng)
' Copies the used Excel range of cells, adds a page to Visio, pastes
' the Excel copy as worksheet into Visio, and renames it.
' If table exists, deletes it before pasting new one.
'
    Dim vsoPage1 As Visio.Page
    Dim vsoShp As Visio.Shape
    Dim visSel As Visio.Selection

    myUsedRng.Copy
   
    'Next lines add a new page called Excel.  This fails if page exists!!!
    'Comment out, worksheet goes on current active page.
    On Error GoTo addPage       'Error if no page named Excel
        Set vsoPage = ActiveDocument.Pages("Excel")
        ActiveWindow.Page = vsoPage
        ActiveWindow.DeselectAll
    On Error GoTo AddTable      'Error if no table exists
        ActiveWindow.Select ActiveWindow.Page.Shapes.ItemU("Excel_Table"), visSelect
        Application.ActiveWindow.Selection.Delete
        GoTo AddTable
   
addPage:
    Set vsoPage1 = ActiveDocument.Pages.Add
    vsoPage1.Name = "Excel"
    vsoPage1.Background = False
    vsoPage1.Index = 2
    vsoPage1.PageSheet.CellsSRC(visSectionObject, visRowPageLayout, visPLOSplit).FormulaForceU = "1"
    vsoPage1.PageSheet.CellsSRC(visSectionUser, 0, visUserValue).FormulaForceU = ""
   
    'This line places the worksheet items on the active Visio page
AddTable:
    Visio.ActiveWindow.Page.PasteSpecial 49162, False, False
'   ActiveWindow.Page.Shapes.ItemFromID(1).Name = "Excel_Table"
    Set visSel = Visio.ActiveWindow.Selection
   
    If visSel.Count > 0 Then        'The newly placed object is only selection
        For Each vsoShp In visSel
           vsoShp.Name = "Excel_Table"
        Next
    End If
End Sub

Enjoy
Wapperdude

[Yacine]

Hi Wayne,
I did read your post, bit did not want to reply by a simple "nice", "well done", or "awful".
I do nevertheless value your effort. Especially knowing that you don't like to code.
I even read these posts with delight (sorry for the expression), as they show that you are not only ready, but also willing to embrace the next step - namely automation.

You may have read some of my posts, where I asked how to get from the simple VBA to the coding of the big guys with C#, addons, Visual Studio and so on. For the moment, I got rid of these ambitions, because I realized, that I can do much more of my time with this simple VBA and some other office tools than trying to do it the "bigger" way.
Especially Access got me into it. I wrote some quite robust applications, just with the power of Visio and Access. Every "real" programmer would wrinkle his nose reading this. But I'm more interested in results than in style. And both Visio and Access have the power to put simple user wishes into solutions.

As for your Excel post,
1) this is definitely THE way to go because,
a) Visio's reports are too poor
b) Users want (need) to be able to put reports on their drawings

My Ideas (wishes) on the project:
2) have a tool as flexible as Vsio's report tool. Gather all the available props. Let the user chose the right ones. Have some SQL capabilities (Filtering and Grouping).
3) Work with excel templaytes. --> Less formating.
4) Get a very generic too.
5) Have the tool available to the "World". Not buried in a post of the forum. --> GitHub???

Just some ideas,
Cheers,
Yacine

[wapperdude]

All good comments ...   
1)  I can barely spell SQL, let alone pronounce it.  Haven't the foggiest what to do with it.
2)  This is do-able, I'm thinking User form.   However, wasn't sure the  "demand" would justify the effort.  Read lazy.
3)  Well, the formatting is barebones.  Not sure if all of the formatting code shown is needed, but I included it for completeness.  Makes a starting point for customization.  Regarding the templates...haven't tried this, but, setting the excel window to visible, I think all of the Excel functionality would be there.  This might be a selectable option on the user form.
4)  not sure what is meant by generic?
5)  Didn't think the code was sufficiently mature for broader user base.  Plus, have never done anything like that.  Not sure I want that level of exposure.

Glad you took the extra time.  The feedback is always welcome, especially constructive ideas.

Thanks.
Wapperdude