M
maperalia
The program I have below reads values from cells in excel and draw it in auto
into the template1.
I wonder if you can help me to add a condition if the coordinates values
(x,y) taken from excel are between:
1.- 500 to 4000 use the template1
2.- 500 to 5000 use the template2
3.- 500 to 6000 use the template3
4.- 500 to 7000 use the tempalte4
Can you please help me with this matter .
Thanks in advance.
Maperalia
'DRAW FROM EXCEL TO AUTOCAD
Option Explicit
Public oAcadApp As AcadApplication
Public oAcadDoc As AcadDocument
Public Sub DrawInAutoCADFromExcel1()
Dim i As Integer
Dim lowerLoop As Integer: lowerLoop = 6
Dim upperLoop As Integer: upperLoop = 100
Dim minusValue As Integer
Dim pointsColl As New Collection
Dim acadApp As AcadApplication
Dim pline As AcadLWPolyline
Dim text As AcadText
Dim textValue As String
Dim textLocation(0 To 2) As Double
Dim textHeight As Double: textHeight = 0.03
Dim LWPoints() As Double
'**********************************************************************
'Insert Text
Dim oTextEnt As AcadText
Dim dInsertPoint(0 To 2) As Double
Dim sTextString As String
Dim dTextHeight As Double
Dim lRowCount As Long
dTextHeight = 0.06
AcadConnect 'Subroutine provided previously
Set oAcadDoc = oAcadApp.ActiveDocument 'Connect to the open and active Drawing
For lRowCount = 1 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
'Type coordinates location in the columns A & B for the text written in
column D
dInsertPoint(0) = CDbl(Val(ThisWorkbook.ActiveSheet.Cells(lRowCount,
1).Value))
'dInsertPoint(0) = dInsertPoint(0) * 1000
dInsertPoint(1) = CDbl(Val(ThisWorkbook.ActiveSheet.Cells(lRowCount,
2).Value))
dInsertPoint(2) = 0#
'Type the text value in the column D
sTextString = ThisWorkbook.ActiveSheet.Cells(lRowCount, 4).Value
Set oTextEnt = oAcadDoc.ModelSpace.AddText(sTextString, dInsertPoint,
dTextHeight)
oTextEnt.Layer = "0"
oTextEnt.Alignment = acAlignmentMiddleLeft
oTextEnt.TextAlignmentPoint = dInsertPoint
oTextEnt.Color = acGreen
oTextEnt.StyleName = "title"
oTextEnt.Update
Next lRowCount
'***********************************************************************
'Read Coordinates from Excel cells and Draw them in AutoCAD
On Error GoTo stub_Error
For i = lowerLoop To upperLoop
If Not Cells(i, 7) = "" And _
Not Cells(i, 8) = "" Then
pointsColl.Add Cells(i, 7)
pointsColl.Add Cells(i, 8)
Else: Exit For
End If
Next i
ReDim LWPoints(pointsColl.Count - 1) As Double
For i = 0 To UBound(LWPoints)
LWPoints(i) = pointsColl(i + 1)
Next i
If UBound(LWPoints) > 0 Then
With oAcadDoc.ModelSpace
'--------------------------------------------
'Draw the Polyline
Set pline = .AddLightWeightPolyline(LWPoints)
oAcadDoc.Regen acActiveViewport
pline.Color = acYellow
pline.Linetype = "Dot"
pline.LinetypeScale = 0.18
pline.Update
If LWPoints(0) = LWPoints(UBound(LWPoints) - 1) And _
LWPoints(1) = LWPoints(UBound(LWPoints)) Then
minusValue = 2
Else: minusValue = 0
End If
'--------------------------------------------
'Add Coordinates to the drawing
For i = 0 To (UBound(LWPoints) - minusValue) Step 2
textValue = LWPoints(i) & "," & LWPoints((i + 1))
textLocation(0) = LWPoints(i)
textLocation(1) = LWPoints((i + 1))
textLocation(2) = 0
Set text = .AddText(textValue, textLocation, textHeight)
text.Color = acYellow
Next i
'***********************************************************************
oAcadDoc.Regen acActiveViewport
End With
Else: Resume stub_Exit
End If
stub_Exit:
On Error GoTo 0
Set pointsColl = Nothing
Set acadApp = Nothing
Exit Sub
stub_Error:
Err.Clear
Resume stub_Exit
End Sub
'Connect to AutoCAD
Public Sub AcadConnect()
If Err Then Err.Clear
On Error Resume Next
Set oAcadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set oAcadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox "Could not connect to AutoCad"
Exit Sub
End If
End If
oAcadApp.Visible = True
oAcadApp.WindowState = acMax
oAcadApp.ZoomExtents
End Sub
'Open Drawing
Public Sub AcadOpenDoc(sFilename As String)
Set oAcadDoc = oAcadApp.Documents.Open(sFilename)
End Sub
'Open an existen Template
Public Sub Main()
Dim sFilename As String
AcadConnect
sFilename = "S:\Templates\Template1.dwt"
AcadOpenDoc sFilename
DrawInAutoCADFromExcel1
End Sub
into the template1.
I wonder if you can help me to add a condition if the coordinates values
(x,y) taken from excel are between:
1.- 500 to 4000 use the template1
2.- 500 to 5000 use the template2
3.- 500 to 6000 use the template3
4.- 500 to 7000 use the tempalte4
Can you please help me with this matter .
Thanks in advance.
Maperalia
'DRAW FROM EXCEL TO AUTOCAD
Option Explicit
Public oAcadApp As AcadApplication
Public oAcadDoc As AcadDocument
Public Sub DrawInAutoCADFromExcel1()
Dim i As Integer
Dim lowerLoop As Integer: lowerLoop = 6
Dim upperLoop As Integer: upperLoop = 100
Dim minusValue As Integer
Dim pointsColl As New Collection
Dim acadApp As AcadApplication
Dim pline As AcadLWPolyline
Dim text As AcadText
Dim textValue As String
Dim textLocation(0 To 2) As Double
Dim textHeight As Double: textHeight = 0.03
Dim LWPoints() As Double
'**********************************************************************
'Insert Text
Dim oTextEnt As AcadText
Dim dInsertPoint(0 To 2) As Double
Dim sTextString As String
Dim dTextHeight As Double
Dim lRowCount As Long
dTextHeight = 0.06
AcadConnect 'Subroutine provided previously
Set oAcadDoc = oAcadApp.ActiveDocument 'Connect to the open and active Drawing
For lRowCount = 1 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
'Type coordinates location in the columns A & B for the text written in
column D
dInsertPoint(0) = CDbl(Val(ThisWorkbook.ActiveSheet.Cells(lRowCount,
1).Value))
'dInsertPoint(0) = dInsertPoint(0) * 1000
dInsertPoint(1) = CDbl(Val(ThisWorkbook.ActiveSheet.Cells(lRowCount,
2).Value))
dInsertPoint(2) = 0#
'Type the text value in the column D
sTextString = ThisWorkbook.ActiveSheet.Cells(lRowCount, 4).Value
Set oTextEnt = oAcadDoc.ModelSpace.AddText(sTextString, dInsertPoint,
dTextHeight)
oTextEnt.Layer = "0"
oTextEnt.Alignment = acAlignmentMiddleLeft
oTextEnt.TextAlignmentPoint = dInsertPoint
oTextEnt.Color = acGreen
oTextEnt.StyleName = "title"
oTextEnt.Update
Next lRowCount
'***********************************************************************
'Read Coordinates from Excel cells and Draw them in AutoCAD
On Error GoTo stub_Error
For i = lowerLoop To upperLoop
If Not Cells(i, 7) = "" And _
Not Cells(i, 8) = "" Then
pointsColl.Add Cells(i, 7)
pointsColl.Add Cells(i, 8)
Else: Exit For
End If
Next i
ReDim LWPoints(pointsColl.Count - 1) As Double
For i = 0 To UBound(LWPoints)
LWPoints(i) = pointsColl(i + 1)
Next i
If UBound(LWPoints) > 0 Then
With oAcadDoc.ModelSpace
'--------------------------------------------
'Draw the Polyline
Set pline = .AddLightWeightPolyline(LWPoints)
oAcadDoc.Regen acActiveViewport
pline.Color = acYellow
pline.Linetype = "Dot"
pline.LinetypeScale = 0.18
pline.Update
If LWPoints(0) = LWPoints(UBound(LWPoints) - 1) And _
LWPoints(1) = LWPoints(UBound(LWPoints)) Then
minusValue = 2
Else: minusValue = 0
End If
'--------------------------------------------
'Add Coordinates to the drawing
For i = 0 To (UBound(LWPoints) - minusValue) Step 2
textValue = LWPoints(i) & "," & LWPoints((i + 1))
textLocation(0) = LWPoints(i)
textLocation(1) = LWPoints((i + 1))
textLocation(2) = 0
Set text = .AddText(textValue, textLocation, textHeight)
text.Color = acYellow
Next i
'***********************************************************************
oAcadDoc.Regen acActiveViewport
End With
Else: Resume stub_Exit
End If
stub_Exit:
On Error GoTo 0
Set pointsColl = Nothing
Set acadApp = Nothing
Exit Sub
stub_Error:
Err.Clear
Resume stub_Exit
End Sub
'Connect to AutoCAD
Public Sub AcadConnect()
If Err Then Err.Clear
On Error Resume Next
Set oAcadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set oAcadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox "Could not connect to AutoCad"
Exit Sub
End If
End If
oAcadApp.Visible = True
oAcadApp.WindowState = acMax
oAcadApp.ZoomExtents
End Sub
'Open Drawing
Public Sub AcadOpenDoc(sFilename As String)
Set oAcadDoc = oAcadApp.Documents.Open(sFilename)
End Sub
'Open an existen Template
Public Sub Main()
Dim sFilename As String
AcadConnect
sFilename = "S:\Templates\Template1.dwt"
AcadOpenDoc sFilename
DrawInAutoCADFromExcel1
End Sub