CAD Software Forum

Hello,

I have written the code below which works perfectly drawing four shed elevations, however, I want to also include dimensions. How would I go about this please?


Option Explicit
Sub DrawBorder()
Dim icadApp As Object
Dim icadDoc As Object

Dim icadLibrary As Object
Dim myPoints As Object


Dim Shed As Object

'****** Launch icad application****
On Error Resume Next
Set icadApp = GetObject(, "icad.application")

On Error GoTo 0

If icadApp Is Nothing Then
Set icadApp = CreateObject("icad.application")
icadApp.Visible = True
End If

Set icadLibrary = icadApp.Library

Set myPoints = icadLibrary.CreatePoints

myPoints.Add ActiveSheet.Range("E39"), ActiveSheet.Range("F39")
myPoints.Add ActiveSheet.Range("E40"), ActiveSheet.Range("F40")
myPoints.Add ActiveSheet.Range("E41"), ActiveSheet.Range("F41")
myPoints.Add ActiveSheet.Range("E42"), ActiveSheet.Range("F42")
myPoints.Add ActiveSheet.Range("E39"), ActiveSheet.Range("F39")

On Error Resume Next
Set icadDoc = icadApp.activedocument

On Error GoTo 0

If icadDoc Is Nothing Then
Set icadDoc = icadApp.documents.Add

End If

Set Shed = icadDoc.ModelSpace.AddLightWeightPolyline(myPoints)

icadApp.zoomextents

Set Shed = Nothing
Set icadApp = Nothing
Set icadDoc = Nothing

End Sub

You can start with AddDimAligned:

Thank you.

Hello,

I have tried the code you wrote and it doesn't appear to work. Have I done something wrong? I have attached the code again here.


Option Explicit
Sub DrawBorder()
Dim icadApp As Object
Dim icadDoc As Object

Dim icadLibrary As Object
Dim myPoints As Object


Dim Shed As Object

'****** Launch icad application****
On Error Resume Next
Set icadApp = GetObject(, "icad.application")

On Error GoTo 0

If icadApp Is Nothing Then
Set icadApp = CreateObject("icad.application")
icadApp.Visible = True
End If

Set icadLibrary = icadApp.Library

Set myPoints = icadLibrary.CreatePoints

myPoints.Add ActiveSheet.Range("E39"), ActiveSheet.Range("F39")
myPoints.Add ActiveSheet.Range("E40"), ActiveSheet.Range("F40")
myPoints.Add ActiveSheet.Range("E41"), ActiveSheet.Range("F41")
myPoints.Add ActiveSheet.Range("E42"), ActiveSheet.Range("F42")
myPoints.Add ActiveSheet.Range("E39"), ActiveSheet.Range("F39")

On Error Resume Next
Set icadDoc = icadApp.activedocument

On Error GoTo 0

If icadDoc Is Nothing Then
Set icadDoc = icadApp.documents.Add
End If

Set Shed = icadDoc.ModelSpace.AddLightWeightPolyline(myPoints)

' add dimAligned
Dim pt1 As Object
Dim pt2 As Object
Dim txtPt As Object
Dim aliDim As Object

Set pt1 = icadLibrary.CreatePoint(ActiveSheet.Range("E39"), ActiveSheet.Range("F39"))
Set pt2 = icadLibrary.CreatePoint(ActiveSheet.Range("E40"), ActiveSheet.Range("F40"))
Set txtPt = icadLibrary.CreatePoint(ActiveSheet.Range("E41"), ActiveSheet.Range("F41"))

Set aliDim = icadDoc.ModelSpace.AddDimAligned(pt1, pt2, txtPt)


icadApp.zoomextents

Set Shed = Nothing
Set icadApp = Nothing
Set icadDoc = Nothing

End Sub

Hi,
Your code works as-is, please check your data file, maybe the value of cells in the excel file is invalid or empty.

Try to use this:
https://www.dropbox.com/s/caxtjfzgng65l ... .xlsm?dl=0

I can see how yours worked but mine did not. Here is what happened to mine (bear in mind I am not a proficient user in Intellicad).