VBA to create a timeline in Visio - excel

How do we create a timeline diagram in Visio using VBA scripts?
I am trying to do this from excel. I have written the VBA script to open the visio diagram and create a basic shape. I want to create a timeline diagram.
Similar to basic_u.vss and visMSDefault, are there any parameters that are required while creating a timeline diagram?
Below is the code snippet that I am using.
Option Explicit
Sub VisioFromExcel()
Dim AppVisio As Object
Dim vsoCharacters1 As Visio.Characters
Dim lX As Long
Dim dXPos As Double
Dim dYPos As Double
'Const visSectionCharacter = 3
'Const visCharacterSize = 7
Set AppVisio = CreateObject("visio.application")
'Set AppVisio = CreateObject("VisioTimelineVBA")
AppVisio.Visible = True
AppVisio.Documents.AddEx "", visMSDefault, 0 'Open Blank Visio Document
'AppVisio.Documents.AddEx "", visMSDefault, 0 'Open Blank Visio Document
AppVisio.Documents.OpenEx "basic_u.vss", visOpenRO + visOpenDocked 'Add Basic Stencil
dXPos = AppVisio.ActivePage.PageSheet.Cells("PageWidth") / 2
dYPos = AppVisio.ActivePage.PageSheet.Cells("PageHeight") / 2
For lX = 1 To Cells(Rows.Count, 1).End(xlUp).Row
AppVisio.Windows.ItemEx(1).Activate
AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("BASIC_U.VSS").Masters.ItemU("Square"), dXPos, dYPos
Set vsoCharacters1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lX).Characters
vsoCharacters1.Begin = 0
vsoCharacters1.End = 0
vsoCharacters1.Text = CStr(Cells(lX, 1).Value)
AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lX).CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "36 pt"
Next
Set AppVisio = Nothing
End Sub

The below code worked for me.
Option Explicit
Sub VisioFromExcel()
Dim AppVisio As Object
Dim docsObj As Visio.Documents
Dim DocObj As Visio.Document
Dim pagsObj As Visio.Pages
Set AppVisio = CreateObject("visio.application")
AppVisio.Visible = True
Set docsObj = AppVisio.Documents
Set DocObj = docsObj.Add("Timeline.vst")
Set pagsObj = AppVisio.ActiveDocument.Pages
Set AppVisio = Nothing
End Sub

Related

Copy and paste picture from excel to word

