Di sini menerima pembuatan Program Aplikasi, bila anda berminat bisa kontak lewat via Email rizal.lonly@gmail.com, dan bila ada link yang rusak segera hubungi admin, Terima kasih atas kunjungannya.

Ban Terbaik di Indonesia GT Radial

PT Gajah Tunggal Tbk telah memperoleh banyak penghargaan sebagai ban terbaik di Indonesia maupun Internasional. Dari perjalanan waktu selama 60 tahun, perusahaan ini tetap eksis di Industri ban yang semakin ketat. Ban mobil GT Radial digunakan sebagai Original Equipment Manufacturer (OEM) oleh beberapa Produsen utama kendaraan di Indonesia, seperti Toyota dan Daihatsu.
Pengakuan pun datang dari Harian Bisnis Indonesia yang pada 15 Desember 2009 menyematkan GT Radial sebagai "Anugerah Produk Asli Indonesia" (APAI), merek asli dari Indonesia yang mendapat pengakuan dunia. Sebelumnya, pada 2008 Gajah Tunggal menerima penghargaan Primaniyarta Award dari Kementrian Perdagangan yang diserahkan langsung oleh Presiden Republik Indonesia Susilo Bambang Yudhoyono sebagai salah satu perusahaan nasional terbaik dalam hal "Pengembangan Merek Global".

Divisi riset dan pengembangan (R&D) yang diisi oleh para ahli dari lulusan Politeknik Gajah Tunggal, yang merupakan salah satu pendidikan ternama di tanah air.
Dari sanalah, kemudian lahir Champiro Eco yang pada 2010 mendapat penghargaan dari Museum Rekor Dunia Indonesia (MURI) untuk kategori ban ramah lingkungan pertama yang diproduksi di Indonesia.

Ban bertipe Champiro HPY menerima penghargaan Amazing Record 200 majalah Auto Bild atas daya tahan, kualitas dan kinerja dari ban tersebut yang diuji dengan mengelilingi sirkuit Internasional Sentul selama 200 lap hanya dengan 1 set (4 buah) ban.
Ini diakui oleh Euromoney Magazine yang pada September 2006 memberikan penghargaan Asia's Best Managed Company In Indonesia kepada Gajah Tunggal dan di tahun 2011 perusahaan mendapatkan penghargaan sebagai salah satu dari top 10 Indonesia's best managed companies dari majalah FinanceAsia dan salah satu dari top 10 Indonesia's best performing companies dari majalah Forbes. [GT-RADIAL]

Sumber :
  1. http://ban.dapurpacu.com/materi-teks-1/
  2. http://www.gtradial.co.id/gtradial/ina/
Selengkapnya...

Apple Akan Meluncurkan MacBook Pro Pada Tahun 2012

Menurut rumor yang berkembang, Apple berencana akan meluncurkan MacBook Pro  dengan resolusi 2880 x 1800 pixel pada kuartal kedua tahun 2012. Jika rumor yang beredar itu adalah benar, maka produk tersebut akan mengalahkan komputer desktop iMac 27 inci yang menampilkan resolusi 2560 x 1440 pixel.

Nampaknya rencana tersebut bukan rumor semata, Asus dan Acer memang seakan terobsesi untuk meluncurkan Ultrabook dengan resolusi tertinggi di pasaran, mengalahkan Apple MacBook Air 13 inci yang beresolusi 1440 x 900 piksel.

Sebenarnya, Apple sejak tahun 2010 sudah berusaha mendesak resolusi layar perangkatnya. Mereka telah memperkenalkan Retina Display pada iPhone 4, dengan resolusi layar dan kerapatan pixel yang mendekati cetak.

Persaingan untuk produk dengan kualitas grafis yang tinggi memang semakin ketat. Di tahun 2012, produsen seperti Asus dan Acer juga berencana untuk meluncurkan ultrabook seri terbaru dengan resolusi 1920 x 1080 pada awal 2012.
Selengkapnya...

Cerita Lucu Tentang Transportasi

Di sini saya akan berbagi tentang cerita lucu, sudah lama saya tidak posting tentang cerita lucu. Cerita lucu kali ini berhubungan dengan Transportasi, anda sekalian pasti sudah tahu apa itu transportasi? Bagi anda yang lagi dalam perjalanan mungkin bosen, apalagi kalau kena macet itu menambah kita semakin stress, untuk itu saya berbagi cerita lucu untuk menghibur anda dalam perjalanan, tapi kalau anda sedang mengemudi sebaiknya jangan, itu dapat berakibat fatal. Saya terlalu banyak omong juga, baiklah saya akan bercerita lucu tentang transportasi sebagai berikut :

===========================================================
Terjebak di Gerbong Kereta Api

Terjadi kecelakaan hebat dalam terowongan kereta api, semua penumpang yang selamat terjebak ditengah terowongan, karena pada dua sisi terowongan tersebut terhalang gerbong kereta yang terbakar.
Saat itu semuanya panik, banyak penumpang yang berteriak kita tidak bisa keluar, kita terjebak, kita akan mati dan lain-lainnya.
Tiba-tiba ada Nenek yang berteriak : "Tenang-tenang kita semua pasti akan keluar, saya berani menjamin." Kemudian suasana menjadi tenang.
Lalu seorang penumpang bertanya : "Bagaimana caranya keluar? Semua jalan keluar tertutup oleh gerbong yang terbakar."
Dengan tenang Nenek menjawab : "Kita pasti keluar di KORAN besok....."

===========================================================
Transportasi Surga

Ada tiga pria meninggal dan masuk surga!
Surga mempunyai peraturan bahwa setiap orang baik jahat maupun orang baik akan mendapat kendaraan yang pantas dengan perbuatannya.
Lelaki-1 tiba dan malaikat bertanya, "Berapa tahun kamu menikah?"
Jawab Lelaki-1, "20 Tahun."
"Berapa kali kamu mengkhianati istrimu?"
Jawab Lelaki-1, "5 kali."
"Baiklah," jawab Sang Malaikat, "Kamu boleh masuk tapi hanya mendapat Kijang."
Lelaki-1 pun berlalu dengan Kijangnya.
Berikutnya adalah Lelaki-2, "Berapa tahun kamu menikah?"
Jawab lelaki-2, "30 tahun."
"Berapa kali kamu mengkhianati istrimu?"
Jawab Lelaki-2, "2 kali"
"Lumayan...Kamu pantas mendapat BMW."
Tibalah kini lelaki-3 dan Malaikat pun mengajukan pertanyaan yang sama dan dijawab Lelaki-3, "50 tahun."
"Berapa kali kamu mengkhianati istrimu?"
"Tidak pernah!"
"Luar biasa! Ini kunci untuk Ferrari."
Suatu hari tatkala lelaki-1 dan Lelaki-2 tadi tengah mengendarai mobilnya, mereka melihat Lelaki-3 duduk di tepi jalan sambil menangis.
Mereka menghampirinya dan bertanya, "Kenapa kamu menangis? Tidak puas dengan Ferrarinya?"
Jawab Lelaki-3 sambil mengusap air matanya, "Tadi saya berpapasan dengan istriku yang sedang naik SEPEDA."

===========================================================
Transportasi Jemaah Haji

Seorang Jemaah Haji asal Jepara, sebut saja namanya Adi, sedang menunggu angkutan di sebuah halte dekat maktabnya untuk ke Masjidil Haram. Setiap kali bus datang, dia mengurungkan niatnya untuk naik bus. Bus datang lagi, urung lagi. Datang lagi, urung lagi.
Begitu seterusnya dari tadi pagi sampai menjelang waktu zhuhur tiba.
Usutnya ternyata si Adi tidak berani naik ke bus karena setiap berhenti di Halte, kernetnya berteriak , "Haram! Haram!"
"Si Adi mengira kalau dia tidak boleh naik ke bus karena kernetnya bilang "Haram...Haram!"
Seperti kondektur Metromini Jakarta yang bilang "Grogol...Grogol!" Kata mantan Ketua PBNU, KH. Hasyim Muzadi sambil terkekeh-kekeh.
Saat dikasih tahu bahwa Adi bukaan tidak boleh naik bus melainkan bus itu memang jurusan Masjidil Haram, dia punya ide besar. Kelak jika kembali ke Tanah Air, dia akan bangun sebuah mesjid yang akan dia beri nama "MASJIDIL HALAL."
"Supaya jangan ada orang terkecoh seperti saya. Dikira Haram, ternyata Halal, " kata Adi seperti di ceritakan KH. Hasyim Muzadi.

===========================================================
Dikentutin Orang Afrika

