LinkBack URL
About LinkBacksThe variables for the select statement is the cell "8". However, I can not
make it work in ythe program showm below.
Could you please help to find the way to may work the variable for this
select case statement?
Thanks in advance.
Maperalia
'DRAW FROM EXCEL TO AUTOCAD
Option Explicit
Public oAcadApp As AcadApplication
Public oAcadDoc As AcadDocument
'Open an existen Template
Public Sub Main()
Dim sFilename As String
AcadConnect
'Sub rountine entered with lUpperLimit set to 4000, 5000, 6000, or 7000
Select Case (pointsColl.Add Cells(8))
Case 500 To 4000
sFilename = "S:\Templates\Template1.dwt"
Case 500 To 5000
sFilename = "S:\Templates\Template2.dwt"
Case 500 To 6000
sFilename = "S:\Templates\Template3.dwt"
Case 500 To 7000
sFilename = "S:\Templates\Template4.dwt"
Case Else
MsgBox "Error, using default template", vbExclamation + vbOKOnly,
"Limits Error"
sFilename = "S:\Templates\Template1.dwt"
End Select
AcadOpenDoc sFilename
DrawInAutoCADFromExcel1
End Sub
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
Dim lUpperLimit As Long
'Sub rountine entered with lUpperLimit set to 4000, 5000, 6000, or 7000
Select Case (lUpperLimit)
Case 500 To 4000
sFilename = "S:\Templates\Template1.dwt"
Case 500 To 5000
sFilename = "S:\Templates\Template2.dwt"
Case 500 To 6000
sFilename = "S:\Templates\Template3.dwt"
Case 500 To 7000
sFilename = "S:\Templates\Template4.dwt"
Case Else
MsgBox "Error, using default template", vbExclamation + vbOKOnly,
"Limits Error"
sFilename = "S:\Templates\Template1.dwt"
End Select
AcadOpenDoc sFilename
DrawInAutoCADFromExcel1
End Sub
Register To Reply
Bookmarks