Draw Polyline To AutoCAD from Excel Coordinates - Visual Basic , VB.NET

	Find Code:
Home : Code : Forums : Submit : Mailing List : About : Contact

All

VB.NET

ASP.NET

C#

Snippets

Popular

Forums

Articles

Tips

Links

Books

Contest

Draw Polyline To AutoCAD from Excel Coordinates
Author: Sajid Javid
Submitted: 11/15/2014
Version: VB6
Compatibility: VB6
Category: Graphics
Views: 6436
This program uses coordinates of Polylines from Excel and Draw Polyline to AutoCAD,This program can draw many polyline at a time.There should be one empty cell between coordinates of individual polylines.
Declarations:
Private Sub CommandButton2_Click() Call drawPolyLines End Sub
Code:
Sub drawPolyLines() Set A2k = GetObject(, "AutoCAD.Application") Set A2Kdwg = A2k.ActiveDocument Dim totalRows As Double Dim val1, val2, sname As String Dim i, sp, ep As Integer Dim r, c As Integer r = 2:c = 1 totalRows = 1000 sname = "Sheet1" Worksheets(sname).Cells(2, 436) = r '-----------'' Start: '-----------'' r = Worksheets(sname).Cells(2, 436) ''''Search Number of rows containing data '''' For r = Worksheets(sname).Cells(2, 436) To totalRows If Worksheets(sname).Cells(r, c) = "" And Worksheets(sname).Cells(r + 1, c) = "" Then totalRows = r + 2 Exit For End If Next '' Get Starting and Ending of Data '' For r = Worksheets(sname).Cells(2, 436) To totalRows If Worksheets(sname).Cells(r, c) = "" Then sp = Worksheets(sname).Cells(2, 436) ep = r - 1 Exit For End If Next ''Store Points into Array to Display into AutoCad '' Dim w, oglepo, rows, cols As Integer w = 0 oglepo = (ep - sp) * 2 + 1 ReDim Polylinepoints(0 To oglepo) As Double For rows = sp To ep For cols = c To c + 1 Polylinepoints(w) = Round(Worksheets(sname).Cells(rows, cols), 3) w = w + 1 Next Next ''Display Polyline ''' Set pline1 = A2Kdwg.ModelSpace.AddLightWeightPolyline(Polylinepoints) '''Set START point for Next Portion of Data ''' Worksheets(sname).Cells(2, 436) = ep + 2 ''' When two consecutive Empty cells occure then Stop your Execution '' If Worksheets(sname).Cells(ep + 1, c) = "" And Worksheets(sname).Cells(ep + 2, c) = "" Then Worksheets(sname).Cells(2, 436) = 2 Exit Sub Else ''' If two consecutive Empty cells will not occure then Continue your Execution '' '-----------'' GoSub Start '-----------'' End If End Sub