Pengalaman unik dan lucu tidak hanya dialami jemaah, tapi juga oleh petugas haji termasuk wartawan. Seorang wartawan yang bertugas di Media Center Haji (MCH), sebut saja namanya Haji Warta, percaya betul akan hukum karma dan keajaiban-keajaiban yang bisa dialami oleh jemaah saat menjalankan ibadah haji.
Misalnya saja, kalau di Indonesia dia seorang yang murah hati suka bagi-bagi rejeki, maka di Tanah Suci tiba-tiba banyak orang yang tidak dikenal kasih-kasih dia apa saja, dari mulai sekedar makanan, cenderamata sampai uang riyal. Ada juga wartawan yang sombong karena sudah sering ke luar negeri lalu menganggap mudah bisa pulang sendiri dari Masjidil Haram ke pemondokannya.
"Eh, ternyata dia tersesat. Biasanya wartawan memberikan jemaah yang tersesat, ternyata wartawannya sendiri tersesat," kata Haji Warta.
Khusus hukum karma yang dia alami sendiri, Haji Warta menceritakan pengalamannya. Ia mengaku doyan kentut. Kalau sudah mau buang gas, dia tidak bisa menahan diri. Haji Warta bisa kentut dimana saja, kapan saja, dan bagi siapa saja seperti iklan minuman kaleng. Di ruang kerja kentut, saat rapat kentut, bahkan di lift dia mengaku sering kentutin orang.
"Tahu tidak Pak? Di Tanah Suci saya dibalas dikentutin orang melulu," cerita Haji Warta kepada saya.
Ia mengatakan baru saja dikentutin jemaah haji berkulit hitam berbadan tinggi dan besar. Saat habis tawafdan sedang berjalan meninggalkan Masjidil Haram, tiba-tiba seorang jemaah haji asal Afrika bergegas melewatinya. Begitu terlewati dan berada persis di depan Haji Warta, si Afrika berhenti sebentar dan "Brutttt...." buang gas persis ke muka Haji Warta.
"Celakanya, habis kentut begitu, dia menengok ke saya dan tersenyum-senyum. Habis itu, dia jalan begitu saja. DARGOMBES!" kata Haji Warta memelas.
DARGOMBES adalah umpatan khas Jawa Timuran untuk mengganti kata "Diancuk" yang sangat vulgar.
Selengkapnya...

Nitro PDF Profesional Full Crack Terbaru

Hari ini saya akan memposting tentang software, software ini sangat bermanfaat untuk mengkonversi file PDF ke file Microsoft Office seperti Word dan Excel kalau bukan lagi Software Nitro PDF Profesional.
Hasil konversi sangat baik dan menghasilkan sama persis dengan file PDF tanpa ada yang berantakan.
Ketika saya menggunakan Software Nitro PDF Profesional versi terbaru ini ada beberapa fitur tambahan yaitu :
  • Tampilan lebih dinamis
  • Kinerja lebih cepat dari versi sebelumnya
  • Bisa mengkonversi dari file PDF menjadi file gambar (jpg dan lain-lainnya)
  • Anda dapat menambahkan tulisan (edit) langsung di file PDF
  • Dan masih banyak fitur yang lainnya.
Jika anda berminat bisa di download pada link di bawah ini!

Selengkapnya...

Script Code : Buat Billing Rental Komputer

Anda sekalian pasti sudah tahu apa itu Billing? Nah, disini saya akan berbagi Script Code tentang membuat Billing Rental Komputer, bahasa pemprograman yang digunakan adalah bahasa pemprograman VB (Visual Basic), bisa juga dicoba dengan bahasa pemprograman yang lainnya seperti Java maupun Foxpro, tapi memang harus sedikit merubah perintahnya saja. Jika anda tertarik untuk mencoba bisa mengikuti langkah-langkah berikut ini, disini anda tinggal mengklik menu dibawah ini!
1.  Forms
     -  FrmBilling(FrmBilling.frm)
     -  frmHelp(frmHelp.frm)
     -  FrmMenu(FrmMenu.frm)
     -  frmSplash(frmSplash.frm)

--------------------------------------------------------------------------------------------------
1.  Forms
     -  FrmBilling
     Script Code :
Private Sub CekRental_Click()
CekSendiri.Enabled = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub CekSendiri_Click()
CekRental.Enabled = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub CmdBilUlang_Click()
DTPickTgl.Enabled = False
CmdMasuk.Enabled = False
TxtMasuk.Text = ""
TxtMasuk.Enabled = False
CmdKeluar.Enabled = False
TxtKeluar.Text = ""
TxtKeluar.Enabled = False
CmdLama.Enabled = False
TxtLama.Text = ""
TxtLama.Enabled = False
OptYa.Value = False
OptTidak.Value = False
OptYa.Enabled = False
OptTidak.Enabled = False
CekSendiri.Value = 0
CekRental.Value = 0
CekSendiri.Enabled = False
CekRental.Enabled = False
TxtPrint.Text = ""
TxtPrint.Enabled = False
txtTotal.Text = ""
txtTotal.Enabled = False
CmdHitung.Enabled = False
CmdBilUlang.Enabled = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub CmdHitung_Click()
Dim lama_rental As Integer
Dim kertas As Integer
Dim banyak_print As Integer
lama_rental = TxtLama.Text
biaya_rental = (lama_rental / 60) * 1000
If CekRental.Value = Checked Then
kertas = 300
Else
kertas = 200
End If
banyak_print = TxtPrint.Text
biaya_print = banyak_print * kertas
txtTotal.Text = biaya_rental + biaya_print
txtTotal.Text = Format(txtTotal.Text, "Rp ###,###,###")
CmdBilUlang.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub CmdKeluar_Click()
TxtKeluar.Enabled = True
TxtKeluar.Text = Time
CmdLama.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub CmdLama_Click()
TxtLama.Enabled = True
TxtLama.Text = DateDiff("n", TxtMasuk.Text, TxtKeluar.Text)
OptYa.Enabled = True
OptTidak.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub CmdMasuk_Click()
TxtMasuk.Enabled = True
TxtMasuk.Text = Time
CmdKeluar.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub ComHari_Change()
If ComHari.Text = "Senin" Or ComHari.Text = "Selasa" Or ComHari.Text = "Rabu" Or ComHari.Text = "Kamis" Or ComHari.Text = "Jumat" Or ComHari.Text = "Sabtu" Or ComHari.Text = "Minggu" Then
CmdMasuk.Enabled = True
DTPickTgl.Enabled = True
Else
X = MsgBox("Nama hari yang Anda isi Salah !!! Silahkan memilih dari daftar yang telah tersedia", vbOKOnly, "Nama Hari Salah")
ComHari.SetFocus
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub ComHari_DropDown()
CmdMasuk.Enabled = True
DTPickTgl.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub ComHari_KeyDown(KeyCode As Integer, Shift As Integer)
CmdMasuk.Enabled = True
DTPickTgl.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
FrmBilling.Top = 0
FrmBilling.Left = 0
DTPickTgl.Enabled = False
CmdMasuk.Enabled = False
CmdKeluar.Enabled = False
CmdLama.Enabled = False
OptYa.Enabled = False
OptTidak.Enabled = False
CekSendiri.Enabled = False
CekRental.Enabled = False
TxtPrint.Enabled = False
txtTotal.Enabled = False
CmdHitung.Enabled = False
CmdBilUlang.Enabled = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub Image1_Click()
FrmBilling.Hide
End Sub
-----------------------------------------------------------------------------------------
Private Sub OptTidak_Click()
CekSendiri.Enabled = False
CekRental.Enabled = False
TxtPrint.Text = "0"
TxtPrint.Enabled = False
CmdHitung.Enabled = True
CmdHitung.Default = True
CmdBilUlang.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub OptYa_Click()
OptTidak.Enabled = False
CekSendiri.Enabled = True
CekRental.Enabled = True
TxtPrint.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub TxtPrint_Change()
CmdHitung.Enabled = True
End Sub
    -  frmHelp
     Script Code :
Option Explicit
-----------------------------------------------------------------------------------------
Private Sub CmdOk_Click()
Unload Me
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Resize()
CmdOk.Move (Me.ScaleWidth - CmdOk.Width) / 2, Me.ScaleHeight - CmdOk.Height - 120
txtHelp.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight - CmdOk.Height - 240
End Sub
-----------------------------------------------------------------------------------------
Private Sub txtHelp_Click()
CmdOk.SetFocus
End Sub
    -  FrmMenu
     Script Code :
Private Sub MnuBantu_Click()
frmHelp.Show
End Sub
-----------------------------------------------------------------------------------------
Private Sub MnuInputBil_Click()
FrmBilling.Show
End Sub
-----------------------------------------------------------------------------------------
Private Sub TmrAnimasi_Timer()
FrmMenu.Caption = Right(FrmMenu.Caption, Len(FrmMenu.Caption) - 1) & Left(FrmMenu.Caption, 1)
End Sub
-----------------------------------------------------------------------------------------
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "ToolBilling"
FrmBilling.Show
Case "ToolHelp"
frmHelp.Show
Case "ToolExit"
End
End Select
End Sub
     - frmSplash
     Script Code :
Option Explicit
-----------------------------------------------------------------------------------------
Private Sub Form_Click()
animasilayar
Unload Me
FrmMenu.Show
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_KeyPress(KeyAscii As Integer)
animasilayar
Unload Me
FrmMenu.Show
End Sub
-----------------------------------------------------------------------------------------
Sub animasilayar()
Dim i As Integer
i = Me.Height
While i >= frmSplash.Height
i = i - 110
If i < frmSplash.Height Then
Me.Height = i
Else
Me.Height = frmSplash.Height
End If
DoEvents
Wend
i = Me.Top
i = Me.Top
While i > 0
Me.Move Me.Left, i, Me.Width, Me.Height
i = i - 330
DoEvents
Wend
i = Me.Left
While i < Screen.Width
Me.Move i, Me.Top + 135, Me.Width, Me.Height
i = i + 335
DoEvents
Wend
End Sub
Sekian dulu informasi dari saya, apabila ada pertanyaan bisa lewat kotak komentar.
Terima kasih, semoga bermanfaat!
Selengkapnya...

AMD FX-6200 Bulldozer CPU Akan Dirilis Pada Akhir Tahun 2011

