Add Condition if to use different template file

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top