Tag: Visual Basic Application

[DOC-VBA-02]: Aplikasi Fungsi Terbilang di Microsoft Word Rev.1

Referensi :
[DOC-VBA-01]: Aplikasi Fungsi Terbilang Di Microsoft Word
Platform : Microsot Word
Lokasi File : Download

Pada tulisan   [DOC-VBA-01]: Aplikasi Fungsi Terbilang Di Microsoft Word code diambil dari https://support.microsoft.com/en-us/kb/213360 dengan sedikit modifikasi.

Sedangkan pada tulisan ini adalah versi Visual Basic Application (VBA) dari [XLS-PMG-08]: Fungsi Terbilang Di Excel Tanpa Macro Versi Mega Formula Rev.03 berupa macro sehingga bisa digunakan di Microsoft Word.

Ada dua Procedure / Macro dan dua Fungsi dalam VBA tersebut :

Procedure / Macro Fungsi yang dijalankan Keterangan
Terbilang fTerbilang untuk mengubah angka ke bahasa indonesia
Spell2Number fSpellNumber untuk mengubah angka ke bahasa inggris

1. Procedure / Macro Terbilang

Sub Terbilang()
    Selection.Text = fTerbilang(Selection.Text)
End Sub

Function fTerbilang(dAngka As Variant)

