List Koordinat Dari Excel Ke AutoCAD ( Cross Section )

Code dalam visual basic application, ada dua bagian yaitu Prosedur Pertama dan Prosedur / Function Pendukung.

Prosedur Pertama adalah nama Macro yang akan dijalankan melalui menu MS Excel, sedangkan Prosedur / Function Pendukung adalah Prosedur yang tidak ditampilkan dalam menu Macro di MS Excel.

Prosedur Pertama :

Option Explicit Dim appCAD As AcadApplication Dim acadDoc As AcadDocument Dim acadMspace As AcadModelSpace   Sub PlotGarisCrossSection() Dim LstKoordExisting() As Double, LstKoordDesign() As Double Dim BasePoint As Variant, OK As Boolean OK = True ‘Membaca list koordinat existing dan design If Not BacaListKoordinat(LstKoordExisting, “Pilih List Koordinat Existing “) Then Exit Sub If Not BacaListKoordinat(LstKoordDesign, “Pilih List Koordinat Design “) Then Exit Sub ‘Jika bisa connect autocad, ganti window ke autocad If ConnectAutoCAD = Not OK Then Exit Sub GantiWindowKeCAD BasePoint = GetPointInCAD(“Base Point”) ‘base point untuk menggambar cross section ‘Buat Layer dengan nama Existing SetLayerAktif “Existing” ‘Plot Garis (Polyline) Existing di layer Existing PlotGaris2D LstKoordExisting, CDbl(BasePoint(0)), CDbl(BasePoint(1))  ‘Buat Layer dengan nama Design SetLayerAktif “Design” ‘Plot Garis (Polyline) Design di layer Design PlotGaris2D LstKoordDesign, CDbl(BasePoint(0)), CDbl(BasePoint(1))  ‘plot label dengan jarak baris exiting =1, design =1, tinggi huruf=0.1 x_section_label CDbl(BasePoint(0)), CDbl(BasePoint(1)), 1, 1, 0.1 End Sub

Prosedur Kedua :