I am trying to try another method that is not to export the images from excel and then import them to word.
This method makes use of copy and paste, however I have encountered a problem using different versions of Office. In some it pastes it as InlineShape and in another as Shape.
I don't know how to correctly reference a variable in the pasted image. I thought I could use something like set object = selection after pasting the image but it doesn't work.
The purpose of referencing it is to add a text that allows me to delete it if I insert an update of the same image.
For the inlineshape I have solved it using the InlineShape.Range.BookmarkID property but if it is a Shape object I don't know the way.
Could anyone help me?
Code:
Sub Copy_Paste_Image_Bookmark(sBookmark As String, sImage As String, Optional sSheet As String, Optional sWorkbook As String)
Dim xlApp As Excel.Application, xlWrk As Excel.Workbook, xlSht As Excel.Worksheet
Dim oShp As Excel.Shape
Set xlApp = GetObject(, "Excel.Application")
Set xlWrk = xlApp.Workbooks(sWorkbook)
Set xlSht = xlWrk.Worksheets(sSheet)
xlSht.Shapes(sImage).Copy
'Control for word
Dim docWord As Word.Document
Dim oBookmark As Bookmark, rBookmark As Word.Range, oInLiShp As Word.InlineShape
Dim lInLiShapes As Long, idx As Long, lInLiShapes_old As Long
Dim lShapes As Long, lShapes_old As Long, bIsInlineShape As Boolean, bIsShape As Boolean
Dim oShape As Word.Shape, oShapes As Word.Shapes
Set docWord = ThisDocument
'If exists bookmark
If docWord.Bookmarks.Exists(sBookmark) Then
Set oBookmark = docWord.Bookmarks(sBookmark)
Set rBookmark = oBookmark.Range
'Delete previous text
'rBookmark.MoveEndUntil Chr(46), wdForward 'chr(12) jump page
rBookmark.Expand Unit:=wdParagraph
rBookmark.MoveEnd Unit:=wdCharacter, Count:=-1
If StrComp(rBookmark.Text, "Text test") = 0 Then rBookmark.Delete
'Delete previous image
idx = GetIndex_Inlishape_BookmarkID(oBookmark.Range.BookmarkID)
If idx > 0 Then docWord.InlineShapes(idx).Delete
'Recover count of shapes
lInLiShapes_old = docWord.InlineShapes.Count
lShapes_old = docWord.Shapes.Count
'Paste image
rBookmark.PasteAndFormat wdFormatOriginalFormatting
'Recover new count shapes
lInLiShapes = docWord.InlineShapes.Count
lShapes = docWord.Shapes.Count
'Determine type pasted shape
bIsInlineShape = lInLiShapes > lInLiShapes_old
bIsShape = lShapes > lShapes_old
'If is inlineshape
If bIsInlineShape And bIsShape = False Then
idx = GetIndex_Inlishape_BookmarkID(oBookmark.Range.BookmarkID)
Set oInLiShp = docWord.InlineShapes(idx)
ElseIf bIsShape And bIsInlineShape = False Then
Set oShape = docWord.Shapes(lShapes)
'Convert to inlineshape
Set oInLiShp = oShape.ConvertToInlineShape
Else
Exit Sub
End If
'Change some options
oInLiShp.Title = sImage
oInLiShp.Range.Paragraphs.Alignment = wdAlignParagraphCenter
Else
MsgBox "The bookmark " & sBookmark & " doesn't exist in the document.", vbOKOnly + vbCritical, "Not exists bookmark"
End If
End Sub
Function GetIndex_Inlishape_BookmarkID(bkm_ID As Long) As Long
Dim o As InlineShape, i As Long
For Each o In ThisDocument.InlineShapes
i = i + 1
If o.Range.BookmarkID = bkm_ID Then
Select Case o.Type
Case wdInlineShapePicture
GetIndex_Inlishape_BookmarkID = i
Exit Function
End Select
End If
Next
GetIndex_Inlishape_BookmarkID = 0
End Function
Solved with Set oShape = docWord.Shapes(sImage) because image pasted keep the name of shape from Excel although with .count of the collection Shapes run fine.
However with .count of the collection inlineshapes not run fine because Word orders the elements, first the shapepictures and after shapecharts.
Thanks.

Manipulating Visio shapes using Excel VBA

I am trying to manipulate Visio shapes using Excel VBA using the following code it is not generating errors but its not running
Sub ShapeControl()
Dim shp As Visio.Shape
Dim mst As Master
Dim Verdana_ID As Integer
Dim ActiveDoc As Object
Dim ActivePage As Object
Dim VisioApp As Object
Set ActiveDoc = GetObject("C:\Users\z028317\Desktop\Architecutre Flowchart.vsdm")
Verdana_ID = ActiveDoc.Fonts.Item("Verdana").ID
Set ActivePage = ActiveDoc.Pages("Page-1")
' iterate all shapes per page
For Each shp In ActivePage.Shapes
' declare parent master for current shape
Set mst = shp.Master
' Process only shapes that have parent master-shape
If Not (mst Is Nothing) Then
' Connector Properties Settings
If mst.Name = "Dynamic connector" Then shp.Cells("LineColor").Formula = "RGB(255,192,0)": shp.Cells("LineWeight").Formula = "1.0 pt"
' Process Box Properties Settings
If mst.Name = "Process" Then shp.Cells("Width").Formula = "1.0": shp.Cells("Height").Formula = "1.0 ": shp.Characters.CharProps(visCharacterSize) = 12
VisioApp.Visible = True
End If
Exit For
Next
End Sub

VB.NET: Excel Crashes when Updating Data in a Word Chart