AMD FX-6200 Bulldozer CPU memiliki total  enam inti proses dan menurut Haber Donanim akan datang dengan clock 3.8GHz. Prosesor ini akan mampu untuk secara dinamis menyesuaikan kecepatan operasi, menurut jumlah untuk menjalankan thread, berkat masuknya teknologi Turbo Core 2.0 yang memungkinkan prosesor mencapai kecepatan maksimum 4.1GHz.

Sisa dari spesifikasi chip ini agak standar untuk chip enam core seri FX lainnya seperti 6MB L2 cache serta 8MB level 3 cache memory, namun TDP telah meningkat menjadi 125W dari 95W pada FX-6100.

Peningkatan ini mungkin dikarenakan peningkatan frekuensi operasi, tapi ada juga kemungkinan bahwa isu-isu untuk persyaratan memproduksi 32nm diberikan AMD pada Globalfoundries yang susah menghasilkan keputusan menaikkan TDP pada tujuan agar lebih mudah membuat chip untuk memenuhi syarat.
Tentang kinerja chip yang bersangkutan, dokumen internal menyebutkan chip Bulldozer baru ini berada di antara AMD FX-6100 dan FX-8150 dalam proses encoding video. Grafik ini juga menunjukkan Intel Core i5-2400 menjalankan aplikasi ini, terlihat bahwa dua prosesor ini memiliki performa hampir sama saat melakukan encoding video. Perhatikan grafik berikut :

Harga untuk chip ini baru akan ditetapkan pada $175, yang berarti menjadi sekitar 134 USD, dan membuat CPU AMD dibanding rivalnya Intel Core i5-2400 sedikit lebih murah, yang dijual seharga $184 sampai $ 195.

Selengkapnya...

Script Code : Buat Form Login

Anda sekalian pasti sudah tahu apa itu Login? kalau belum tahu Login itu adalah suatu form yang digunakan untuk masuk ke sistem ID user, baik itu private maupun public. Kalau Login yang bersifat private seperti Login admin, dimana hanya admin yang bisa mengaksesnya, tapi kalau public semuanya bisa sharing. Nah, di sini saya akan berbagi Script Code untuk membuat Form Login, ini bukan Form Login biasa karena Form Login yang akan saya bagikan, Password nya saya Enkripsi, jadi Password nya di kodekan dan Form Login ini hanya bisa diakses oleh user yang mempunyai ID nya saja yang bersifat private, tapi user lain bisa mengakses dengan cara konfirmasi oleh admin sehingga user tersebut bisa mengaksesnya. Jika anda berminat bisa mengikuti langkah-langkah sebagai berikut :
1.  Form
     -  Login(Login.frm)
     Script Code :
Dim adologin As New ADODB.Recordset
Public conn As New ADODB.Connection
Dim strsql As String
-----------------------------------------------------------------------------------------
Private Sub cmdbatal_Click()
kosong
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdlogin_Click()
strsql = "select * from adm_user " _
& " where userID='" & txtUserId.Text & "' " _
& " and password=md5('" & txtPassword.Text & "')"
Set adologin = conn.Execute(strsql)
If Not adologin.EOF Then
MDIMenuUtama.Show
Me.Hide
txtUserId.Text = ""
txtPassword.Text = ""
Else
MsgBox "User atau Password Tidak Sesuai..", _
vbCritical, "Error Login"
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
'Database dan Password bisa anda ganti.
strsql = "Driver={Mysql ODBC 3.51 Driver}; " _
& " Server=localhost; Database=root;" _
& " UID=root; Password="
Set conn = New ADODB.Connection
conn.ConnectionString = strsql
conn.CursorLocation = adUseClient
conn.Open
End Sub
-----------------------------------------------------------------------------------------
Sub kosong()
txtUserId.Text = ""
txtPassword.Text = ""
End Sub
Selanjutnya anda mengisi perintah SQL, sebagai berikut :
Dan Ketik SQL :
insert into adm_user values ('Rizal',md5('admin'));

Catatan :
  • Dimana pada SQL yang saya gunakan adalah SQLyog, anda bisa pakai Appserv atau xammp, perintahnya sama saja.
  • Bila anda belum mempunyai MySQL ODBC Konektor 3.51, bisa didownload Di Sini


Selengkapnya...

Manfaat Buah Anggur Bagi Kesehatan

Buah anggur tidak hanya sumber dari vitamin A, C, B6 dan folate yang baik. Tetapi juga sumber mineral penting seperti potassium, calcium, iron, phosphorus, magnesium dan selenium.
Semua vitamin tersebut sangat berguna untuk menjaga kesehatan tubuh. Inilah beberapa khasiat kesehatan dari buah anggur seperti yang dikutip dari Idiva.

1. Asma
Anggur memiliki kekuatan assimilatory yang dapat meningkatkan kadar air dalam paru-paru. Hal ini sangat baik bagi penderita asma karena dapat mengurangi masalah sesak nafas.

2. Antibakteri
Anggur merah memiliki kandungan antibakterial dan antivirus yang sangat kuat, sehingga dapat melindungi tubuh dari infeksi.

3. Alzheimer
Penelitian menunjukkan bahwa anggur dapat meningkatkan kesehatan otak dan menghindari dari penyakit Alzheimer. Hal ini dikarenakan anggur mengandung resveratol, yakni sebuah polifenol yang mengurangi tingkat amyloidal beta peptides pada penderita Alzheimer.

4. Kanker Payudara
Penelitian juga menunjukkan bahwa jus anggur yang berwarna ungu membantu dalam mencegah kanker payudara yang secara signifikan mengurangi massa tumor pada payudara.

5. Sembelit
Anggur mengandung asam organik, gula, selulosa yang dikenal sebagai pencahar. Manfaat ini sangat baik untuk mengatasi sembelit atau susah buang air besar.

6. Kelelahan
Jus anggur mengandung energi instan. Jus anggur yang kaya akan zat besi dapat mengurangi kelelahan diimbangi dengan istirahat yang cukup.

7. Penyakit Jantung
Tingkat oksida nitrat dalam darah akan meningkat ketika anda mengkonsumsi buah anggur, yang bermanfaat untuk mencegah pembekuan dan mengurangi resiko penyakit jantung. Antioksidannya juga dapat menghentikan oksidasi kolesterol LDL yang menghambat pembuluh darah.

8. Pencernaan
Bila anda menderita gangguan pencernaan, ada baiknya anda mengkonsumsi anggur. Anggur juga baik untuk mengatasi masalah perut lainnya.

9. Migrain
Minum jus anggur murni tanpa campuran air di setiap pagi dapat menyembuhkan penyakit migrain atau sakit kepala sebelah.

10. Gangguan Ginjal
Anggur dapat membantu menyingkirkan asam pada ginjal. Hal ini berarti mengurangi gangguan pada tekanan ginjal.
Selengkapnya...

Makanan dan Minuman yang Alami Untuk Memutihkan Gigi

1. Stroberi
Buah ini adalah salah satu makanan alami yang dapat memutihkan gigi. Asam malat yang terkandung dalam stroberi bertindak sebagai zat yang akan mengikis dan menghilangkan beberapa noda pada permukaan gigi.
Stroberi yang dicampur dengan setengah sendok teh baking soda bisa bertindak sebagai pemutih gigi. Oleskan campuran tersebut ke seluruh permukaan gigi selama 5 menit untuk mendapatkan hasil yang memuaskan.
Namun, metode ini tidak boleh dilakukan dalam waktu yang lama karena bisa asam pada stroberi dapat menghancurkan enamel gigi dari waktu ke waktu.

2. Apel
Apel mengandung dua kualitas yang membantu dalam pemutihan gigi. Pertama, proses mengunyah buah apel yang keras dan renyah bisa melunturkan plak gigi yang dapat mengubah warna gigi. Selain itu, mengunyah juga merangsang produksi air liur yang secara alami dapat melawan bakteri dalam mulut yang merubah warna gigi.
Kedua, apel juga mengandung asam malat yang bertindak sebagai bahan alami untuk mengendurkan dan menghilangkan noda pada permukaan gigi.

3. Wortel
Wortel juga dapat berfungsi sebagai pemutih gigi yang alami. Seperti apel, wortel adalah makanan yang dapat melunturkan plak gigi yang keras selama proses mengunyah.

4. Lemon atau Jeruk Nipis
Jus lemon juga dapat digunakan untuk memutihkan gigi. Jus lemon dapat dikombinasikan dengan garam atau soda kue untuk membuat pasta, yang kemudian menggosok gigi selama beberapa menit.
Tapi karena jus lemon mengandung asam sitrat yang dapat menyebabkan korosi dari enamel gigi, selalu bilas dan sikat gigi dengan baik setelah meminum jus lemon tersebut.
Selengkapnya...

Tim Peneliti Dari Amerika Telah Menciptakan Network Dengan Kecepatan Transfer Data 186 Gbps