‘==private sub dan function==== ‘================= ’1. Objects Excel ‘================= Private Function BacaListKoordinat(rtnListXY() As Double, ByVal strTitle As String) As Boolean Dim aRange As Range, cr As Range   On Error GoTo Err_Trap: Set aRange = Application.InputBox(Prompt:=strTitle, Type:=8) If aRange.Columns.Count < 2 And aRange.Columns.Count > 2 Then MsgBox “List Koordinat Harus 2 (Dua) Kolom. Kolom Pertama X, Kolom Kedua Y “ GoTo Err_Trap End If  ‘membaca koordinat x dan y, hasilnya disimpan di rtnListXY() Dim i As Integer i = -1 For Each cr In aRange.Columns(1).Cells i = i + 2 ReDim Preserve rtnListXY(i) rtnListXY(i – 1) = cr rtnListXY(i) = cr.Offset(, 1) Next BacaListKoordinat = True Exit Function Err_Trap: Err.Clear BacaListKoordinat = False End Function ‘================== ’2. Objects AutoCAD ‘================== Private Function ConnectAutoCAD() As Boolean On Error Resume Next ConnectAutoCAD = True Set appCAD = GetObject(, “AutoCAD.Application”) Set acadDoc = appCAD.ActiveDocument Set acadMspace = acadDoc.ModelSpace If Err.Number Then ConnectAutoCAD = False Exit Function End If End Function Private Sub GantiWindowKeCAD() AppActivate appCAD.Caption End Sub  Private Function GetPointInCAD(strPrompt As String) As Variant GetPointInCAD = acadDoc.Utility.GetPoint(, strPrompt) End Function  Private Sub SetLayerAktif(strNamaLayer As String) Dim aLayer As AcadLayer On Error Resume Next Set aLayer = acadDoc.Layers(strNamaLayer) If Err.Number Then Err.Clear Set aLayer = acadDoc.Layers.Add(strNamaLayer) End If acadDoc.ActiveLayer = aLayer End Sub  Private Sub PlotGaris2D(ListTitik() As Double, Optional Xorigin As Double = 0, Optional Yorigin As Double = 0) Dim i As Integer For i = LBound(ListTitik) To UBound(ListTitik) Step 2 ListTitik(i) = ListTitik(i) + Xorigin ListTitik(i + 1) = ListTitik(i + 1) + Yorigin Next i acadMspace.AddLightWeightPolyline ListTitik End Sub Private Function GetOneEntity(ByVal strPrompt As String) As AcadEntity Dim objEntity As AcadObject, PickedPoint(0 To 2) As Double AppActivate appCAD.Caption acadDoc.Utility.GetEntity objEntity, PickedPoint, strPrompt Set GetOneEntity = objEntity End Function Private Sub x_section_label(Xorigin As Double, Yorigin As Double, _ TinggiBaris1 As Double, TinggiBaris2 As Double, TinggiHuruf As Double)  Dim anEntity As AcadEntity, polyExisting As AcadLWPolyline, polyDesign As AcadLWPolyline Dim aText As AcadText  Dim i As Integer, stLine(0 To 2) As Double, edLine(0 To 2) As Double, Xmin As Double, Xmax As Double Dim Existing_XY() As Double, Design_XY() As Double, Ymin As Double Dim pntText(0 To 2) As Double, textRotation As Double  textRotation = Application.Radians(90) Ymin = Yorigin – TinggiBaris1 – TinggiBaris2 Set anEntity = GetOneEntity(“Pilih Polyline Existing”) If anEntity.ObjectName = “AcDbPolyline” Then Set polyExisting = anEntity Existing_XY = polyExisting.Coordinates Xmin = Existing_XY(0) ‘gambar garis vertikal SetLayerAktif “Grid Existing” For i = LBound(Existing_XY) To UBound(Existing_XY) Step 2 stLine(0) = Existing_XY(i) stLine(1) = Existing_XY(i + 1) Xmax = stLine(0) edLine(0) = stLine(0) edLine(1) = Ymin acadMspace.AddLine stLine, edLine  ‘menulis text elevasi dan jarak pntText(1) = Yorigin – TinggiBaris1 ‘Label jarak pntText(0) = stLine(0) – TinggiHuruf Set aText = acadMspace.AddText(Format(stLine(0) – Xorigin, “0.00″), pntText, TinggiHuruf) aText.Rotate pntText, textRotation ‘Label elevasi pntText(0) = stLine(0) + TinggiHuruf Set aText = acadMspace.AddText(Format(stLine(1) – Yorigin, “0.00″), pntText, TinggiHuruf) aText.Rotate pntText, textRotation  Next i End If  ‘Gambar Garis Base Line SetLayerAktif “Datum” stLine(0) = Xmin: edLine(0) = Xmax stLine(1) = Yorigin: edLine(1) = stLine(1) acadMspace.AddLine stLine, edLine  stLine(0) = Xmin: edLine(0) = Xmax stLine(1) = Yorigin – TinggiBaris1: edLine(1) = stLine(1) acadMspace.AddLine stLine, edLine  stLine(0) = Xmin: edLine(0) = Xmax stLine(1) = Yorigin – TinggiBaris1 – TinggiBaris2: edLine(1) = stLine(1) acadMspace.AddLine stLine, edLine  Set anEntity = GetOneEntity(“Pilih Polyline Design”) If anEntity.ObjectName = “AcDbPolyline” Then Set polyDesign = anEntity Design_XY = polyDesign.Coordinates  ‘menggambar garis vertikal di layer grid design SetLayerAktif “Grid Design” For i = LBound(Design_XY) To UBound(Design_XY) Step 2 stLine(0) = Design_XY(i) stLine(1) = Design_XY(i + 1)  edLine(0) = stLine(0) edLine(1) = Ymin acadMspace.AddLine stLine, edLine  ‘menulis text elevasi dan jarak pntText(1) = Yorigin – TinggiBaris1 – TinggiBaris2  ‘Label jarak pntText(0) = stLine(0) – TinggiHuruf Set aText = acadMspace.AddText(Format(stLine(0) – Xorigin, “0.00″), pntText, TinggiHuruf) aText.Rotate pntText, textRotation  ‘Label elevasi pntText(0) = stLine(0) + TinggiHuruf Set aText = acadMspace.AddText(Format(stLine(1) – Yorigin, “0.00″), pntText, TinggiHuruf) aText.Rotate pntText, textRotation  Next i End If End Sub  ‘===end private sub dan function”

Download Contoh Cross section "Here"
Extract Contoh Cross dan Buka MS Excel yang ada di dalamnya
Pada Program Excel tekan Alt + F11 untuk membuka Microsoft Visual Basic Editor
Di Microsoft Visual Basic Editor, tekan Ctr + M kemudian pilih file Script Cross section
Setting library ke AutoCAD anda.
Keluar dari Microsoft Visual Basic Editor dengan menekan Alt + Q
Pada file Master, tekan Alt + F8 kemudian double click macro Plot Garis Cross Section

Block koordinat ( Offset, Elevasi ) Existing yaitu $Q$7:$R$57, kemudian click OK. Akan muncul kotak dialog seperti di atas lagi, untuk memilih ( Block ) koordinat design yaitu $S$7:$T$11. Akhiri dengan click OK
Pindah ke program AutoCAD, jika program tidak pindah ke AutoCAD secara otomatis.
Di Autocad akan muncul prompt

          Command: Base Point → Click sembarang lokasi di AutoCAD
          Command: Pilih Polyline Existing → Pilih Polyline Existing di AutoCAD
          Command: Pilih Polyline Design → Pilih Polyline Design di autoCAD