Update: Releasing objects has no effect on Excel crashing. The problematic line is:
Dim wChartData = wChart.ChartData
I have written a VB.Net application that opens a word document, iterates through the inline shapes, and updates each chart with data from the database. Sometimes Excel will crash when opening the sheet containing the chart data. Can anyone tell me how I fix this?
Here is the code that iterates through the shapes:
wApp = New Word.Application
wApp.Visible = True
wDoc = wApp.Documents.Add("Some_File_Name.docx")
Console.WriteLine("Updating Charts")
Dim chartName As String
For Each wShape As Word.InlineShape In wDoc.InlineShapes
If wShape.HasChart = Core.MsoTriState.msoTrue Then
If wShape.Chart.HasTitle Then
chartName = wShape.Chart.ChartTitle.Text
Else
chartName = "NO_TITLE"
End If
UpdateChart(wShape.Chart, reportID, reportTitle,
reportUser, curriculumYear, chartName)
End If
Next
The UpdateChart subroutine grabs a SQL query and some options related to the chart, then fires off the FillChartData subroutine below:
Public Sub FillChartData(ByRef wChart As Word.Chart, ByVal sql As String,
Optional ByVal addDataPointsToLabels As Boolean = False)
If sql = "" Then Exit Sub
Dim cmd = O.factory.CreateCommand()
cmd.CommandText = sql
cmd.Connection = O.con
O.factory.CreateDataAdapter()
Dim adapter = O.factory.CreateDataAdapter
adapter.SelectCommand = cmd
Dim dt As New System.Data.DataTable()
Dim ds As New System.Data.DataSet()
adapter.Fill(ds, "report_name")
dt = ds.Tables(0)
Dim wChartData = wChart.ChartData
Dim wChartWb As Excel.Workbook = wChartData.Workbook
Dim wChartSheet As Excel.Worksheet = wChartWb.Sheets(1)
Dim title As String = "No title"
If wChart.HasTitle Then title = wChart.ChartTitle.Text.ToString
Dim r As Excel.Range
r = wChartSheet.Range("A1")
r.CurrentRegion.Clear()
For i = 0 To dt.Columns.Count - 1
Dim c As System.Data.DataColumn = dt.Columns(i)
r.Offset(0, i).Value2 = c.ColumnName
Next
r = wChartSheet.Range("A2")
For Each row As System.Data.DataRow In dt.Rows
For i = 0 To row.ItemArray.Count - 1
r.Offset(0, i).Value2 = row.Item(i)
Next
r = r.Offset(1)
Next
r = wChartSheet.Range("A1")
If addDataPointsToLabels Then
While r.Value <> ""
r.Value &= " " & r.Offset(1).Value
r = r.Offset(0, 1)
End While
End If
wChartWb.Close()
releaseObject(r)
releaseObject(wChartSheet)
releaseObject(wChartWb)
releaseObject(wChartData)
r = Nothing
wChartSheet = Nothing
wChartWb = Nothing
wChartData = Nothing
GC.Collect()
End Sub
The releaseObject subroutine is as follows:
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
MessageBox.Show(ex.ToString)
obj = Nothing
End Try
End Sub
And here's the crash report:
Problem signature:
Problem Event Name: APPCRASH
Application Name: EXCEL.EXE
Application Version: 15.0.5007.1000
Application Timestamp: 5a5eb36d
Fault Module Name: EXCEL.EXE
Fault Module Version: 15.0.5007.1000
Fault Module Timestamp: 5a5eb36d
Exception Code: c0000005
Exception Offset: 002b71c8
OS Version: 6.1.7601.2.1.0.256.4
Locale ID: 1033
Additional information about the problem:
LCID: 1033
skulcid: 1033
Read our privacy statement online:
http://go.microsoft.com/fwlink/?linkid=104288&clcid=0x0409
If the online privacy statement is not available, please read our privacy statement offline:
C:\Windows\system32\en-US\erofflps.txt
Thanks for your help!
You need to Activate the Word ChartData object to begin the inter-process communication between Word and Excel.
The example below is a simplified demonstration of code pattern and contains no error handling. This example also demonstrates releasing out of scope COM objects via the garbage collector. See this answer for more discussion on this COM clean-up procedure.
This code was verified against Office 2007.
Imports System.Runtime.InteropServices
Imports Excel = Microsoft.Office.Interop.Excel
Imports Word = Microsoft.Office.Interop.Word
Public Class Form1
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
InterOpWork("Embedded Excel Chart.docx")
COMCleanup()
End Sub
Sub InterOpWork(filePath As String)
Dim appWord As New Word.Application
Dim doc As Word.Document = appWord.Documents.Open((filePath))
Dim shp As Word.InlineShape = doc.InlineShapes(1)
Dim ch As Word.Chart = shp.Chart
Dim chData As Word.ChartData = ch.ChartData
chData.Activate() ' **** This is what your code is missing
Dim wb As Excel.Workbook = DirectCast(chData.Workbook, Excel.Workbook)
Dim appExcel As Excel.Application = DirectCast(wb.Application, Excel.Application)
Dim ws As Excel.Worksheet = DirectCast(wb.Worksheets("Sheet1"), Excel.Worksheet)
Dim rng As Excel.Range = ws.Range("B2:B4")
Dim dataToChange As Object(,) = DirectCast(rng.Value2, Object(,))
For i As Int32 = dataToChange.GetLowerBound(0) To dataToChange.GetUpperBound(0)
dataToChange(i, 1) = i * 2 + (5 - i)
Next
rng.Value = dataToChange
wb.Save()
wb.Close(False)
appExcel.Quit()
doc.Save()
doc.Close(False)
appWord.Quit()
End Sub
Private Sub COMCleanup()
Do
GC.Collect()
GC.WaitForPendingFinalizers()
Loop While Marshal.AreComObjectsAvailableForCleanup
End Sub
End Class