Sebuah tim peneliti yang berasal dari California Institute of Technology (Caltech), University of Victory dan University of Michigan baru saja membuat terobosan baru dalam dunia informasi teknologi. Mereka mengklaim bahwa telah berhasil menggunakan rangkaian jaringan wide-area dengan kemampuan transfer data dari satu lokasi ke lokasi lain mencapai 186 gigabits per second (Gbps).
Mereka melakukan hal tersebut pada saat pelaksanaan konferensi SuperComputing 2011 (SC11) yang diadakan di Seattle, Washington Amerika Serikat pada pertengahan November lalu. Dengan kecepatan tersebut, orang bisa memindahkan tidak kurang dari 100 ribu BluRay Disk melalui sebuah jaringan dalam satu hari saja, atau sekitar 2 juta gigabytes.
Harvey Newman, yang merupakan seorang profesor fisika di Caltech sekaligus ketua tim tersebut mengatakan bahwa dengan kemampuan tersebut, jalan menuju masa depan dapat dilihat dengan jelas. Selain itu teknologi tersebut juga mampu menunjukkan apa-apa yang belum ditemukan oleh generasi sebelumnya.
Selengkapnya...

Script Code : Buat Form Tes Koneksi

Pada artikel kali ini saya akan berbagi tentang Script Code untuk bahasa pemprograman VB (Visual Basic), bisa juga digunakan untuk bahasa pemprograman Java maupun Foxpro, hanya dengan mengganti perintah-perintahnya saja. Script Code yang akan saya bahas adalah tentang Tes Koneksi yaitu koneksi antara Server dan Client, ini bisa digunakan juga untuk Jaringan, bagi anda yang suka mengotak-atik jaringan bisa pakai program ini. Jika anda berminat bisa mengikuti langkah-langkah berikut, anda tinggal mengklik menu dibawah ini :
1.  Forms
     -  frmConnectionTest(frmConnectionTest.frm)
     -  frmMyIP(frmMyIP.frm)
     -  frmPortScanner(frmPortScanner.frm)
--------------------------------------------------------------------------------------------------
1.  Forms
     -  frmConnectionTest
     Script Code :
Dim AtPort As String
Dim LimitSend As String
Dim Start As String
-----------------------------------------------------------------------------------------
Private Sub cmdClearLog_Click()
txtPortsOpenLog.Text = ""
End Sub
-----------------------------------------------------------------------------------------
Private Sub CmdScan_Click()
TimerScanner.Enabled = False
If Start = "No" Then
Exit Sub
End If
CmdScan.Enabled = False
If optLocal.Value = True Then
Dim PortLow As String
PortLow = txtPortLow.Text
Dim PortHigh As String
PortHigh = txtPortHigh.Text
Dim Ok As String
Ok = AtPort
WinsockPortScanner.Close
DoEvents
WinsockPortScanner.Connect txtIPHostscanner.Text, AtPort
DoEvents
If Not WinsockPortScanner.State = 7 Then
WinsockPortScanner.Close
AtPort = Ok + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
If AtPort = LimitSend Then
LimitSend = AtPort + 4000
Exit Sub
End If
If AtPort = PortHigh Then
Exit Sub
End If
Call CmdScan_Click
Exit Sub
Else
WinsockPortScanner.Close
AtPort = Ok + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
If AtPort = PortHigh Then
Exit Sub
End If
Call CmdScan_Click
End If
Else
WinsockPortScanner.Close
DoEvents
WinsockPortScanner.Connect txtIPHostscanner.Text, AtPort
DoEvents
TimerScanner.Enabled = True
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdStopRefresh_Click()
Start = "No"
TimerRefresh.Enabled = True
WinsockPortScanner.Close
CmdScan.Enabled = False
txtPortHigh.Text = 3000
txtPortLow.Text = 1
AtPort = 1
LimitSend = 4000
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdScanSpeed_Click()
Dim ScanSpeed As String
ScanSpeed = txtScanSpeed.Text
If lblShowsatwhatPort.Caption = "Pada Port: Tidak Terscan" Then
Else
MsgBox "Anda harus terlebih dahulu menghentikan scan."
Exit Sub
End If
If ScanSpeed < 1 Then
MsgBox "Kecepatan harus antara 1-1000"
Exit Sub
Else
GoTo ScanSpeedToHighCheck
End If
ScanSpeedToHighCheck:
If ScanSpeed > 1000 Then
MsgBox "Kecepatan harus antara 1-1000"
Exit Sub
Else
lblScanSpeed.Caption = "Kecepatan Scan: " & txtScanSpeed.Text
TimerScanner.Interval = txtScanSpeed.Text
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdSendDataServer_Click()
If WinsockConnectTest.State = 7 Then
Dim SendDataServer As String
SendDataServer = txtSendData.Text
WinsockConnectTest.SendData SendDataServer
Else
Beep
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Command1_Click()
frmMyIP.Show
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
Start = "Yes"
AtPort = 1
LimitSend = 4000
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
If frmPortScanner.Visible = False Then
Timer1.Enabled = False
cmdConnnect.Enabled = True
cmdListen.Enabled = True
DoEvents
WinsockConnectTest.Close
DoEvents
End
Else
Cancel = True
frmConnectionTest.Visible = False
Exit Sub
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub TimerRefresh_Timer()
Start = "Yes"
lblShowsatwhatPort.Caption = "Pada Port: Tidak Terscan"
CmdScan.Enabled = True
TimerRefresh.Enabled = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub TimerScanner_Timer()
Dim Ok As String
Ok = AtPort
If Not WinsockPortScanner.State = 7 Then
WinsockPortScanner.Close
AtPort = Ok + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
If AtPort = LimitSend Then
LimitSend = AtPort + 4000
Exit Sub
End If
If AtPort = PortHigh Then
Exit Sub
End If
Call CmdScan_Click
Exit Sub
Else
WinsockPortScanner.Close
AtPort = Ok + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
If AtPort = PortHigh Then
Exit Sub
End If
Call CmdScan_Click
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub txtPortLow_Change()
AtPort = txtPortLow.Text
LimitSend = AtPort + 4000
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockPortScanner_Connect()
txtPortsOpenLog.SelText = AtPort & vbCrLf
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockPortScanner_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Exit Sub
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdConnnect_Click()
cmdListen.Enabled = False
WinsockConnectTest.Close
WinsockConnectTest.Connect txtIPaddress.Text, txtTestPort
lblConnectionStatus.Caption = "Koneksi dari " & txtIPaddress.Text & " pada port " & txtTestPort.Text
Timer1.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdListen_Click()
cmdConnnect.Enabled = False
WinsockConnectTest.Close
WinsockConnectTest.LocalPort = txtTestPort.Text
WinsockConnectTest.Listen
lblConnectionStatus.Caption = "Dengarkan pada port " & txtTestPort.Text
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdCloseConnection_Click()
cmdConnnect.Enabled = True
cmdListen.Enabled = True
WinsockConnectTest.Close
lblConnectionStatus.Caption = "Koneksi Ditutup"
Timer1.Enabled = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub lblCheckConnection_Click()
If Not WinsockConnectTest.State = 7 Then
lblCheckConnection.Caption = "Koneksi: Tidak"
Else
lblCheckConnection.Caption = "Koneksi: Ya"
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub lblShowPortScanner_Click()
frmPortScanner.Show
End Sub
-----------------------------------------------------------------------------------------
Private Sub Timer1_Timer()
If Not WinsockConnectTest.State = 7 Then
lblConnectionStatus.Caption = "Koneksi Gagal"
WinsockConnectTest.Close
cmdConnnect.Enabled = True
cmdListen.Enabled = True
Timer1.Enabled = False
Else
If cmdListen.Enabled = True Then
lblConnectionStatus.Caption = "Terkoneksi"
End If
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockConnectTest_Connect()
lblConnectionStatus.Caption = "Koneksi dari " & txtIPaddress.Text & " pada port " & txtTestPort.Text
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockConnectTest_ConnectionRequest(ByVal requestID As Long)
If WinsockConnectTest.State <> sckClosed Then WinsockConnectTest.Close
WinsockConnectTest.Accept requestID
lblConnectionStatus.Caption = "Host telah terkoneksi..."
Timer1.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockConnectTest_DataArrival(ByVal bytesTotal As Long)
Dim ServerData As String
WinsockConnectTest.GetData ServerData, vbString
txtDataServer.SelStart = Len(txtDataServer.Text)
txtDataServer.SelText = ServerData
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockConnectTest_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Exit Sub
End Sub
    -  frmMyIP
     Script Code :
Option Explicit
-----------------------------------------------------------------------------------------
Private Sub cmdGetIP_Click()
On Error GoTo ErrroHere
Label2.Caption = "Status: Harap tunggu proses pencarian..."
Dim LengthToIP As Integer
Dim LengthToEndIP As Integer
Dim TotalLengthIP As Integer
Dim FinalIP As String
Dim Html As String
Dim HackData As String
Html = Inet1.OpenURL("http://www.whatismyip.com")
TotalLengthIP = Len(Html)
LengthToIP = InStr(1, Html, "is", 1) + 3
LengthToEndIP = InStr(LengthToIP, Html, " ", 1)
If LengthToEndIP > 0 Then
LengthToEndIP = (LengthToEndIP - LengthToIP)
FinalIP = Mid(Html, LengthToIP, LengthToEndIP)
HackData = "IP Internal = " & WinsockBot.LocalIP & " <|||> " & "IP Eksternal = " & FinalIP
Label2.Caption = "Status: IP address ditemukan / Tidak Error"
Else
HackData = "Error ketika mencoba untuk mendapatkan IP"
End If
text1.Text = HackData
Exit Sub
ErrroHere:
Label2.Caption = "Status: Error untuk menemukan IP Eksternal"
HackData = "IP Internal = " & WinsockBot.LocalIP & " <|||> " & "IP Eksternal = Pencarian-Error"
End Sub
    -  frmPortScanner
