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
Related
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.
I am having this weird issue when I am trying to add textboxes in a Word document from an Excel file. Textboxes are being placed in a loop in all the pages which all contain a table. When I run the code, the first textbox is placed correctly but when I increment to go to next page (where there is a table), the textbox is placed at incorrect position.
I noticed that when I remove the table element the code works fine and all textboxes are placed correctly but when I add back the table, the first page comes out fine but the subsequent pages textboxes are placed incorrectly. Below is an example:
Here is a snippet of my code:
Public Sub test9()
Dim objWord As Object
Dim objDoc As Object
Dim box As Object
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\Users\user\Downloads\Test2.docx")
objWord.Visible = True
For i = 1 To 10
objWord.Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=i
Set doc = objWord.ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 53, 130, 20)
doc.TextFrame.TextRange.InsertAfter "Test Box" & i
Next i
End Sub
To reproduce the error you can create a tables in multiple pages and if you run, you'll see the output as shown in the picture.
I am not sure what is causing this or if I am missing anything, please point it out.
This worked for me - get the range of the page you want - then anchor the textbox shape to it.
I tested it in Word - you'll have to modify to match your object declarations
Sub test()
Dim i As Integer
Dim objTextBox As Object ' TextBox Shape
Dim objRge As Object ' Word Object Range
For i = 1 To ActiveDocument.ComputeStatistics(wdStatisticPages)
Set objRge = ActiveDocument.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=i)
Set objRge = objRge.GoTo(What:=wdGoToBookmark, Name:="\page")
' next you specify the page range as your textbox anchor parameter
Set objTextBox = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 53, 130, 20, Anchor:=objRge)
objTextBox.TextFrame.TextRange.InsertAfter "Test Box" & i
Next i
End Sub
If you're running from inside Excel and don't have a reference to Word, you'll need to predefine the Word constants - try this
Option Explicit
Const TestDoc As String = "C:\Users\<yourusername>\Documents\Test2.docx"
Public Sub TestFromExcel()
Dim objWord As Object
Dim objDoc As Object
Dim box As Object
' Define Word constants in Excel if you don't have a reference to WORD
Const wdGoToAbsolute As Long = 1
Const wdStatisticPages As Long = 2
Const wdGoToPage As Long = 1
Const wdGoToBookmark As Long = -1
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(TestDoc)
objWord.Visible = True
Dim i As Integer
Dim objTextBox As Object ' TextBox Shape
Dim objRge As Object ' Word Object Range
For i = 1 To objDoc.ComputeStatistics(wdStatisticPages)
Set objRge = objDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=i)
Set objRge = objRge.GoTo(What:=wdGoToBookmark, Name:="\page")
Set box = objDoc.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 53, 130, 20, Anchor:=objRge)
box.TextFrame.TextRange.InsertAfter "Test Box" & i
Next i
End Sub
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
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
I have to know how can i link the excel database of Instrument loop Diagram in AutoCad format. I have AutoCad Template for a loop typical and Excel Database in which i have 100 Loops information for particular typical.I have AutoCad 2006,2007 and 2011 with me. please suggest idea for linking and generating he AutoCAD Drawings automatically.
The easiest way would be to learn a bit of AutoLisp, which is really worth learning if you're into generating drawings or automating your processes within AutoCAD.
Here's a great website for learning AutoLisp:
http://www.afralisp.net/index.php
AutoDesk's Lisp forum is also a great source of help.
As for extracting the data from Excel, here is a library which really facilitates access from AutoLisp:
http://download.cnet.com/KozMos-VLXLS/3000-2077_4-94214.html
'General rule: excel and acad have to be same like both 64bit or both 32 bit !!!
' You will need to add a reference to the AutoCAD
' Type Library to run this example book. Use the "Tools -
' References" menu. If you prefere you can switch to late
' binding by changeing the AutoCAD types to generic objects
Public Sub Excel_drives_acadPolyline_import_POINTs()
Dim objApp As AcadApplication
Dim objDoc As AcadDocument
Dim objEnt As AcadEntity
Dim varPnt As Variant
Dim strPrmpt As String
Dim intVCnt As Integer
Dim varCords As Variant
Dim varVert As Variant
Dim varCord As Variant
Dim varNext As Variant
Dim intCrdCnt As Integer
On Error GoTo Err_Control
Set objApp = AINTERFACE.Iapp
Set objDoc = objApp.activedocument
AppActivate objApp.CAPTION
objDoc.Utility.GetEntity objEnt, varPnt
If TypeOf objEnt Is AcadLWPolyline Then
AppActivate ThisDrawing.applicaTION.CAPTION
varCords = objEnt.COORDINATES
For Each varVert In varCords
intVCnt = intVCnt + 1
Next
For intCrdCnt = 0 To intVCnt / 2 - 1
varCord = objEnt.COORDINATE(intCrdCnt)
Excel.applicaTION.Cells(intCrdCnt + 1, 1).value = varCord(0)
Excel.applicaTION.Cells(intCrdCnt + 1, 2).value = varCord(1)
Next intCrdCnt
Else
MsgBox "Selected entity was not a LWPolyline"
End If
Exit_Here:
If Not objApp Is Nothing Then
Set objApp = Nothing
Set objDoc = Nothing
End If
Exit Sub
Err_Control:
'debug.print err.DESCRIPTION
Resume Exit_Here
End Sub
'----------------------------------------------------------------
' You will need to add a reference to the Excel
' Type Library to run this.In case of excel excel.exe is the library !
Sub acad-drives_excel()
Dim xAP As Excel.applicaTION
Dim xWB As Excel.Workbook
Dim xWS As Excel.WorkSheet
Set xAP = Excel.applicaTION
Set xWB = xAP.Workbooks.Open(SLOPEDIR.PROJECT & "\A2K2_VBA\IUnknown.xls")
Set xWS = xWB.Worksheets("Sheet1")
MsgBox "Excel says: """ & Cells(1, 1) & """"
Dim A2K As AcadApplication
Dim A2Kdwg As AcadDocument
Set A2K = AINTERFACE.Iapp
Set A2Kdwg = A2K.applicaTION.documents.Add
MsgBox A2K.NAME & " version " & A2K.version & _
" is running."
Dim HEIGHT As Double
Dim p(0 To 2) As Double
Dim TxtObj As ACADTEXT
Dim TxtStr As String
HEIGHT = 1
p(0) = 1: p(1) = 1: p(2) = 0
TxtStr = Cells(1, 1)
Set TxtObj = A2Kdwg.modelspace.AddText(TxtStr, _
p, HEIGHT)
A2Kdwg.SaveAs SLOPEDIR.PROJECT & "\A2K2_VBA\IUnknown.dwg"
A2K.documents.Close
A2K.Quit
Set A2K = Nothing
xAP.Workbooks.Close
xAP.Quit
Set xAP = Nothing
End Sub
Whatever way you choose now you can draw into the autocad drawing by using VBA.
There is another way for non programmers.
AUTOCAD SCRIPT
in fact you can create a excel table which creates this things and then you can export them to a text file. For simple task a solution but crap if you hase more complex things to do.
And last but not least you can create dynamic blocks and use vba to insert them and set the values of their parameters according to your excel sheet. But this would explode this tiny post