Transfering shape data from Visio 2010 to Excel 2010 for further manipulation using VBA

I'm attempting to take shape data (withing specific shapes) and transfer their values into an Excel spreadsheet so that Excel can run functions on the transferred values.
The plan is to click on a shape and automatically send its specific shape data to Excel, where it will be manipulated further to create a very specific spreadsheet.
I'm using VBA for all the programming.
I know how to acquire shape data and manipulate it WITHIN Visio but I'm not sure how to pass it to Excel.
So, is this even possible? I know you can link shapes to data (which I've done) and hyperlink shapes to specific documents (which I've also done) but is it possible to send specific shape data to a document for further manipulation?
Please help, I've not been able to find any information on this situation anywhere.
Thank you in advance!
Yes it is possible. Here is some VBA code to create an Excel report from Visio.
Just remember that Excel VBA and Visio VBA have properties with the same name so make sure you fully qualify the Excel reference. Otherwise VBA gets confused.
Public Sub ExcelReport()
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim celObj1 As Visio.Cell, celObj2 As Visio.Cell
Dim curShapeIndx As Integer
Dim localCentx As Double, localCenty As Double, localCenty1 As Double
Dim ShapesCnt As Integer, i As Integer
Dim ShapeHeight As Visio.Cell, ShapeWidth As Visio.Cell
Dim XlApp As Excel.Application
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Set XlApp = CreateObject("excel.application")
' You may have to set Visible property to True if you want to see the application.
XlApp.Visible = True
Set XlWrkbook = XlApp.Workbooks.Add
Set XlSheet = XlWrkbook.Worksheets("sheet1")
Set shpObjs = ActivePage.Shapes
ShapesCnt = shpObjs.Count
XlSheet.Cells(1, 1) = "Indx"
XlSheet.Cells(1, 2) = "Name"
XlSheet.Cells(1, 3) = "Text"
XlSheet.Cells(1, 4) = "localCenty"
XlSheet.Cells(1, 5) = "localCentx"
XlSheet.Cells(1, 6) = "Width"
XlSheet.Cells(1, 7) = "Height"
' Loop through all the shapes on the page to find their locations
For curShapeIndx = 1 To ShapesCnt
Set shpObj = shpObjs(curShapeIndx)
If Not shpObj.OneD Then
Set celObj1 = shpObj.Cells("pinx")
Set celObj2 = shpObj.Cells("piny")
localCentx = celObj1.Result("inches")
localCenty = celObj2.Result("inches")
Set ShapeWidth = shpObj.Cells("Width")
Set ShapeHeight = shpObj.Cells("Height")
Debug.Print shpObj.Name, shpObj.Text, curShapeIndx; Format(localCenty, "000.0000") & " " & Format(localCentx, "000.0000"); " "; ShapeWidth; " "; ShapeHeight
i = curShapeIndx + 1
XlSheet.Cells(i, 1) = curShapeIndx
XlSheet.Cells(i, 2) = shpObj.Name
XlSheet.Cells(i, 3) = shpObj.Text
XlSheet.Cells(i, 4) = localCenty
XlSheet.Cells(i, 5) = localCentx
XlSheet.Cells(i, 6) = ShapeWidth
XlSheet.Cells(i, 7) = ShapeHeight
End If
Next curShapeIndx
XlApp.Quit ' When you finish, use the Quit method to close
Set XlApp = Nothing '
End Sub
John... Visio MVP