Script Code :
Dim AtPort As String
Dim Start As String
Dim Pause As Boolean
-----------------------------------------------------------------------------------------
Private Sub cmdClearLog_Click()
txtPortsOpenLog.Text = ""
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdPause_Click()
If cmdPause.Caption = "Pause" Then
cmdPause.Caption = "Lanjutkan"
Pause = True
Else
cmdPause.Caption = "Pause"
Pause = False
Call CmdScan_Click
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub CmdScan_Click()
Dim PortLow As String
PortLow = txtPortLow.Text
Dim PortHigh As String
PortHigh = txtPortHigh.Text
TimerScanner.Enabled = False
If Pause = True Then
lblShowsatwhatPort.Caption = "Pada port: " & AtPort & " Pause"
Exit Sub
End If
If Start = "No" Then
Exit Sub
End If
If AtPort = PortHigh Then
Exit Sub
End If
CmdScan.Enabled = False
If optLocal.Value = True Then
Do
If Start = "No" Then
Exit Sub
End If
WinsockPortScanner.Close
DoEvents
WinsockPortScanner.Connect txtIPHostscanner.Text, AtPort
DoEvents
If Not WinsockPortScanner.State = 7 Then
WinsockPortScanner.Close
AtPort = AtPort + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
Else
WinsockPortScanner.Close
AtPort = AtPort + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
End If
Loop Until AtPort = PortHigh
Else
WinsockPortScanner.Close
DoEvents
WinsockPortScanner.Connect txtIPHostscanner.Text, AtPort
DoEvents
TimerScanner.Enabled = True
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdStopRefresh_Click()
Start = "No"
TimerRefresh.Enabled = True
WinsockPortScanner.Close
CmdScan.Enabled = False
txtPortHigh.Text = 3000
txtPortLow.Text = 1
AtPort = 1
LimitSend = 4000
cmdPause.Caption = "Pause"
Pause = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdScanSpeed_Click()
Dim ScanSpeed As String
ScanSpeed = txtScanSpeed.Text
If lblShowsatwhatPort.Caption = "Pada Port: Tidak Terscan" Then
Else
MsgBox "Anda harus terlebih dahulu menghentikan scan saat ini."
Exit Sub
End If
If ScanSpeed < 1 Then
MsgBox "Kecepatan harus antara 1-1000"
Exit Sub
Else
GoTo ScanSpeedToHighCheck
End If
ScanSpeedToHighCheck:
If ScanSpeed > 1000 Then
MsgBox "Kecepatan harus antara 1-1000"
Exit Sub
Else
lblScanSpeed.Caption = "Kecepatan Scan: " & txtScanSpeed.Text
TimerScanner.Interval = txtScanSpeed.Text
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
Start = "Yes"
AtPort = 1
LimitSend = 4000
Pause = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
If frmConnectionTest.Visible = False Then
TimerRefresh.Enabled = False
TimerScanner.Enabled = False
WinsockPortScanner.Close
End
Else
Cancel = True
frmPortScanner.Visible = False
Exit Sub
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub lblShowConnectionTest_Click()
frmConnectionTest.Show
End Sub
-----------------------------------------------------------------------------------------
Private Sub TimerRefresh_Timer()
Start = "Yes"
lblShowsatwhatPort.Caption = "Pada Port: Tidak Terscan"
CmdScan.Enabled = True
TimerRefresh.Enabled = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub TimerScanner_Timer()
If Pause = True Then
lblShowsatwhatPort.Caption = "Pada port: " & AtPort & " Pause"
TimerScanner.Enabled = False
Exit Sub
End If
If Start = "No" Then
TimerScanner.Enabled = False
Exit Sub
End If
If AtPort = PortHigh Then
Exit Sub
End If
If Not WinsockPortScanner.State = 7 Then
WinsockPortScanner.Close
AtPort = AtPort + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
WinsockPortScanner.Close
DoEvents
WinsockPortScanner.Connect txtIPHostscanner.Text, AtPort
DoEvents
Exit Sub
Else
WinsockPortScanner.Close
AtPort = AtPort + 1
lblShowsatwhatPort.Caption = "Pada port: " & AtPort
If AtPort = PortHigh Then
Exit Sub
End If
WinsockPortScanner.Close
DoEvents
WinsockPortScanner.Connect txtIPHostscanner.Text, AtPort
DoEvents
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub txtPortLow_Change()
AtPort = txtPortLow.Text
LimitSend = AtPort + 4000
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockPortScanner_Connect()
txtPortsOpenLog.SelStart = Len(txtPortsOpenLog.Text)
txtPortsOpenLog.SelText = AtPort & vbCrLf
End Sub
-----------------------------------------------------------------------------------------
Private Sub WinsockPortScanner_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Exit Sub
End Sub
Sekian dulu informasi dari saya, bila ada pertanyaan bisa lewat kotak komentar.
Terima kasih, semoga bermanfaat!
Selengkapnya...

Script Code : Buat Form Blocker

Di sini saya akan berbagi dengan Script Coding Program, Program yang digunakan dalam Script ini terutama Bahasa Pemprograman VB (VisualBasic), sebenarnya hampir sama dengan Bahasa Pemprograman Java dan Visual Foxpro, hanya memgganti sedikit perintah-perintahnya saja. Script Coding yang akan saya bagikan ini, tentang pemblokiran situs-situs baik itu situs yang mengandung virus yang dapat merusak PC maupun situs yang berbau porno. Jika anda berminat ingin belajar Bahasa Pemprograman ini, anda bisa mengikuti langkah-langkah berikut. Oya, anda tinggal mengklik menu dibawah ini!
1. Forms
    -  frm_Main(frm_Main.frm)
    -  frm_Splash(frm_Splash.frm)
2. Modules
    -  Fungsi(Fungsi.bas)
    -  Registry(Registry.bas)
    -  tray(tray.bas)
3. User Controls
    -  XpButton(XpButton.ctl)

--------------------------------------------------------------------------------------------------
1.  Forms
     -  frm_Main
        Keterangan Gambar tentang Pengaturan Pemblokiran Berdasarkan Alamat Situs.

          Keterangan Gambar tentang Pengaturan Pemblokiran Berdasarkan Caption.

    Script Code :