‘Keterangan : Fungsi ini akan merubah angka menjadi huruf atau terbilang
‘maksimal angka adalah 999999999999.99
‘jika melebihi angka tersebut tidak akan diproses.
‘dibuat oleh: zainul_ulum@cbn.net.id
‘Rev.0: 15 Oktober 2017
    Const dMAX_NUMBER As Double = 999999999999.99
    Const sFormat As String = "000000000000.00"
    Dim arrHuruf As Variant
   
    arrHuruf = Array("", "satu", "dua", "tiga", "empat", "lima", "enam", "tujuh", _
        "delapan", "sembilan", "sepuluh", "sebelas", "dua belas", "tiga belas", _
        "empat belas", "lima belas", "enam belas", "tujuh belas", "delapan belas", _
        "sembilan belas", "dua puluh", "tiga puluh", "empat puluh", "lima puluh", _
        "enam puluh", "tujuh puluh", "delapan puluh", "sembilan puluh")
   
    ‘Dim dAngka As Double
    ‘dAngka = 134912931#
   
    If dAngka > dMAX_NUMBER Then
        fTerbilang = "N/A"
        Exit Function
    End If

   
    Dim sAngka As String
   
    ‘merubah angka menjadi string
    sAngka = Format(dAngka, sFormat)
   
    Dim iRatusan As Integer, iPuluhan As Integer
    Dim idxHuruf As Integer, j As Integer, k As Integer
    Dim sTerbilang As String, sTerbilangPenuh As String
    Dim sRatusan As String, sPuluhan As String
   
    j = 1
    sTerbilangPenuh = ""
    For k = 0 To 3
    ‘angka ratusan
    iRatusan = CInt(Mid(sAngka, j, 1))
   
    ‘membaca angka Ratusan
    sRatusan = IIf(iRatusan = 0, "", arrHuruf(iRatusan) & " ratus")
   
    ‘mengganti "satu ratus" menjadi "seratus"
    sRatusan = Replace(sRatusan, "satu ratus", "seratus")
   
    ‘angka Puluhan
    iPuluhan = CInt(Mid(sAngka, j + 1, 2))
    If iPuluhan <= 19 Then
        sPuluhan = arrHuruf(iPuluhan)
    Else
        sPuluhan = arrHuruf(18 + CInt(Left(iPuluhan, 1)))
        sPuluhan = sPuluhan & " " & arrHuruf(CInt(Right(iPuluhan, 1)))
    End If
    sTerbilang = sRatusan & " " & sPuluhan
   
    ‘menambahkan kata milyar
    Select Case k
        Case 0
            sTerbilang = sTerbilang & IIf(dAngka / 1000000000# > 1, " milyar", "")
        Case 1
            sTerbilang = sTerbilang & IIf(dAngka / 1000000# > 1, " juta", "")
        Case 2
            sTerbilang = sTerbilang & IIf(dAngka / 1000# > 1, " ribu", "")
            ‘mengganti "satu ribu" menjadi "seribu"
            sTerbilang = Replace(sTerbilang, "satu ribu", "seribu")
        Case Else
            sTerbilang = sTerbilang
    End Select
    sTerbilangPenuh = sTerbilangPenuh & " " & sTerbilang
    j = j + 3
    Next k
   
    ‘membaca sen
    Dim iSen As Integer, sSen As String
    iSen = CInt(Right(sAngka, 2))
   
    If iSen <= 19 Then
            sSen = arrHuruf(iSen)
        Else
            sSen = arrHuruf(18 + CInt(Left(iSen, 1)))
            sSen = sSen & " " & arrHuruf(CInt(Right(iSen, 1)))
    End If
   
    fTerbilang = Trim(sTerbilangPenuh & IIf(iSen = 0, "", " dan " & sSen & " sen"))

End Function

2. Procedure / Macro Spell2Number

Sub Spell2Number()
    Selection.Text = fSpellNumber(Selection.Text)
End Sub

Function fSpellNumber(dAngka As Variant)
   
‘Descrition : This function converts number into text or spells number into text
‘maximum number can be converted is 999999999999.99
‘Function return "N/A" if the number exceeds of the allowable maximum number
‘coded by: zainul_ulum@cbn.net.id
‘Rev.0: 15 Oktober 2017
   
   
    Const sFormat As String = "000000000000.00"
    Const dMAX_NUMBER As Double = 999999999999.99
    Dim arrHuruf As Variant
   
    arrHuruf = Array("", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", _
    "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", _
    "eighteen", "nineteen", "twenty-", "thirty-", "forty-", "fifty-", "sixty-", "seventy-", "eighty-", "ninety-")
   
    ‘Dim dAngka As Double
    ‘dAngka = 134912931#
    If dAngka > dMAX_NUMBER Then
        fSpellNumber = "N/A"
        Exit Function
    End If
   
    Dim sAngka As String
   
    ‘merubah angka menjadi string
    sAngka = Format(dAngka, sFormat)
   
    Dim iRatusan As Integer, iPuluhan As Integer
    Dim idxHuruf As Integer, j As Integer, k As Integer
    Dim sTerbilang As String, sTerbilangPenuh As String
    Dim sRatusan As String, sPuluhan As String
   
    j = 1
    sTerbilangPenuh = ""
    For k = 0 To 3
    ‘angka ratusan
    iRatusan = CInt(Mid(sAngka, j, 1))
   
    ‘membaca angka Ratusan
    sRatusan = IIf(iRatusan = 0, "", arrHuruf(iRatusan) & " hundred")
   
    ‘mengganti "satu ratus" menjadi "seratus"
    ‘sRatusan = Replace(sRatusan, "satu ratus", "seratus")
   
    ‘angka Puluhan
    iPuluhan = CInt(Mid(sAngka, j + 1, 2))
    If iPuluhan <= 19 Then
        sPuluhan = arrHuruf(iPuluhan)
    Else
        sPuluhan = arrHuruf(18 + CInt(Left(iPuluhan, 1)))
        sPuluhan = sPuluhan & arrHuruf(CInt(Right(iPuluhan, 1)))
    End If
    sTerbilang = sRatusan & " " & sPuluhan
   
    ‘menambahkan kata milyar
    Select Case k
        Case 0
            sTerbilang = sTerbilang & IIf(dAngka / 1000000000# > 1, " billion", "")
        Case 1
            sTerbilang = sTerbilang & IIf(dAngka / 1000000# > 1, " million", "")
        Case 2
            sTerbilang = sTerbilang & IIf(dAngka / 1000# > 1, " thousand", "")
            ‘mengganti "satu ribu" menjadi "seribu"
            ‘sTerbilang = Replace(sTerbilang, "satu ribu", "seribu")
        Case Else
            sTerbilang = sTerbilang
    End Select
    sTerbilangPenuh = sTerbilangPenuh & " " & sTerbilang
    j = j + 3
    Next k
   
    ‘membaca sen
    Dim iSen As Integer, sSen As String
    iSen = CInt(Right(sAngka, 2))
   
    If iSen <= 19 Then
            sSen = arrHuruf(iSen)
        Else
            sSen = arrHuruf(18 + CInt(Left(iSen, 1)))
            sSen = sSen & arrHuruf(CInt(Right(iSen, 1)))
    End If
   
    fSpellNumber = Trim(sTerbilangPenuh & IIf(iSen = 0, "", " and " & sSen & " cent" & IIf(iSen > 1, "s", "")))

End Function

Cara penggunaan silakan baca di tulisan sebelumnya [DOC-VBA-01]: Aplikasi Fungsi Terbilang Di Microsoft Word.

==semoga bermanfaat==

[XLS-SVY-006]:Menghitung Luas Cross Section dengan Visual Basic Application Excel (Macro)

Referensi : https://cadex.wordpress.com/2010/12/05/xls-svy-004membuat-grafik-dan-menghitung-luas-cross-section-dengan-excel-bagian-2/
Platform : Excel
File :

Pada post [XLS-SVY-004]:Membuat Grafik dan Menghitung Luas Cross Section dengan Excel Bagian #2, telah diuraikan tahapan menghitung luas cross section dengan menggunakan rumus / fungsi excel (tanpa macro). Pada hitungan metode ini, untuk mengurangii panjangnya rumus diperlukan beberapa cell bantu. Penggunakaan cell bantu tentunya akan memperbesar ukuran file excel, apalagi kalo data yang akan diolah terdiri dari beberapa station.

Dengan visual basic application, cell bantu tersebut dapat dihilangkan, sehingga didapat fungsi baru (user defined function/UDF) yang lebih simple.

Download file Download program & contoh cross. Setelah didownload dan diextract filenya, buka file xs.xla, kemudian file contoh cross sectionnya. Click [Enable Macro] saat membuka file xs.xla

Contoh cross section :

image

Dalam file xs.xla ada dua UDF yaitu:

1. xCatchPoint()

2. xCutFill()

1. Format Fungsi xCatchPoint():

=CatchPoint(PolylineExisting ,OffsetTemplateKiri ,OffsetTemplateKanan,ElevasiTemplateKiri ,ElevasiTemplateKanan ,SlopeCatchPointKiri ,SlopeCatchPointKanan)

Fungsi ini akan menghasilkan 4 (empat) angka yaitu Offset, Elevasi catch point Kiri dan Offset Elevasi catch point kanan.

[B11]=Index(xCatchPoint($Q$7:$R$27,$B$7,$C$7,$B$9,$C$9,$B$10,$C$10),1)
[B12]=Index(xCatchPoint($Q$7:$R$27,$B$7,$C$7,$B$9,$C$9,$B$10,$C$10),2)
[C11]=Index(xCatchPoint($Q$7:$R$27,$B$7,$C$7,$B$9,$C$9,$B$10,$C$10),3)
[C12]=Index(xCatchPoint($Q$7:$R$27,$B$7,$C$7,$B$9,$C$9,$B$10,$C$10),4)

2. Format Fungsi xCutFillX():

=xCutFill(PolylineExisting, PolylineDesign, TypeRtn)

TypeRtn=0, untuk menampilkan hasil hitungan luas Cut dan Fill. Gunakan index=1, untuk mengambil luas Cut, dan index=2 untuk mengambil lus Fill.

[G8]=INDEX(xCutFill($Q$7:$R$27,$S$7:$T$11,0),1)
[H8]=INDEX(xCutFill($Q$7:$R$27,$S$7:$T$11,0),2)

Coba rubah-rubah parameter design di seperti elevasi design, slope, grade, offset template dll, maka otomatis luas cross section dan grafik akan terupdate

Dalam contoh data cross section ada dua contoh cross section sehingga masing-masing dapat dihitung luas cut dan luas fillnya. Ada tambahan satu sheet [Resume] untuk menghitung volume cut dan fill seperti gambar di bawah:

image

Catatan Penting:

1. Program ini memerlukan fungsi UDF yang disimpan dalam file xs.xla sehinga apabila file cross section dicopy ke tempat lain yang tidak mempunyai file xs.xla, maka graphic dan hitungan luas tidak bisa dihitung” Tampilan jika file xs.xla belum dibuka adalah:

image

2. Copy >> Paste >> Value rumus yang menggunakan fungsi xCatchPoint() dan xCutFill() sebelum didistribusikan.

3. Jika diinginkan setiap kali menjalan program excel file xs.xla otomatis terbuka lakukan pengatuan setting Add-In. Kalo pakai Excel 2007 lakukan pengaturan sebagai berikut:

  • Click tombol image , kemudian pilih [Excel Option] kemudian [Add-Ins]
  • Dalam pilihan [Manage], pilih [Excel Add-Ins] kemudian click tombol [Go]
  • Pada pilihan [Add-Ins], click tombol [Browse]
  • Pilih lokasi file xs.xla, sehingga tampilan Add-Ins yang aktif menjadi

image

 

Note: 8 Feb 2014

the xla program (xs.xla) has been revised since the previous program had “calculation errors” on the right catch point.

thanks for Khalid Maqbool for finding these errors.

 

‘============== selamat mencoba =========================

[XLS-SVY-12]: Add-Ins Excel untuk Hitung Kuadrat Terkecil (HKT)

Referensi :
Platform : Excel 2007, 2003
Lokasi File : https://skydrive.live.com/embedicon.aspx/Public/catatan%20juru%20ukur/XLS-SVY-12.zip?cid=7b3122134b7f51a8&sc=documents

Salah satu program least square adjustment yang pernah aku buat menggunakan visual basic application for excel.

Silahkan didownload dan dicoba. Jika ada yang berminat untuk dikembangkan silahkan lihat source codenya di file terlampir. Untuk melihat source code, aktifkan terlebih dahulu visual basic editor. Jangan lupa cantumkan sumbernya ….

image

Contoh hasil running program:

image

===selamat mencoba===

[XLS-SVY-007]: Plotting Cross Section dari Excel ke AutoCAD

Referensi : [XLS-MAP-03]: Plotting List Koordinat dari Excel ke AutoCAD
Platform : Excel dan AutoCAD
Lokasi File : xls-svy-007.zip

Rencananya program ini akan saya masukkan ke program perhitungan cut and fill cross section dengan vba/macro. Tetapi mempertimbangkan bahwa untuk melakukan koneksi excel ke autocad harus menggunakan library autocad yang sesuai dengan versi autocad yang sudah terinstall, maka code koneksi ini tidak saya masukkan.

Saat saya menulis program ini, saya menggunakan AutoCAD versi 2011. Versi autocad yang lain dan cara setting di Visual Basic Application, silahkan membaca [XLS-MAP-03]: Plotting List Koordinat dari Excel ke AutoCAD di section ‘Setting Reference ke AutoCAD Library’.

Code dalam visual basic application, saya bagi menjadi dua bagian yaitu Procedure Utama dan Procedure/Function Pendukung. Procedure Utama adalah nama macro yang akan dijalankan melalui menu excel, sedangkan procedure/function pendukung adalah procedure2 yang tidak ditampilkan dalam menu macro di excel.

Procedure Utama:

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

Text warna biru adalah procedure atau function pendukung.

Procedure Pendukung (Private):

‘==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 RangeOn 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 List Program (mdlPlot2CAD.bas)

Download contoh cross section (xls-svy-007.zip)

Menjalankan Makro

1. Buka Excel yang ada di file xls-svy-007.zip dan AutoCAD

2. Pada Program Excel tekan Alt+F11 untuk membuka Microsoft Visual Basic Editor

3. Di Microsoft Visual Basic Editor, tekan Ctr+M kemudian pilih file mdlPlot2CAD.bas yang sudah didownload.

4. Setting library ke AutoCAD yang ada di komputer Anda.

5. Keluar dari Microsoft Visual Basic Editor dengan menekan Alt+Q

6. Pada file xls-svy-007.xls, tekan Alt+F8 kemudian double click macro PlotGarisCrossSection

image

Gunakan Mouse untuk mengeblok koordinat (offset, elevasi) Existing yaitu $Q$7:$R$57, kemudian click OK. Akan muncul kotak dialog seperti di atas lagi, untuk memilih (mengeblok) koordinat design yaitu $S$7:$T$11. Akhiri dengan click OK

7. Pindah ke program AutoCAD, jika program tidak pindah ke AutoCAD secara otomatis.

8. 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

9. Lakukan setting warna Layer

10. Gambar cross section di AutoCAD, lengkap dengan label offset dan elevasi

image

selamat mencoba

==zainul==

[XLS-MAP-03]: Plotting List Koordinat dari Excel ke AutoCAD

 

Referensi : import point dengan autolisp
Platform : Excel dan AutoCAD
Lokasi File : download

Pada awalnya saya ingin membuat program visual basic application yang ada di Autocad 2011 untuk menggambarkan lokasi titik-titik sesuai dengan list koordinat yang ada di excel. Tetapi saat saya menekan tombol Alt+F11 untuk mengaktifkan visual basic di AutoCAD 2011 muncul pesan “Microsoft Visual Basic for Application Software is no longer installed with AutoCAD”. Sebetulnya masih disupport oleh Autodesk, tetapi harus download dulu di sini.

Daripada download (sebetulnya pingin sih), saya coba cara lain dengan memanfaatkan program Microsoft Visual Basic for Application yang ada di Excel (Macro). Koneksi AutoCAD dan Excel bisa dilakukan dengan cara memilih ‘AutoCAD 2011 Type Library’ di pilihan References-VBA Project. Jika Anda menggunakan versi AutoCAD yang lain, pilihlah library dengan nama ‘AutoCAD xxxx Type Library’, dimana xxxx adalah versi AutoCAD yang sedang Anda gunakan. misal untuk AutoCAD 2010, maka librarynya adalah ‘AutoCAD 2010 Type Library’.

Contoh List Koordinat di Excel yang akan diplot di AutoCAD adalah :

image

Bujur akan diplot sebagai koordinat X, Lintang adalah koordinat Y dan  Elevasi adalah Z. Text Keterangan akan diplot sesuai dengan posisi titik tersebut (XYZ).

 

 

 

 

 

 

1. Buka file Excel yang berisi list koordinat Saat file excel sudah terbuka, pilih sheet yang berisi list koordinatnya, kemudian tekan Alt+F11 untuk mengaktifkan visual basic editor.
Dari Menu ‘Insert’ pilih ‘Module’
2. Jalankan program AutoCAD, tanpa menutup program Excel Jika diinginkan, pilih layer dan text style di AutoCAD.
3. Setting Reference ke AutoCAD Library pada visual basic editor, pilih menu ‘Tools’ kemudian ‘References’.
Pilih AutoCAD Library sesuai dengan versi AutoCAD yang aktif di pilihan available references. 

image
click OK jika library sudah dipilih.

4. Tulis Macro atau Visual basic di module Option Explicit
Sub PlotKeAutocad()
Dim rgKoordinat As Range

‘table list koordinat di sheet yang aktif
Set rgKoordinat = ActiveSheet.UsedRange
rgKoordinat.Select

Dim respon As Long
If MsgBox(“Pilihan Sudah Benar?”, vbYesNo) = vbNo Then Exit Sub

Dim c As Range, i As Integer, j As Integer
Dim lstKoord() As Double, lstDes() As String

‘membaca list koordinat dan nama titik dari excel
i = -1: j = -1
For Each c In rgKoordinat.Columns(1).Cells
If Application.IsNumber(c) Then
i = i + 3
j = j + 1
ReDim Preserve lstKoord(i)
lstKoord(i – 2) = c
lstKoord(i – 1) = c.Offset(, 1)
lstKoord(i) = c.Offset(, 2)

ReDim Preserve lstDes(j)
lstDes(j) = c.Offset(, 3)
End If
Next

‘koneksi ke autocad, program autocad harus sudah dijalankan
Dim appCAD As AcadApplication
On Error Resume Next
Set appCAD = GetObject(, “AutoCAD.Application”)
If Err.Number Then Exit Sub

Dim Koordinat(0 To 2) As Double
Const TinggiHuruf = 0.002 ‘rubah angka sesuai dengan tinggi huruf yang diinginkan
j = -1
For i = LBound(lstKoord) To UBound(lstKoord) Step 3
j = j + 1
Koordinat(0) = lstKoord(i)
Koordinat(1) = lstKoord(i + 1)
Koordinat(2) = lstKoord(i + 2)
With appCAD.ActiveDocument.ModelSpace
.AddPoint Koordinat ‘plot koordinat
.AddText lstDes(j), Koordinat, TinggiHuruf
End With
Next i

appCAD.ZoomExtents
AppActivate appCAD.Caption
Set appCAD = Nothing
End Sub

5. Menjalankan Program atau Macro Kembali ke sheet list koordinat.
Tekan Alt+F8, kemudian pilih macro PlotKeAutocad , kemudian click Run
6. Check di AutoCAD, apakah titik2 tersebut sudah benar possisinya?

[XLS-MAP-02]: Rumus Proyeksi Traverse Mercator dengan VBA Excel (Macro)

Referensi : Dulu saya ambil dari sini tapi sekarang kok sdh nggak ada.
Platform : Excel
Lokasi File : ada di sini

Saat pertama kali menulis  program ini pada 21 April 2006, tujuannya adalah membuat UDF (User Defined Function) di excel untuk memproyeksi koordinat Lintang Bujur ke North, East dan sebaliknya dari beberapa macam datum dan type sistem proyeksi.

Sampai saat ini baru sampai pada sistem proyeksi traverse mercator, mungkin dari rekan2 sekalian ingin mengembangkan lebih lanjut silahkan.

Pada file excel terlampir dalam project VBA terdapat satu module “mdlProjection” dan satu class “clsTranverseMercator”.

image

mdlProjection berisi fungsi untuk mendefinisikan parameter transformasi seperti :

Dim FalseEasting As Double, FalseNorthing As Double
Dim k0 As Double, a_ellips As Double, inv_f As Double
Dim LebarZone As Double

Sedangkan clsTranverseMercator berisi fungsi-fungsi  proyeksi koordinat dalam Metode TraverseMercator dengang input atau masukan parameter dari module “mslProjectin”

Kode yang ada di “clsTransverseMercator”:

Option Explicit
Function GetCentralMeridian(Bujur As Double, ByVal WidthZone As Double) As Double
GetCentralMeridian = WidthZone * (Int(Bujur / WidthZone) + 0.5)
End Function

Function DegreeToRadian(AngleDegree As Double) As Double
Dim Phi As Double
Phi = 4 * Atn(1)
DegreeToRadian = AngleDegree * Phi / 180
End Function
Function RadianToDegree(AngleRadian As Double) As Double
Dim Phi As Double
Phi = 4 * Atn(1)
RadianToDegree = AngleRadian * 180 / Phi
End Function

Sengaja dalam fungsi konversi degree ke radian atau sebaliknya tidak menggunakan fungsi bawaan excel =DEGREES() atau =RADIANS() karena apabila program ini dipakai atau dicopy ke visual basic yang bukan excel masih bisa berfungsi.

Fungsi untuk memproyeksi Lintang Bujur ke North, East

Sub TransverseMercator( _
CentralMeridian As Double, LATITUDE As Double, LONGITUDE As Double, _
ScaleFactor As Double, a_ellips As Double, inv_f As Double, _
FalseEast As Double, FalseNorth As Double, _
North As Double, East As Double)

Dim Lr As Double, Lg As Double ‘Lr:Latitude in radian,Lg:Longitude in Radian
Dim dB As Double ‘dB:central meridian in radian
Lr = DegreeToRadian(LATITUDE)
Lg = DegreeToRadian(LONGITUDE)
dB = DegreeToRadian(CentralMeridian)
Dim f As Double, e2 As Double, e4 As Double, e6 As Double
Dim e_2 As Double
f = 1 / inv_f
e2 = 2 * f – f ^ 2: e4 = e2 * e2: e6 = e4 * e2
e_2 = e2 / (1 – e2)

Dim T As Double, C As Double, A As Double, M As Double
Dim T2 As Double, C2 As Double, v As Double
T = Tan(Lr) * Tan(Lr)
T2 = T * T
C = e_2 * Cos(Lr) * Cos(Lr)
C2 = C * C
A = (Lg – dB) * Cos(Lr)

Dim MA As Double, MB As Double, MC As Double, MD As Double
MA = (1 – (e2 / 4) – (3 * e4 / 64) – (5 * e6 / 256)) * Lr
MB = ((3 * e2 / 8) + (3 * e4 / 32) + (45 * e6 / 1024)) * Sin(2 * Lr)
MC = ((15 * e4 / 256) + (45 * e6 / 1024)) * Sin(4 * Lr)
MD = (35 * e6 / 3072) * Sin(6 * Lr)
M = a_ellips * (MA – MB + MC – MD)
v = a_ellips / Sqr(1 – e2 * Sin(Lr) * Sin(Lr))

Dim A2 As Double, A3 As Double, A4 As Double, A5 As Double, A6 As Double
Dim X As Double, Y As Double
Dim X1 As Double, X2 As Double
Dim Y1 As Double, Y2 As Double
A2 = A * A
A3 = A2 * A
A4 = A3 * A
A5 = A4 * A
A6 = A5 * A
X1 = (1 – T + C) * A3 / 6
X2 = (5 – 18 * T + T2 + 72 * C – 58 * e_2) * A5 / 120
X = ScaleFactor * v * (A + X1 + X2)
Y1 = (5 – T + 9 * C + 4 * C2) * A4 / 24
Y2 = (61 – 58 * T + T2 + 600 * C – 330 * e_2) * A6 / 720

Y = ScaleFactor * (M + v * Tan(Lr) * (A2 / 2 + Y1 + Y2))

North = FalseNorth + Y
East = FalseEast + X
End Sub

Fungsi untuk memproyeksikan North, East ke Lintang, Bujur adalah:

Sub InversTransverseMercator(CentralMeridian As Double, LATITUDE As Double, LONGITUDE As Double, _
ScaleFactor As Double, a_ellips As Double, inv_f As Double, _
FalseEast As Double, FalseNorth As Double, _
North As Double, East As Double)
Dim f As Double, e2 As Double, e4 As Double, e6 As Double
f = 1 / inv_f
e2 = 2 * f – f ^ 2
e4 = e2 * e2
e6 = e4 * e2
Dim M1 As Double, MiuA As Double, Miu As Double
M1 = (North – FalseNorth) / ScaleFactor
MiuA = 1 – e2 / 4 – (3 * e4) / 64 – (5 * e6) / 256
Miu = M1 / (a_ellips * MiuA)
Dim e_ As Double, e_2 As Double, e_3 As Double, e_4 As Double
e_ = (1 – Sqr(1 – e2)) / (1 + Sqr(1 – e2))
e_2 = e_ * e_
e_3 = e_2 * e_
e_4 = e_3 * e_
Dim Lf As Double, LfA As Double, LfB As Double, LfC As Double, LfD As Double
LfA = ((3 * e_ / 2) – (27 * e_3 / 32)) * Sin(2 * Miu)
LfB = ((21 * e_2 / 16) – (55 * e_4 / 32)) * Sin(4 * Miu)
LfC = ((151 * e_3 / 96)) * Sin(6 * Miu)
LfD = ((1097 * e_4 / 512)) * Sin(8 * Miu)
Lf = Miu + LfA + LfB + LfC + LfD

Dim v_ As Double, p_ As Double
v_ = a_ellips / Sqr(1 – e2 * Sin(Lf) * Sin(Lf))
p_ = a_ellips * (1 – e2) / ((1 – e2 * Sin(Lf) * Sin(Lf)) ^ 1.5)
Dim T_ As Double, C_ As Double, D As Double, e_a2 As Double, T_2 As Double
T_ = Tan(Lf) * Tan(Lf)
e_a2 = e2 / (1 – e2)
C_ = e_a2 * Cos(Lf) * Cos(Lf)
D = (East – FalseEast) / (v_ * ScaleFactor)
T_2 = T_ * T_

Dim D2 As Double, D3 As Double, D4 As Double, D5 As Double, D6 As Double
D2 = D * D
D3 = D2 * D
D4 = D3 * D
D5 = D4 * D
D6 = D5 * D
Dim C_2 As Double
C_2 = C_ * C_
Dim LatitudeA As Double, LatitudeB As Double, LatitudeC As Double
LatitudeA = D2 / 2
LatitudeB = (5 + 3 * T_ + 10 * C_ – 4 * C_2 – 9 * e_a2) * D4 / 24
LatitudeC = (61 + 90 * T_ + 298 * C_ + 45 * T_2 – 252 * e_a2 – 3 * C_2) * D6 / 720
Dim Lr As Double
Lr = Lf – v_ * Tan(Lf) * (LatitudeA – LatitudeB + LatitudeC) / p_
LATITUDE = RadianToDegree(Lr)
Dim LongA As Double, LongB As Double, Lg As Double, dB As Double
LongA = (1 + 2 * T_ + C_) * D3 / 6
LongB = (5 – 2 * C_ + 28 * T_ – 3 * C_2 + 8 * e_a2 + 24 * T_2) * D5 / 120

dB = DegreeToRadian(CentralMeridian)
Lg = dB + (D – LongA + LongB) / Cos(Lf)

LONGITUDE = RadianToDegree(Lg)

End Sub

Contoh penggunaan kedua fungsi tersebut, silahkan buka file terlampir

“semoga bermanfaat”

[XLS-SVY-01]: Prediksi Pasut dengan VBA Excel

Referensi : Harmonic Analysis and Prediction of Tides
Platform : Excel 2003
Lokasi File : <<available upon request>>

 

RUMUS YANG DIGUNAKAN

Prediksi pasang surut (pasut) menggunakan rumus Harmonic Analysis dengan metode least square untuk mencari 9 constituents  utama pembangkit pasut dan 9 phase.

Dalam referensi tertulis,

“The ideal tide curve for any given port is represented as an average height Z0 plus a sum of terms (“constituents”) each of which is of the form f(t) = H cos(at + \phi). The time t is measured in hours, and f comes out in feet. The numbers H,a, \phi are the amplitude, the speed and the phase of the constituent.”

Karena data hasil bacaan pasut yang tersedia adalah dalam meter dan dicatat tiap jam, maka nilai f tidak lagi dinyatakan dalam feet, melainkan dalam meter.

Rumus kemudian dikembangkan menjadi:

image

dalam format matrix dapat ditulis:

image

Jika MatrixX telah didapat, maka dengan menggunakan rumus(4) dan rumus(5),amplitudo dan phase tiap constituent dapat dihitung.

INPUT (DATA HASIL PENGUKURAN MUKA AIR)

Hasil pengukuran muka air didapat dari pengamatan selama 29 hari dengan pencatatan tiap jam, dimulai jam 0:00 sampai jam 23:00 tanggal 1 Maret 2008 sampai jam 23:00 tanggal 29 Maret 2008 yang ditabelkan sebagai berikut:

image

PROSES PEMBACAAN DATA DAN PERHITUNGAN

Proses pembacaan dan perhitungan dengan menggunakan program Visual Basic Application (macro) yang ada di microsoft excel 2003.

Khusus untuk prosedure atau program perkalian matirx dan inverse didapat dari http://www.alglib.net/

Pada file excel spread sheet saya, data pengukuran muka air pertama (1.850m) ada di cell $C$10 sedangkan data terakhir (2.110m) ada di $Z$38, sehingga range data pengukuran adalah di $C$10:$Z$38.

Pastikan bahwa di bagian Declaration di awal program diset :

Option Explicit ‘berguna untuk mendeteksi definisi variable
Option Base 1 ‘hitungan matrix dimulai dari 1, kalo tidak diset, maka default index matrix adalah 0

Sub PrediksiPasutDenganLeastSquare()

‘1. membaca data pengukuran muka air
dim cr as Range, rgData as Range

set rgData=Activesheet.Range(“$C$10:$Z$38”)

For Each cr In rgData.Columns(1).Cells
i = i + 1
j = 1 + (i – 1) * 24
ReDim Preserve MatrixL(1 To j + 23)
For jm = 0 To 23
MatrixL(j + jm) = cr.Offset(0, jm).Value
Next jm
Next

‘2. membaca atau set variable periode tiap Constituents

Dim w(1 To 9) As Double ‘periode dari 9 Constituents pasut
Dim pi As Double
pi = 4 * Atn(1)
w(1) = 2# * pi / 12.4206 ‘M2
w(2) = 2# * pi / 12# ‘S2
w(3) = 2# * pi / 12.6582 ‘N2
w(4) = 2# * pi / 11.9673 ‘K2
w(5) = 2# * pi / 23.9346 ‘K1
w(6) = 2# * pi / 25.8194 ‘O1
w(7) = 2# * pi / 24.0658 ‘P1
w(8) = 2# * pi / 6.2103 ‘M4
w(9) = 2# * pi / 6.1033 ‘MS4

‘3. membuat atau membetuk MatrixA() atau Matrix coeffisien

Dim it As Integer,MatrixA() as Double
ReDim Preserve matrixA(1 To UBound(MatrixL), 1 To 19)

For i = 1 To UBound(MatrixL)
matrixA(i, 1) = 1
it = i
For j = 1 To 9
matrixA(i, 2 * j) = Cos(w(j) * it)
matrixA(i, 2 * j + 1) = -Sin(w(j) * it)
Next j
Next i

‘4. proses least square

Dim weight() As Double: ReDim Preserve weight(UBound(MatrixL, 1))
For i = LBound(weight) To UBound(weight): weight(i) = 1: Next i ‘matrix bobot=matrix identitas
MatrixX() = clsLSQ.LSPAR(matrixA, MatrixL, weight)

‘clsLSQ adalah class yang saya buat untuk proses perhitungan least square, tidak dibahas di session ini

‘5. menghitung amplitudo dan phase 9 konstituent dan sekaligus menampilkan hasilnya di excel
Dim A As Double, B As Double, H(1 To 9) As Double, Phase(1 To 9) As Double
Dim ph As Double, Zo As Double

Const addPrint As String = “H66”

With Range(addPrint)
.Offset(0, 3) = MatrixX(1)’mencetak Zo atau mean sea level
For i = 2 To 19 Step 2
j = i / 2
A = MatrixX(i): .Offset(j, 0) = A
B = MatrixX(i + 1): .Offset(j, 1) = B
ph = Atn(B / A) ‘kwadran I
If A < 0 Then
ph = ph + pi ‘kwadran II dan III
Else
If B < 0 Then ph = ph + 2 * pi ‘kwadran IV
End If
‘phase dikonversi ke derajat
Phase(j) = ph * 180 / pi: .Offset(j, 2) = Phase(j)
H(j) = Sqr(A * A + B * B): .Offset(j, 3) = H(j)

Next i
End With

‘6. Membandingkan muka air hasil pengukuran  dengan muka air hasil hitungan
Dim Ht As Double, SumHCos As Double
Dim Cetak() As Double

ReDim Preserve Cetak(1 To UBound(MatrixL), 1 To 5)

Zo = MatrixX(1)
For i = LBound(MatrixL) To UBound(MatrixL)
Cetak(i, 5) = CDbl(i)’mencetak nomer urut
Cetak(i, 1) = Range(addFirstDate) + (i – 1) / 24’mencetak hari dan jam
Cetak(i, 2) = MatrixL(i)’mencetak muka air pengukuran
SumHCos = 0
For j = 1 To 9
SumHCos = SumHCos + H(j) * Cos(w(j) * i + (Phase(j) * pi / 180))’rumus harmonic
Next j
Ht = Zo + SumHCos ‘rumus(1)
Cetak(i, 3) = Ht’cetak muka air hasil hitungan
Cetak(i, 4) = Ht – MatrixL(i)’muka air hitungan – pengukuran
Next i
Range(“A90:E785”) = Cetak

End Sub

Dengan menggunakan data perbandingan antara muka air hasil pengukuran dengan perhitungan, maka dapat dibuat graphic sebagai berikut:

image

dari hasil hitungan didapat standard deviasi sebesar 0.11meter.