Application-defined or object-defined error in Excel VBA

I'm getting said error in using VBA in Excel on the following code:
Private Sub XMLGen(mapRangeA, mapRangeB, ticketSize, mapping)
Dim fieldOneArr As Variant
Dim fieldTwoArr As Variant
Dim row As Long
Dim column As Long
Dim infoCol As Long
Dim endInfo As Long
Dim objDom As DOMDocument
Dim objNode As IXMLDOMNode
Dim objXMLRootelement As IXMLDOMElement
Dim objXMLelement As IXMLDOMElement
Dim objXMLattr As IXMLDOMAttribute
Set ws = Worksheets("StockData")
Dim wsName As String
Set objDom = New DOMDocument
If ticketSize = 8 Then
wsName = "A7Tickets"
ElseIf ticketSize = 16 Then
wsName = "A8Tickets"
Else
wsName = "A5Tickets"
End If
Set ps = Worksheets(wsName)
'create processing instruction
Set objNode = objDom.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
objDom.appendChild objNode
'create root element
Set objXMLRootelement = objDom.createElement("fields")
objDom.appendChild objXMLRootelement
'create Attribute to the Field Element and set value
Set objXMLattr = objDom.createAttribute("xmlns:xfdf")
objXMLattr.NodeValue = "http://ns.adobe.com/xfdf-transition/"
objXMLRootelement.setAttributeNode objXMLattr
infoCol = 1
fieldOneArr = Worksheets(mapping).range(mapRangeA)
fieldTwoArr = Worksheets(mapping).range(mapRangeB)
For row = 1 To UBound(fieldOneArr, 1)
For column = 1 To UBound(fieldOneArr, 2)
'create Heading element
Set objXMLelement = objDom.createElement(fieldOneArr(row, column))
objXMLRootelement.appendChild objXMLelement
'create Attribute to the Heading Element and set value
Set objXMLattr = objDom.createAttribute("xfdf:original")
objXMLattr.NodeValue = (fieldTwoArr(row, column))
objXMLelement.setAttributeNode objXMLattr
objXMLelement.Text = ps.Cells(row, infoCol)
infoCol = infoCol + 1
endInfo = endInfo + 1
If endInfo = 4 Then
infoCol = 1
End If
Next column
Next row
'save XML data to a file
If ticketSize = 2 Then
objDom.Save ("C:\ExportTestA5.xml")
MsgBox "A5 XML created"
ElseIf ticketSize = 8 Then
objDom.Save ("C:\ExportTestA7.xml")
MsgBox "A7 XML created"
Else
objDom.Save ("C:\ExportTestA8.xml")
MsgBox "A8 XML created"
End If
End Sub
When I hit debug it points to this line:
fieldOneArr = Worksheets(mapping).range(mapRangeA)
I know that .Range is supposed to be upper case but it keeps on setting it to lower case automatically whenever I correct it.
This code is meant to create an XML file and then write the details from the chosen worksheet (based on the ticketSize variable) into the correct XML fields. Hence I have a mapping worksheet from which I write the field and attribute names, and then write in the info from the correct ticket size worksheet into the text property of the element.
You should define the types of your function parameters, in this case mapRangeA As String. Office object methods and properties are often not very helpful with their error messages, so it's better to have a type mismatch error if you have a problem with a parameter.

Resources