Private Sub cmd_add_Click()
Dim cari As Long
If Text1.Text = "" Then
MsgBox "Anda belum memasukan situs yang akan diblokir", vbInformation + vbOKOnly, "(punya-rizal.blogspot.com)The Porn Blocker"
Exit Sub
End If
For cari = 0 To List1.ListCount - 1
If Text1.Text = List1.list(cari) Then
MsgBox "Situs yang anda masukan sudah ada dalam daftar situs yang diblokir", vbInformation + vbOKOnly, "(punya-rizal.blogspot.com)The Porn Blocker"
Exit Sub
End If
Text1.SetFocus
Next
List1.AddItem Text1.Text
Text1.Text = ""
SaveFileHost List1, GetSystemPath & "\drivers\etc\Hosts"
lbl_jml.Caption = List1.ListCount
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_addcap_Click()
Dim cari As Long
If txt_blokcap.Text = "" Then
MsgBox "Anda belum memasukan caption yang akan diblokir", vbInformation + vbOKOnly, "(punya-rizal.blogspot.com)The Porn Blocker"
Exit Sub
End If
For cari = 0 To lst_cap.ListCount - 1
If txt_blokcap.Text = lst_cap.list(cari) Then
MsgBox "Caption yang anda masukan sudah ada dalam daftar caption yang diblokir", vbInformation + vbOKOnly, "(punya-rizal.blogspot.com)The Porn Blocker"
txt_blokcap.SetFocus
Exit Sub
End If
Next
lst_cap.AddItem txt_blokcap.Text
txt_blokcap.Text = ""
SaveCaption lst_cap, App.Path & "\list.txt"
lbl_jmlcap.Caption = lst_cap.ListCount
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_atur_Click()
Frame1.Visible = True
Frame1.Enabled = True
Framecap.Visible = False
Framecap.Enabled = False
lbl_jml.Caption = List1.ListCount
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_aturcap_Click()
Frame1.Visible = False
Frame1.Enabled = False
Framecap.Visible = True
Framecap.Enabled = True
lbl_jmlcap.Caption = lst_cap.ListCount
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_delcap_Click()
If lst_cap.ListIndex = -1 Then
MsgBox "Anda belum memilih situs yang akan dihapus", vbInformation + vbOKOnly, "(punya-rizal.blogspot.com)The Porn Blocker"
Exit Sub
End If
lst_cap.RemoveItem (lst_cap.ListIndex)
HapusCaption lst_cap, App.Path & "\list.txt"
Call cmd_refreshcap_Click
lbl_jmlcap.Caption = lst_cap.ListCount
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_exit_Click()
If MsgBox("Apakah anda yakin ingin keluar dari aplikasi ini?" & vbNewLine & "Keluar dari aplikasi ini berarti proses pemblokiran dihentikan", vbInformation + vbYesNo, "(punya-rizal.blogspot.com)The Porn Blocker") = vbYes Then
TrayDelete
backup
Kill App.Path & "\kill.bat"
End
Else
Exit Sub
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_hapus_Click()
If List1.ListIndex = -1 Then
MsgBox "Anda belum memilih situs yang akan dihapus", vbInformation + vbOKOnly, "(punya-rizal.blogspot.com)The Porn Blocker"
Exit Sub
End If
List1.RemoveItem (List1.ListIndex)
hapus List1, GetSystemPath & "\drivers\etc\Hosts"
Call cmd_refresh_Click
lbl_jml.Caption = List1.ListCount
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_hide_Click()
App.TaskVisible = False
ilang.Enabled = True
frm_main.Hide
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmd_refresh_Click()
List1.Clear
LoadFileHost List1, GetSystemPath & "\drivers\etc\Hosts"
Text1.Text = ""
Text1.SetFocus
lbl_jml.Caption = List1.ListCount
End Sub
Private Sub cmd_refreshcap_Click()
lst_cap.Clear
Load_Caption lst_cap, App.Path & "\list.txt"
txt_blokcap.Text = ""
txt_blokcap.SetFocus
lbl_jmlcap.Caption = lst_cap.ListCount
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_DblClick()
MsgBox "Copyright (C) YaDoY SofTwaRe DeVeLoPmEnT 2007", vbOKOnly + vbInformation, "(punya-rizal.blogspot.com)The Porn Blocker"
End Sub
Private Sub Form_Load()
mulai
TrayAdd hwnd, Picture1.Picture, "The Porn Blocker", MouseMove
Frame1.Visible = True
Frame1.Enabled = True
Framecap.Visible = False
Framecap.Enabled = False
LoadFileHost List1, GetSystemPath & "\drivers\etc\Hosts"
lbl_jml.Caption = List1.ListCount
lst_cap.Clear
Load_Caption lst_cap, App.Path & "\list.txt"
lbl_jmlcap.Caption = lst_cap.ListCount
CreateStringValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run\", REG_SZ, "Porn Blocker", "C:\Program Files\Porn_Blocker\Porn Blocker.exe"
buat_kill
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
TrayDelete
backup
Kill App.Path & "\kill.bat"
End
End Sub
-----------------------------------------------------------------------------------------
Private Sub Frame1_Click()
Text1.SetFocus
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Dim cEvent As Single
cEvent = x / Screen.TwipsPerPixelX
Select Case cEvent
Case MouseMove
Debug.Print "MouseMove"
Case LeftUp
Debug.Print "Left Up"
Case LeftDown
Debug.Print "LeftDown"
Case LeftDbClick
Debug.Print "LeftDbClick"
Case MiddleUp
Debug.Print "MiddleUp"
Case MiddleDown
Debug.Print "MiddleDown"
Case MiddleDbClick
Debug.Print "MiddleDbClick"
Case RightUp
Debug.Print "RightUp": PopupMenu mnu
Case RightDown
Debug.Print "RightDown"
Case RightDbClick
Debug.Print "RightDbClick"
End Select
End Sub
-----------------------------------------------------------------------------------------
Private Sub ilang_Timer()
On Error Resume Next
Dim bunuh As Long
frm_main.show
App.TaskVisible = False
For bunuh = 0 To lst_cap.ListCount - 1
kill_IE (lst_cap.list(bunuh))
Tonjok (lst_cap.list(bunuh))
Next
End Sub
-----------------------------------------------------------------------------------------
Private Sub kill_task_Timer()
Hajar "TASK MANAGER"
Hajar "CMD"
Hajar "Command Prompt"
End Sub
-----------------------------------------------------------------------------------------
Private Sub show_Click()
frm_main.show
End Sub
-----------------------------------------------------------------------------------------
Private Sub buat_kill()
Open App.Path & "\kill.bat" For Output As #1
Print #1, "taskkill /f /im iexplore.exe"
Close #1
End Sub
     -  frm_Splash
    Script Code :
Private Sub Form_Load()
ProgressBar1.Value = ProgressBar1.Min
End Sub
-----------------------------------------------------------------------------------------
Private Sub Timer1_Timer()
ProgressBar1.Value = ProgressBar1.Value + 5
If ProgressBar1.Value = 10 Then
Label3.Caption = "Application Initialazing"
End If
If ProgressBar1.Value = 40 Then
Label3.Caption = "Loading Database"
End If
If ProgressBar1.Value = 80 Then
Label3.Caption = "Loading Complete"
End If
If ProgressBar1.Value >= ProgressBar1.Max Then
Unload Me
frm_main.show
End If
End Sub
2.  Modules
     -  Fungsi

    Script Code :
Public Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Const WM_CLOSE = &H10
Public IP As String, Situs As String
Public x As String, Judul As String
-----------------------------------------------------------------------------------------
Public Sub LoadFileHost(list As ListBox, Namafile As String)
Dim linestr As String, tmp() As String
On Error Resume Next
Open Namafile For Input As #1
While Not EOF(1)
Line Input #1, linestr
tmp = Split(linestr, " ")
IP = tmp(0)
Situs = tmp(1)
DoEvents
list.AddItem Situs
Wend
Close #1
End Sub
-----------------------------------------------------------------------------------------
Public Sub Load_Caption(list As ListBox, Namafile As String)
Dim linestr As String, tmp() As String
On Error Resume Next
Open Namafile For Input As #1
While Not EOF(1)
Line Input #1, linestr
Judul = linestr
DoEvents
list.AddItem Judul
Wend
Close #1
End Sub
-----------------------------------------------------------------------------------------
Public Sub SaveFileHost(list As ListBox, place As String)
On Error Resume Next
Dim simpan As Long
Open place For Output As #1
For simpan = 0 To list.ListCount - 1
Print #1, "127.0.0.1 " & list.list(simpan)
Next
Close #1
End Sub
-----------------------------------------------------------------------------------------
Public Sub SaveCaption(list As ListBox, place As String)
On Error Resume Next
Dim simpan As Long
Open place For Output As #1
For simpan = 0 To list.ListCount - 1
Print #1, list.list(simpan)
Next
Close #1
End Sub
-----------------------------------------------------------------------------------------
Public Sub hapus(list As ListBox, place As String)
On Error Resume Next
Dim hapus As Long
Open place For Output As #1
For hapus = 0 To list.ListCount - 1
Print #1, "127.0.0.1 " & list.list(hapus)
Next
Close #1
End Sub
-----------------------------------------------------------------------------------------
Public Sub HapusCaption(list As ListBox, place As String)
On Error Resume Next
Dim hapus As Long
Open place For Output As #1
For hapus = 0 To list.ListCount - 1
Print #1, list.list(hapus)
Next
Close #1
End Sub
-----------------------------------------------------------------------------------------
Public Sub backup()
FileCopy GetSystemPath & "\Drivers\etc\Hosts", App.Path & "\back.txt"
Open GetSystemPath & "\Drivers\etc\Hosts" For Output As #1
Print #1, "127.0.0.1 localhost"
Close #1
End Sub
-----------------------------------------------------------------------------------------
Public Sub mulai()
On Error Resume Next
FileCopy App.Path & "\back.txt", GetSystemPath & "\Drivers\etc\Hosts"
FileCopy App.Path & "back.txt", GetSystemPath & "\Drivers\etc\Hosts"
End Sub
-----------------------------------------------------------------------------------------
Public Function GetSystemPath() As String
On Error Resume Next
Dim Buffer As String * 255
Dim x As Long
x = GetSystemDirectory(Buffer, 255)
GetSystemPath = Left(Buffer, x) & "\"
End Function
-----------------------------------------------------------------------------------------
Public Function Hajar(target As String)
Dim h As Long
Dim t As String * 255
h = GetForegroundWindow
GetWindowText h, t, 255
If InStr(UCase(t), UCase(target)) > 0 Then
SendMessage h, WM_CLOSE, 0, 0
MsgBox "Maaf perintah yang coba anda jalankan telah dinonaktifkan oleh administrator komputer ini. Silahkan menghubungi administrator untuk mengaktifkannya kembali", vbInformation + vbOKOnly, "Pembatasan"
End If
End Function
-----------------------------------------------------------------------------------------
Public Sub Tonjok(target As String)
Dim h As Long
Dim t As String * 255
h = GetForegroundWindow
GetWindowText h, t, 255
If InStr(UCase(t), UCase(target)) > 0 Then
SendMessage h, WM_CLOSE, 0, 0
End If
End Sub
-----------------------------------------------------------------------------------------
Public Sub kill_IE(target As String)
Dim h As Long
Dim t As String * 255
h = GetForegroundWindow
GetWindowText h, t, 255
If InStr(UCase(t), UCase(target)) > 0 Then
Shell App.Path & "\kill.bat", vbHide
End If
End Sub
    Registry

    Script Code :
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Public Const REG_DWORD = 4
Enum REG
HKEY_CURRENT_USER = &H80000001
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
End Enum
Enum TypeStringValue
REG_SZ = 1
REG_EXPAND_SZ = 2
REG_MULTI_SZ = 7
End Enum
-----------------------------------------------------------------------------------------
Public Function DeleteValue(hKey As REG, Subkey As String, lpValName As String) As Long
Dim Ret As Long
On Error Resume Next
RegOpenKey hKey, Subkey, Ret
DeleteValue = RegDeleteValue(Ret, lpValName)
RegCloseKey Ret
End Function
-----------------------------------------------------------------------------------------
Public Function CreateStringValue(hKey As REG, Subkey As String, RTypeStringValue As TypeStringValue, strValueName As String, strData As String) As Long
On Error Resume Next
Dim Ret As Long
RegCreateKey hKey, Subkey, Ret
CreateStringValue = RegSetValueEx(Ret, strValueName, 0, RTypeStringValue, ByVal strData, Len(strData))
RegCloseKey Ret
End Function
    -  tray

    Script Code :
