Linking Excel Database to AutoCad for Typical Loop Drawing Generation - excel

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

Related

Calling excel from solidworks works 1 time out of 2

This may sound a little bit dumb, but I have never experienced anything like this before with SolidWorks macro. I have written a SolidWorks macro that inserts a BOM table into an assembly saves it as excel, and adds needed formulas to an excel file. However it works 1 time out of 2- 1st time- all good, 2nd time I get an error- "Run-time error '1004' Method 'Rows' of object '_Global' Failed", 3rd time- all good, 4th time I get the same error and so on and so on. I'm really new to excel macro so I don't know if I'm missing something or just stupid?
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swBOMAnnotation As SldWorks.BomTableAnnotation
Dim i As Integer
Dim nNumRow As Variant
Dim swTableAnn As SldWorks.TableAnnotation
Dim swAnn As SldWorks.Annotation
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim template As String
Dim fType As String
Dim configuration As String
'excel variables
Dim x1App As Excel.Application
Dim xlWB As Excel.Workbook
Dim NextRow As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
template = "C:\Program Files\SOLIDWORKS Corp\SOLIDWORKS\lang\english\bom-all.sldbomtbt"
fType = swBomType_PartsOnly
configuration = "Default"
Set swBOMAnnotation = swModelDocExt.InsertBomTable3(template, 770, 240, fType, configuration, False, 2, True)
Dim path As String
path = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "\"))
Dim fpath As String
fpath = Format(path & "BOM\")
On Error Resume Next
MkDir (fpath)
On Error GoTo 0
Dim fName As String
fName = Format(fpath & "TEST.xls")
swBOMAnnotation.SaveAsExcel fName, False, False
Set swTableAnn = swBOMAnnotation
Set swAnn = swTableAnn.GetAnnotation
swAnn.Select3 False, Nothing
swModel.EditDelete
'Excel part
Set x1App = New Excel.Application
x1App.Visible = True
Set xlWB = x1App.Workbooks.Open(fName)
With Range("G3:G" & Cells(Rows.Count, "C").End(xlUp).Row)
.Formula = "=C3*F3"
End With
NextRow = Range("G" & Rows.Count).End(xlUp).Row + 1
Range("G" & NextRow).Formula = "=SUM(G2:G" & NextRow - 1 & ")"
End Sub
Not sure what's causing the behavior you're describing but here are a few thoughts that might point you in the right direction.
Objects in macros are persistent, meaning swModel (and other objects) will still exist after the macro is run. This is why you need to set it to 'Nothing' before using it again.
"Rows" is not defined anywhere so I'm surprised that code works at all. It must be late binding it to something... Rows is a method for an excel range but you're not using it that way. (range.Rows)
Try getting the row count explicitly in a double and using that instead. I suspect that will fix your issue.

Pull particular Excel cell value into Word document using Word VBA

I am new to VBA and macros.
I got the repeated task of copy data from Excel and paste it in a particular location in the word document.
For example, my excel sheet has the data like this:
Col1
Col2
ID_1
I'm_One
ID_2
I'm_Two
ID_3
I'm_Three
Now i'm looking for a Word macro
Get text in Word table with cell position 3
Find the same text in Excel Col1
Get the value of Col2 from Excel
Paste the value of Col2 in word table with cell position 10
Repeat the same process for another table in Word document
[Update]
I have tried with multiple code snippets by google search but unable to construct the working macro.
Sub pull_from_Excel2()
'ref: https://www.macworld.com/article/211753/excelwordvisualbasic.html
Dim Month As String
ID_Range = "A2:A6" 'Select this as range like "A2:A16"
Offset_to_fetch = 1 'Select this to fetch comments etc. value starts with
Set xlSheet = GetObject("D:\Excel.xlsx")
'Snippets:
'Debug.Print VarType(xlSheet.Worksheets("Sheet1").Range("A3:A5").Value)
'8204
Dim Cell As Range, rng As Range
Debug.Print VarType(xlSheet.Worksheets("Sheet1").Range(ID_Range).Value2)
Set rng = xlSheet.Worksheets(1).Range(ID_Range)
For Each Cell In rng
Debug.Print Cell.Text
Next Cell
End Sub
I used this url to construct my skeleton code: https://www.macworld.com/article/211753/excelwordvisualbasic.html
When i try to get the values from the range of cells in excel, i got the following error for the code.
Set rng = xlSheet.Worksheets(1).Range(ID_Range).Value2
The above line gives "Object required" error when running.
Set rng = xlSheet.Worksheets(1).Range(ID_Range)
The above line gives "Type Mismatch" error when running.
Notes: For this error, I tried to use for each loop as this is array but the error is showing before executing the for loop.
Kindly assist.
I recommend to use Option Explicit and declare all your varibales properly. This way it is less likely that you end up with unseen errors.
To activate it for all new codes that you add in the future, you can activate it directly in Excel and Word. This is a good practice and will protect you from doing it wrong by notifying you of not declared variables:
In the VBA editor go to Tools › Options › Require Variable Declaration.
This will add Option Explicit to new modules only. In existing modules Option Explicit needs to be added manually as first line.
Further I highly recommend to name your variables according what they contain because otherwise it gets very confusing. You named your variable xlSheet but you load a workbook into it and not a worksheet.
The next issue is that your code is in Word and if you declare rng As Range then this is of type Word.Range and not Excel.Range and those are diffetent types so that is why you get a "Type Mismatch" error.
To solve this you either go in Word VBA to Extras › Refereces … and set a reference to the Excel library so you can declare your variable Dim xlRng As Excel.Range or if you don't set a reference you declare it as Object or Variant like in below example:
' This code is in Word!
Option Explicit
Public Sub pull_from_Excel2()
'declare constants
Const ID_Range As Sting = "A2:A6" 'Select this as range like "A2:A16"
Const Offset_to_fetch As Long = 1 'Select this to fetch comments etc. value starts with
Dim xlWorkbook As Object
Set xlWorkbook = GetObject("D:\Excel.xlsx") 'This expects the Excel to be already open! If not open you need to use CreateObject("Excel.Application")
Dim xlRng As Object
Set xlRng = xlWorkbook.Worksheets(1).Range(ID_Range)
Dim xlCell As Object
For Each xlCell In xlRng
Debug.Print xlCell.Text
Next xlCell
End Sub
Note if your workbook Set xlWorkbook = GetObject("D:\Excel.xlsx") is not open in Excel you need to use CreateObject("Excel.Application") and open it.
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim xlWorkbook As Object
Set xlWorkbook = xlApp.Workbooks.Open(FileName:="D:\Excel.xlsx") 'will open the workbook
xlApp.Visible = True 'make it false to open Excel invisible in the background
'your code here …
'in the end close workbook and Excel (espaciall if you had it invisible!)
xlWorkbook.Close SaveChanges:=False
xlApp.Quit 'close Excel
Option Explicit
Sub UpdateTables()
Const XLSX = "D:\Excel.xlsx"
Dim xlApp, wb, ws
Dim rngSearch, rngFound
Dim iLastRow As Long, n As Integer
' open spreadsheet
'Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(XLSX, 1, 1)
Set ws = wb.Sheets(1)
iLastRow = ws.Cells(ws.Rows.Count, "A").End(-4162).Row 'xlUp
Set rngSearch = ws.Range("A2:A" & iLastRow)
' update tables
Dim doc As Document, tbl As Table, s As String
Set doc = ThisDocument
For Each tbl In doc.Tables
s = tbl.Cell(1, 1).Range.Text
s = Left(s, Len(s) - 2)
Set rngFound = rngSearch.Find(s, LookIn:=-4163, LookAt:=1) ' xlValues, xlWhole
If rngFound Is Nothing Then
MsgBox "'" & s & "' not found in table " & tbl.Title, vbExclamation
Else
tbl.Range.Cells(3).Range.Text = rngFound.Offset(0, 1)
n = n + 1
End If
Next
wb.Close False
xlApp.Quit
MsgBox n & " tables updated", vbInformation
End Sub

Convert Outlook Contact Group early binding Excel VBA to late binding

I am trying to insert a list of email addresses from Excel into a contact group in Outlook.
I found Excel VBA code online. It uses early binding. It is not an option to force the user to go into Tools-> References -> Outlook, when they open the file.
I need to transform the code from early to late binding.
Questions:
I understand that I need to change Outlook.Application to
CreateObject('Outlook.Application') and that I can access
olFolderContacts with the number 10 instead. See code below.
I can't figure out how to access the remaining items such as
CreateItem(olDistributionListItem).
Sub CreateContactGroupfromExcel()
Dim objContactsFolder As Outlook.Folder
Dim objContact As Outlook.ContactItem
Dim objContactGroup As Outlook.DistListItem
Dim objNameCell As Excel.Range
Dim objEmailCell As Excel.Range
Dim strName As String
Dim strEmail As String
Dim objTempMail As Outlook.MailItem
Dim objRecipients As Outlook.Recipients
Set objContactsFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Set objContactGroup = Outlook.Application.CreateItem(olDistributionListItem)
'You can change the contact group name
objContactGroup.DLName = "PlaceHolder_VBA"
i = 0
Do While Range("vba_email_outlook").Offset(i, 0).Value <> "":
strName = Range("vba_name_outlook").Offset(i, 0).Value
strEmail = Range("vba_email_outlook").Offset(i, 0).Value
Set objContact = objContactsFolder.Items.Find("[FullName] = '" & strName & "'")
'If there is no such a contact, create it.
If objContact Is Nothing Then
Set objContact = Outlook.Application.CreateItem(olContactItem)
With objContact
.FullName = strName
.Email1Address = strEmail
.Save
End With
End If
'Add the contacts to the new contact group
Set objTempMail = Outlook.CreateItem(olMailItem)
objTempMail.Recipients.Add (strName)
Set objRecipients = objTempMail.Recipients
objContactGroup.AddMembers objRecipients
i = i + 1
Loop
'Use "objContactGroup.Save" to straightly save it
objContactGroup.Display
objTempMail.Close olDiscard
End Sub
Declare object variables as generic Object
Dim objContactsFolder As Object
Determine number values of constants. With early binding, these values can be seen when hovering over constant or in VBA immediate window: ?olMailItem. Then reference number in place of constant or leave constants referenced as they are and declare them as constants with Const statements. Const olMailItem = 0
olFolderContacts = 10
olMailItem = 0
olDistributionListItem = 7
I am not an expert but this code allows you to add the reference when you run the VBA script, but it will mean that if it errors out the code quits running you will not be able to debug.
On Error Resume Next ''' If reference already exist this would cause an error
Application.VBE.ActiveVBProject.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office16\MSOUTL.OLB") ''' Might have to change file path
On Error GoTo 0

Automating Excel via PowerPoint - Locals window not exposing full Object model (ie Linksources)

background
I am running code (from PowerPoint) that:
Loops through every slide in a presentation.
Checks each shape to determine if it is a chart.
If it is a chart, activate the underlying Excel worksheet, and then change the links in this underlying file to a new source.
I note that the links to excel do not exist at the overall PPT level [viaInfo], they are deliberately linked to each chart so that the presentation can be edited without access to the source excel file.
The code works - broadly.
There is an ongoing error (code running fine now) that I think goes to network and memory stability (fails after around 15 charts), and I am looking to turn off screenupdating as per Turn off screenupdating for Powerpoint.
question
All the charts I access are linked to other workbooks. Yet when the Excel workbook is exposed to PowerPoint the Linksources are not shown in the Locals window even though the code processes each link (image below shows the link exists)
I flipped the automation to access the PowerPoint pack from Excel, same result. No Linksources.
Why would the full object model not also be available in the Locals window when automating PowerPoint with Excel?
Is this a localised glitch I have stumbled over, or is it a broader issue?
The picture below shows the code itearying over the links (ppl variable, but the xlWB variable has no Linksources).
code
Sub FastUpdate()
Dim sld As Slide
Dim shp As Shape
Dim pptchrt As Chart
Dim pptChrtData As ChartData
Dim xlWB As Excel.Workbook
Dim lngStart As Long
Dim strNew As String
Dim strMsg As String
Dim ppl As Variant
On Error GoTo cleanup
'set start position manually
'lngStart = 34
If lngStart = 0 Then lngStart = 1
'call custom function for user to pick file
'strNew = Getfile
strNew = "S:\Corporate Model\05 RSM submissions\05 May 2016\02 Checked RSMs\VFAT\Australia\Australia - Valuation and Financial Analysis template.xlsx"
For Each sld In ActivePresentation.Slides
If sld.SlideIndex >= lngStart Then
For Each shp In sld.Shapes
If shp.HasChart Then
Set pptchart = shp.Chart
Set pptChrtData = pptchart.ChartData
'open underlying excel file - doesn't just activate chart
pptChrtData.Activate
'
Set xlWB = pptChrtData.Workbook
'loop through all links
For Each ppl In xlWB.LinkSources
strMsg = strMsg & SlideNumber & " " & pptchart.Name & vbNewLine
xlWB.ChangeLink ppl, strNew
Next
xlWB.Close True
Set xlWB = Nothing
End If
Next shp
End If
Next sld
cleanup:
Set xlWB = Nothing
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical
If Len(strMsg) > 0 Then MsgBox strMsg, vbOKOnly, "Completed"
End Sub
Locals and Watch windows show properties of objects. List of properties of Workbook object can be found here.
LinkSources is a method with optional Type parameter.
If you want to debug LinkSources you can add it to Watch window:
or save return value to local variant variable to see it in Locals window.

Page numbers or Header Info for embedded Excel file in Word Doc?

I'm trying to search an MS Word doc for embedded Excel files and save them to a different location.
1) I want to record the page number and or section name (based on header style) the embedded file was located in the Word Doc. How can I extract this info?
2) Is there anyway to get the original filename of the embedded Excel file?
Here is the code I'm using to search for embedded files. Originally
Working off the code first presented here: Extract Embeded Excel Workseet Data
Sub TestMacro2()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Dim lNumShapes As Long
Dim lShapeCnt As Long
Dim xlApp As Object
Dim wrdActDoc As Document
Dim iRow As Integer
Dim iCol As Integer
Set wrdActDoc = ActiveDocument
For lShapeCnt = 1 To wrdActDoc.InlineShapes.Count
If wrdActDoc.InlineShapes(lShapeCnt).Type = wdInlineShapeEmbeddedOLEObject Then
If wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.ProgID = "Excel.Sheet.8" Then
wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.Edit
Set xlApp = GetObject(, "Excel.Application")
cpath = "location of interest"
xlApp.Workbooks(1).SaveAs cpath & " " & lShapeCnt
xlApp.Workbooks(1).Close
xlApp.Quit
Set xlApp = Nothing
End If
End If
Next lShapeCnt
End Sub
Note: Your code would be more efficient (and easier to read) if you assign an object that's re-used to a variable:
Dim ils as Word.InlineShape
Set ils = wrdActDoc.InlineShapes(lShapeCnt)
(1) The Range.Information method can return the page number. Something like:
Dim pageNumber as Long
pageNumber = ils.Range.Information(wdwdActiveEndPageNumber)
The other option is not as straight forward... I expect you really mean Heading style, not Header style. There is a built-in bookmark that will get the Heading preceding the current selection. That would be something like:
Dim secName as String
ils.Range.Select
secName = ActiveDocument.Bookmarks("\HeadingLevel").Range.Text
(2) If the file is not linked then your chances are slim. There's nothing VBA can get at directly, that's certain. Possibly, something might be stored in the WordOpenXML. You can check that by downloading the Open XML SDK Productivity Tool, opening such a document in it and inspecting that part of the Open XML. If it's in there then you can get at it in VBA using ils.Range.WordOpenXML to get the Open XML for the InlineShape, then parse that.

Resources