Siapa yang tidak kenal sarang lebah? jika di lihat tampak muka bentuknya simetris terdiri dari kumpulan objek-objek polygon segi 6 yang tersusun rapih.
Berikut analisanya:
Sub TransformasiSegi6()
ActiveDocument.Unit = cdrMillimeter
Dim ObjekAsli As ShapeRange
Set ObjekAsli = ActiveSelectionRange
Dim dup1 As ShapeRange
Dim x As Double, y As Double
ObjekAsli.Cut ' Menghapus sementara dan di simpan di Memory Windows
' Coding : Desember 2014 | Ade Sanusi
' ========== Cara Penggunaan ============
' Buat Objek Segi Enam kemudian Seleksi
' Atur Jumlah Baris Pertama di bawah kemudian Jalankan macro
'Masukan Kode Anda ===========
jb_pertama = 7 ' Jumlah Objek di Baris Pertama Atur Sesuai yang anda inginkan
'jb = 6 'Jumlah Baris yang diinginkan ( Untuk Model Piramid atau Selang Seling )
jb = (jb_pertama * 2) - 1 'Jumlah Baris Otomatis ( Untuk Model Piramid + Piramid Terbalik )
For i = 0 To jb_pertama - 1
For j = 0 To jb_pertama - 1 + i
ActiveLayer.Paste
Set dup1 = ActiveSelectionRange
x = 1 / 2 * dup1.SizeWidth ' Untuk Menggeser Ke Kiri seberas 1/2 L
y = 3 / 4 * dup1.SizeHeight ' Untuk Menggeser ke Bawah sebesar 3/4 T
dup1.Move -(i * x), 0 'Objek yang di Copy di Geser dulu 1/2 L
dup1.Move (j * 2 * x), -(i * y) 'Objek di Cek berada di baris berapa, kemudain di kali posisi kanan, kemudian di kali posisi bawah,
Next j
Next i
For i = 0 To jb_pertama - 2
For j = 0 To jb_pertama - 1 + i
ActiveLayer.Paste
Set dup1 = ActiveSelectionRange
x = 1 / 2 * dup1.SizeWidth 'Objek yang di Copy di Geser dulu 1/2 L
y = 3 / 4 * dup1.SizeHeight ' Untuk Menggeser ke Bawah sebesar 3/4 T
dup1.Move -(i * x), -((jb - 1) * y) 'Di Atur ke Posisi Akhir Dulu
dup1.Move (j * 2 * x), (i * y) 'Objek di Cek berada di baris berapa, kemudain di kali posisi kanan, kemudian di kali posisi atas,
Next j
Next i
For i = 0 To jb - 1
'If i <= jb_pertama - 1 Then
If i Mod 2 = 0 Then
akhir = jb_pertama - 1 'Boleh +1 atau -1
geser = 0
Else
akhir = jb_pertama
geser = 1
End If
For j = 0 To akhir
ActiveLayer.Paste
Set dup1 = ActiveSelectionRange
dup1.Move (j * 2 * x), -(i * y)
Next j
'Else
'For j = 0 To (i - (jb_pertama - 1))
'Next j
'End If
Next i
Taukah Anda meskipun demikian yang menjadi ajaib adalah lebah-lebah tersebut membuat sarang lebah tidak dari tengah atau 1 posisi, melainkan secara acak dari berbagai macam posisi, tapi akhirnya bisa menyatu dengan rapih. #Amazing.Di CorelDraw anda bisa membuatnya dengan toolbox Polygon kemudian diatur sudutnya menjadi 6 bagian. Dan di duplikasi sebanyak yang anda inginkan dan diatur posisinya, dalam hal ini saya tidak ingin menjelaskan cara manualnya, karena ingin membahas cara otomatisnya menggunakan macro.
Berikut analisanya:
- Jumlah Baris : jumlah segi 6 di baris pertama di kali 2 dikurangi 1 (jb_pertama*2) -1
- Pada baris pertama : Objek segi 6 berikutnya terbentuk dari duplikasi objek pertama digeser sejauh lebar segi 6
- Pada baris ke dua : Jumlah segi enam di baris pertama ditambah 1, posisi digeser ke kiri sjauh 1/2 Lebar segi 6 dan digeser ke bawah sejauh 3/4 tinggi segi 6. Kemudian objek disusun posisinya dengan menggeser sejauh lebar segi 6 di kali posisinya.
Berikut kode formasi untuk model (pyramida + pyramida terbalik):
ActiveDocument.Unit = cdrMillimeter
Dim ObjekAsli As ShapeRange
Set ObjekAsli = ActiveSelectionRange
Dim dup1 As ShapeRange
Dim x As Double, y As Double
ObjekAsli.Cut ' Menghapus sementara dan di simpan di Memory Windows
' Coding : Desember 2014 | Ade Sanusi
' ========== Cara Penggunaan ============
' Buat Objek Segi Enam kemudian Seleksi
' Atur Jumlah Baris Pertama di bawah kemudian Jalankan macro
'Masukan Kode Anda ===========
jb_pertama = 7 ' Jumlah Objek di Baris Pertama Atur Sesuai yang anda inginkan
'jb = 6 'Jumlah Baris yang diinginkan ( Untuk Model Piramid atau Selang Seling )
jb = (jb_pertama * 2) - 1 'Jumlah Baris Otomatis ( Untuk Model Piramid + Piramid Terbalik )
For i = 0 To jb_pertama - 1
For j = 0 To jb_pertama - 1 + i
ActiveLayer.Paste
Set dup1 = ActiveSelectionRange
x = 1 / 2 * dup1.SizeWidth ' Untuk Menggeser Ke Kiri seberas 1/2 L
y = 3 / 4 * dup1.SizeHeight ' Untuk Menggeser ke Bawah sebesar 3/4 T
dup1.Move -(i * x), 0 'Objek yang di Copy di Geser dulu 1/2 L
dup1.Move (j * 2 * x), -(i * y) 'Objek di Cek berada di baris berapa, kemudain di kali posisi kanan, kemudian di kali posisi bawah,
Next j
Next i
For i = 0 To jb_pertama - 2
For j = 0 To jb_pertama - 1 + i
ActiveLayer.Paste
Set dup1 = ActiveSelectionRange
x = 1 / 2 * dup1.SizeWidth 'Objek yang di Copy di Geser dulu 1/2 L
y = 3 / 4 * dup1.SizeHeight ' Untuk Menggeser ke Bawah sebesar 3/4 T
dup1.Move -(i * x), -((jb - 1) * y) 'Di Atur ke Posisi Akhir Dulu
dup1.Move (j * 2 * x), (i * y) 'Objek di Cek berada di baris berapa, kemudain di kali posisi kanan, kemudian di kali posisi atas,
Next j
Next i
'===Akhir Kode Anda ====
End Sub
Maka hasilnya sebagai berikut :
Berikut ini kode untuk model selang-seling :
Sub TransformasiSegi6SelangSeling()
ActiveDocument.Unit = cdrMillimeter
Dim ObjekAsli As ShapeRange
Set ObjekAsli = ActiveSelectionRange
Dim dup1 As ShapeRange
Dim x As Double, y As Double
ObjekAsli.Cut ' Menghapus sementara dan di simpan di Memory Windows
' Coding : Desember 2014 | Ade Sanusi
' ========== Cara Penggunaan ============
' Buat Objek Segi Enam kemudian Seleksi
' Atur Jumlah Baris Pertama di bawah kemudian Jalankan macro
'Masukan Kode Anda ===========
jb_pertama = 10 ' Jumlah Objek di Baris Pertama
jb = 6 'Jumlah Baris yang diinginkan
End Sub
Maka hasilnya sebagai berikut :
Berikut ini kode untuk model selang-seling :
Sub TransformasiSegi6SelangSeling()
ActiveDocument.Unit = cdrMillimeter
Dim ObjekAsli As ShapeRange
Set ObjekAsli = ActiveSelectionRange
Dim dup1 As ShapeRange
Dim x As Double, y As Double
ObjekAsli.Cut ' Menghapus sementara dan di simpan di Memory Windows
' Coding : Desember 2014 | Ade Sanusi
' ========== Cara Penggunaan ============
' Buat Objek Segi Enam kemudian Seleksi
' Atur Jumlah Baris Pertama di bawah kemudian Jalankan macro
'Masukan Kode Anda ===========
jb_pertama = 10 ' Jumlah Objek di Baris Pertama
jb = 6 'Jumlah Baris yang diinginkan
offset_x = 2 'Untuk jarak antar segi 6 ke kanan
offset_y = 2 ' Untuk jarak antar segi 6 ke bawah
'If i <= jb_pertama - 1 Then
If i Mod 2 = 0 Then
akhir = jb_pertama - 1 'Boleh +1 atau -1
geser = 0
Else
akhir = jb_pertama
geser = 1
End If
For j = 0 To akhir
ActiveLayer.Paste
Set dup1 = ActiveSelectionRange
x = (1 / 2 * dup1.SizeWidth) + (1/2 *offset_x)
y = (3 / 4 * dup1.SizeHeight) + offset_y
dup1.Move -(geser * x), 0dup1.Move (j * 2 * x), -(i * y)
Next j
'Else
'For j = 0 To (i - (jb_pertama - 1))
'Next j
'End If
Next i
Hasilnya sebagai berikut:
Anda juga bisa mengatur offset di bagian offset_x dan offset_ y untuk memberikan jarak antar segi 6.
Cara penggunaan macronya:
- Alt + F11 di CorelDraw,
- Cari GlobalMacros sebelah kiri bagian Projek Explorer
- Cari CorelMacros trus double Clik modul tersebut dan masukan kode di atas di dalamnya
- Kemudian Runing.
Demikian Tips Trik Membuat Sarang lebah Otomatis dengan Macro di CorelDraw #GRAFISin
0 komentar:
Posting Komentar