Option Explicit
Const NIF_MESSAGE As Long = &H1
Const NIF_ICON As Long = &H2
Const NIF_TIP As Long = &H4
Const NIM_ADD As Long = &H0
Const NIM_MODIFY As Long = &H1
Const NIM_DELETE As Long = &H2
Private Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Public Enum TrayRetunEventEnum
MouseMove = &H200
LeftUp = &H202
LeftDown = &H201
LeftDbClick = &H203
RightUp = &H205
RightDown = &H204
RightDbClick = &H206
MiddleUp = &H208
MiddleDown = &H207
MiddleDbClick = &H209
End Enum
Public Enum ModifyItemEnum
ToolTip = 1
Icon = 2
End Enum
Private TrayIcon As NOTIFYICONDATA
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
-----------------------------------------------------------------------------------------
Public Sub TrayAdd(hwnd As Long, Icon As Picture, _
ToolTip As String, ReturnCallEvent As TrayRetunEventEnum)

With TrayIcon
.cbSize = Len(TrayIcon)
.hwnd = hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = ReturnCallEvent
.hIcon = Icon
.szTip = ToolTip & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, TrayIco
n End Sub
-----------------------------------------------------------------------------------------
Public Sub TrayDelete()
Shell_NotifyIcon NIM_DELETE, TrayIcon
End Sub
-----------------------------------------------------------------------------------------
Public Sub TrayModify(Item As ModifyItemEnum, vNewValue As Variant)
Select Case Item
Case ToolTip
TrayIcon.szTip = vNewValue & vbNullChar
Case Icon
TrayIcon.hIcon = vNewValue
End Select
Shell_NotifyIcon NIM_MODIFY, TrayIcon
End Sub
3.  User Controls
     -  XpButton
    Script Code :
Option Explicit
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Const RGN_DIFF = 4
Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_CENTER = &H1
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
Y As Long
End Type
Public Event Click()
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseOver()
Public Event MouseOut()
Private rc As RECT
Private W As Long, h As Long
Private rgMain As Long, rgn1 As Long
Private isOver As Boolean
Private flgHover As Integer
Private flgFocus As Boolean
Private LastButton As Integer
Private LastKey As Integer
Private r As Long, l As Long, t As Long, b As Long
Private mEnabled As Boolean
Private mCaption As String
Private mForeHover As OLE_COLOR
-----------------------------------------------------------------------------------------
Private Sub DrawButton()
Dim pt As POINTAPI, pen As Long, hpen As Long
With UserControl
hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 1, pt
LineTo .hdc, l + 2, t
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, t, pt
LineTo .hdc, l, t + 2
SelectObject .hdc, pen
DeleteObject hpen
SetPixel .hdc, l, t + 2, RGB(37, 87, 131)
SetPixel .hdc, l + 1, t + 2, RGB(191, 206, 220)
SetPixel .hdc, l + 2, t + 1, RGB(192, 207, 221)
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, t, pt
LineTo .hdc, r - 2, t
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r - 2, t, pt
LineTo .hdc, r + 1, t + 3
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r - 1, t, pt
LineTo .hdc, r, t + 2
SetPixel .hdc, r, t + 1, RGB(122, 149, 168)
SetPixel .hdc, r - 2, t + 1, RGB(213, 223, 232)
SetPixel .hdc, r - 1, t + 2, RGB(191, 206, 219)
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r, t + 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r, b - 3, pt
LineTo .hdc, r - 3, b
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r, b - 2, pt
LineTo .hdc, r - 2, b
SetPixel .hdc, r - 2, b - 2, RGB(177, 183, 182)
SetPixel .hdc, r - 1, b - 3, RGB(182, 189, 189)
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, b - 1, pt
LineTo .hdc, r - 2, b - 1
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 3, pt
LineTo .hdc, l + 3, b
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 2, pt
LineTo .hdc, l + 2, b
SetPixel .hdc, l + 1, b - 3, RGB(191, 199, 202)
SetPixel .hdc, l + 2, b - 2, RGB(163, 174, 180)
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 3, pt
LineTo .hdc, l, b - 3
SelectObject .hdc, pen
DeleteObject hpen
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub DrawFocus()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
hpen = CreatePen(PS_SOLID, 1, RGB(206, 231, 251))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, t + 1, pt
LineTo .hdc, r - 1, t + 1
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(188, 212, 246))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, t + 2, pt
LineTo .hdc, r, t + 2
SelectObject .hdc, pen
DeleteObject hpen
ColorR = 186
ColorG = 211
ColorB = 246
For i = t + 3 To b - 4 Step 1
hpen = CreatePen(PS_SOLID, 2, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, i, pt
LineTo .hdc, l + 2, i + 1
MoveToEx .hdc, r - 1, i, pt
LineTo .hdc, r - 1, i + 1
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 228 Then
ColorR = ColorR - 4
ColorG = ColorG - 3
ColorB = ColorB - 1
End If
Next i
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, b - 3, pt
LineTo .hdc, r - 1, b - 3
SelectObject .hdc, pen
DeleteObject hpen
SetPixel .hdc, l + 2, b - 2, RGB(77, 125, 193)
hpen = CreatePen(PS_SOLID, 1, RGB(97, 125, 229))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, b - 2, pt
LineTo .hdc, r - 2, b - 2
SetPixel .hdc, r - 2, b - 2, RGB(77, 125, 193)
SelectObject .hdc, pen
DeleteObject hpen
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub DrawHighlight()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
hpen = CreatePen(PS_SOLID, 1, RGB(255, 240, 207))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, t + 1, pt
LineTo .hdc, r - 1, t + 1
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(253, 216, 137))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, t + 2, pt
LineTo .hdc, r, t + 2
SelectObject .hdc, pen
DeleteObject hpen
ColorR = 254
ColorG = 223
ColorB = 154
For i = t + 2 To b - 3 Step 1
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, i, pt
LineTo .hdc, l + 1, i + 1
MoveToEx .hdc, r - 1, i, pt
LineTo .hdc, r - 1, i + 1
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 49 Then
ColorR = ColorR - 1
ColorG = ColorG - 3
ColorB = ColorB - 7
End If
Next i
ColorR = 252
ColorG = 210
ColorB = 121
For i = t + 3 To b - 3 Step 1
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, i, pt
LineTo .hdc, l + 2, i + 1
MoveToEx .hdc, r - 2, i, pt
LineTo .hdc, r - 2, i + 1
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 57 Then
ColorR = ColorR - 1
ColorG = ColorG - 4
ColorB = ColorB - 8
End If
Next i
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, b - 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(229, 151, 0))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, b - 2, pt
LineTo .hdc, r - 1, b - 2
SelectObject .hdc, pen
DeleteObject hpen
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub DrawButtonFace()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3
ColorR = 255
ColorG = 255
ColorB = 253
For i = t + 3 To b - 3 Step 1
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, i, pt
LineTo .hdc, r, i
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 230 Then
ColorR = ColorR - 1
ColorG = ColorG - 1
ColorB = ColorB - 1
End If
Next i
hpen = CreatePen(PS_SOLID, 1, RGB(214, 208, 197))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 2, pt
LineTo .hdc, r, b - 2
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(226, 223, 214))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(236, 235, 230))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 4, pt
LineTo .hdc, r, b - 4
SelectObject .hdc, pen
DeleteObject hpen
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub DrawButtonDown()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3
ColorR = 239
ColorG = 238
ColorB = 231
For i = t + 3 To b - 2 Step 4
hpen = CreatePen(PS_SOLID, 4, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, i, pt
LineTo .hdc, r, i
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 218 Then
ColorR = ColorR - 1
ColorG = ColorG - 1
ColorB = ColorB - 1
End If
Next i
hpen = CreatePen(PS_SOLID, 1, RGB(209, 204, 192))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 1, pt
LineTo .hdc, r, t + 1
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(220, 216, 207))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 2, pt
LineTo .hdc, r, t + 2
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(234, 233, 227))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID, 1, RGB(242, 241, 238))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 2, pt
LineTo .hdc, r, b - 2
SelectObject .hdc, pen
DeleteObject hpen
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub DrawButtonDisabled()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
Dim hBrush As Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3
hBrush = CreateSolidBrush(RGB(245, 244, 234))
FillRect UserControl.hdc, rc, hBrush
DeleteObject hBrush
hBrush = CreateSolidBrush(RGB(201, 199, 186))
FrameRect UserControl.hdc, rc, hBrush
DeleteObject hBrush
SetPixel .hdc, l, t + 1, RGB(216, 213, 199)
SetPixel .hdc, l + 1, t + 1, RGB(216, 213, 199)
SetPixel .hdc, l + 1, t, RGB(216, 213, 199)
SetPixel .hdc, l + 1, t + 2, RGB(234, 233, 222)
SetPixel .hdc, l + 2, t + 1, RGB(234, 233, 222)
SetPixel .hdc, r - 1, t, RGB(216, 213, 199)
SetPixel .hdc, r - 1, t + 1, RGB(216, 213, 199)
SetPixel .hdc, r, t + 1, RGB(216, 213, 199)
SetPixel .hdc, r - 2, t + 1, RGB(234, 233, 222)
SetPixel .hdc, r - 1, t + 2, RGB(234, 233, 222)
SetPixel .hdc, l, b - 2, RGB(216, 213, 199)
SetPixel .hdc, l + 1, b - 2, RGB(216, 213, 199)
SetPixel .hdc, l + 1, b - 1, RGB(216, 213, 199)
SetPixel .hdc, l + 1, b - 3, RGB(234, 233, 222)
SetPixel .hdc, l + 2, b - 2, RGB(234, 233, 222)
SetPixel .hdc, r, b - 2, RGB(216, 213, 199)
SetPixel .hdc, r - 1, b - 2, RGB(216, 213, 199)
SetPixel .hdc, r - 1, b - 1, RGB(216, 213, 199)
SetPixel .hdc, r - 1, b - 3, RGB(234, 233, 222)
SetPixel .hdc, r - 2, b - 2, RGB(234, 233, 222)
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub DrawButton2()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
Dim hBrush As Long
With UserControl
hBrush = CreateSolidBrush(RGB(0, 60, 116))
FrameRect UserControl.hdc, rc, hBrush
DeleteObject hBrush
SetPixel .hdc, l, t + 1, RGB(122, 149, 168)
SetPixel .hdc, l + 1, t + 1, RGB(37, 87, 131)
SetPixel .hdc, l + 1, t, RGB(122, 149, 168)
SetPixel .hdc, r - 1, t, RGB(122, 149, 168)
SetPixel .hdc, r - 1, t + 1, RGB(37, 87, 131)
SetPixel .hdc, r, t + 1, RGB(122, 149, 168)
SetPixel .hdc, l, b - 2, RGB(122, 149, 168)
SetPixel .hdc, l + 1, b - 2, RGB(37, 87, 131)
SetPixel .hdc, l + 1, b - 1, RGB(122, 149, 168)
SetPixel .hdc, r, b - 2, RGB(122, 149, 168)
SetPixel .hdc, r - 1, b - 2, RGB(37, 87, 131)
SetPixel .hdc, r - 1, b - 1, RGB(122, 149, 168)
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub RedrawButton(Optional ByVal Stat As Integer = -1)
If mEnabled Then
If Stat = 1 And LastButton = 1 Then
DrawButtonDown
Else
DrawButtonFace
If isOver = True Then
DrawHighlight
Else
If flgFocus = True Then
DrawFocus
End If
End If
End If
DrawButton2
Else
DrawButtonDisabled
End If
DrawCaption
MakeRegion
End Sub
-----------------------------------------------------------------------------------------
Private Sub DrawCaption()
Dim vh As Long, rcTxt As RECT
With UserControl
GetClientRect .hwnd, rcTxt
If mEnabled Then
If isOver Then
SetTextColor .hdc, mForeHover
Else
SetTextColor .hdc, .ForeColor
End If
Else
SetTextColor .hdc, RGB(161, 161, 146)
End If
vh = DrawText(.hdc, mCaption, Len(mCaption), rcTxt, DT_CALCRECT Or DT_CENTER Or DT_WORDBREAK)
SetRect rcTxt, 0, (.ScaleHeight * 0.5) - (vh * 0.5), .ScaleWidth, (.ScaleHeight * 0.5) + (vh * 0.5)
DrawText .hdc, mCaption, Len(mCaption), rcTxt, DT_CENTER Or DT_WORDBREAK
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub HoverTimer_Timer()
If Not isMouseOver Then
HoverTimer.Enabled = False
isOver = False
flgHover = 0
RedrawButton 0
RaiseEvent MouseOut
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
LastButton = 1
Call UserControl_Click
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_Click()
If LastButton = 1 Then
RedrawButton 0
UserControl.Refresh
RaiseEvent Click
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_DblClick()
If LastButton = 1 Then
Call UserControl_MouseDown(1, 0, 0, 0)
SetCapture hwnd
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_GotFocus()
flgFocus = True
RedrawButton 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_InitProperties()
Set UserControl.Font = Ambient.Font
mCaption = Ambient.DisplayName
mEnabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
LastKey = KeyCode
Select Case KeyCode
Case vbKeySpace, vbKeyReturn
RedrawButton 1
Case vbKeyLeft, vbKeyRight
SendKeys "{Tab}"
Case vbKeyDown, vbKeyUp
SendKeys "+{Tab}"
End Select
RaiseEvent KeyDown(KeyCode, Shift)
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
If ((KeyCode = vbKeySpace) And (LastKey = vbKeySpace)) Or ((KeyCode = vbKeyReturn) And (LastKey = vbKeyReturn)) Then
RedrawButton 0
LastButton = 1
UserControl.Refresh
RaiseEvent Click
End If
RaiseEvent KeyUp(KeyCode, Shift)
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_LostFocus()
flgFocus = False
RedrawButton 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
If mEnabled = True Then
LastButton = Button
UserControl.Refresh
If Button <> 2 Then RedrawButton 1
RaiseEvent MouseDown(Button, Shift, x, Y)
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button < 2 Then
If Not isMouseOver Then
If flgHover = 0 Then Exit Sub
RedrawButton 0
Else
If flgHover = 1 Then Exit Sub
flgHover = 1
If Button = 0 And Not isOver Then
HoverTimer.Enabled = True
isOver = True
flgHover = 0
RedrawButton 0
RaiseEvent MouseOver
ElseIf Button = 1 Then
isOver = True
RedrawButton 1
isOver = False
End If
End If
End If
RaiseEvent MouseMove(Button, Shift, x, Y)
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
RedrawButton 0
UserControl.Refresh
RaiseEvent MouseUp(Button, Shift, x, Y)
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_Resize()
GetClientRect UserControl.hwnd, rc
With rc
r = .Right - 1: l = .Left: t = .Top: b = .Bottom
W = .Right: h = .Bottom
End With
RedrawButton 0
End Sub
-----------------------------------------------------------------------------------------
Private Function isMouseOver() As Boolean
Dim pt As POINTAPI
GetCursorPos pt
isMouseOver = (WindowFromPoint(pt.x, pt.Y) = hwnd)
End Function
-----------------------------------------------------------------------------------------
Private Sub MakeRegion()
DeleteObject rgMain
rgMain = CreateRectRgn(0, 0, W, h)
rgn1 = CreateRectRgn(0, 0, 1, 1)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(0, h - 1, 1, h)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(W - 1, 0, W, 1)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(W - 1, h - 1, W, h)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
SetWindowRgn UserControl.hwnd, rgMain, True
End Sub
-----------------------------------------------------------------------------------------
Public Property Get Enabled() As Boolean
Enabled = mEnabled
End Property
-----------------------------------------------------------------------------------------
Public Property Let Enabled(ByVal NewValue As Boolean)
mEnabled = NewValue
PropertyChanged "Enabled"
UserControl.Enabled = NewValue
RedrawButton 0
End Property
-----------------------------------------------------------------------------------------
Public Property Get Font() As Font
Set Font = UserControl.Font
End Property
-----------------------------------------------------------------------------------------
Public Property Set Font(ByVal NewValue As Font)
Set UserControl.Font = NewValue
RedrawButton 0
PropertyChanged "Font"
End Property
-----------------------------------------------------------------------------------------
Public Property Get Caption() As String
Caption = mCaption
End Property
-----------------------------------------------------------------------------------------
Public Property Let Caption(ByVal NewValue As String)
mCaption = NewValue
RedrawButton 0
SetAccessKeys
PropertyChanged "Caption"
End Property
-----------------------------------------------------------------------------------------
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property
-----------------------------------------------------------------------------------------
Public Property Let ForeColor(ByVal NewValue As OLE_COLOR)
UserControl.ForeColor = NewValue
RedrawButton 0
PropertyChanged "ForeColor"
End Property
-----------------------------------------------------------------------------------------
Public Property Get ForeHover() As OLE_COLOR
ForeHover = mForeHover
End Property
-----------------------------------------------------------------------------------------
Public Property Let ForeHover(ByVal NewValue As OLE_COLOR)
mForeHover = NewValue
PropertyChanged "ForeHover"
End Property
-----------------------------------------------------------------------------------------
Private Sub UserControl_Show()
RedrawButton 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
With PropBag
mEnabled = .ReadProperty("Enabled", True)
Set UserControl.Font = .ReadProperty("Font", Ambient.Font)
mCaption = .ReadProperty("Caption", Ambient.DisplayName)
UserControl.ForeColor = .ReadProperty("ForeColor", Ambient.ForeColor)
mForeHover = .ReadProperty("ForeHover", UserControl.ForeColor)
End With
UserControl.Enabled = mEnabled
SetAccessKeys
End Sub
-----------------------------------------------------------------------------------------
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
.WriteProperty "Enabled", mEnabled, True
.WriteProperty "Font", UserControl.Font, Ambient.Font
.WriteProperty "Caption", mCaption, Ambient.DisplayName
.WriteProperty "ForeColor", UserControl.ForeColor
.WriteProperty "ForeHover", mForeHover, Ambient.ForeColor
End With
End Sub
-----------------------------------------------------------------------------------------
Private Sub SetAccessKeys()
Dim i As Long
UserControl.AccessKeys = ""
If Len(mCaption) > 1 Then
i = InStr(1, mCaption, "&", vbTextCompare)
If (i < Len(mCaption)) And (i > 0) Then
If Mid$(mCaption, i + 1, 1) <> "&" Then
UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
Else
i = InStr(i + 2, mCaption, "&", vbTextCompare)
If Mid$(mCaption, i + 1, 1) <> "&" Then
UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
End If
End If
End If
End If
End Sub
Selengkapnya...
 
Copyright © 2011 - 2012 Blogger templates by Rizal