Block Launch Application

Aplikasi ini berguna utk memblok semua yg berbau virus. Yah masih manual sih buat hapusnya...tapi lumayanlah biar aplikasi tak berjalan dan membuat PC atau Laptop kita tidak hang...Aplikasi ini dapat berjalan pada Windows XP dan Windows 7. Ada beberapa fitur yg disediakan.... masih banyak kekurangan mohon bantuan teman2 tuk memberikan pendapat tentang program saya ini. Cara penggunaannya cukup gampang...
1.jalankan Aplikasi Block Lauch Application , dengan mengklik 2x.
2.setelah Block Lauch Application aktif, berikan centang pada bagian "BLOCK ALL FILE EXE".
3. setelah tercentang coba anda jalankan aplikasi Winamp,Windows media player,dsb. maka file semua aplikasi tersebut tak akan berjalan dan menampilkan pesan error. dalam hal ini aplikasi saia berjalan dengan baik dan hanya aplikasi saia saja yg tidak menampilkan tulisan error...

History Update :
Block Lauch Application Versi 1.1.2
- Memiliki Fitur "VALID EXE FILE LIST"

Block Lauch Application Versi 1.2.0
- Menghapus 1 (satu) Fitur "VALID EXE FILE LIST"
- Menambahkan Fitur "Delete FILE".
- Menambahkan Fitur "Open Explore"
- Menambahkan Fitur "List Block File EXE"

Block Lauch Application Versi 1.2.1 : Download
- Menambahkan Fitur "VALID EXE FILE LIST"
- Menambahkan Fitur "Delete FILE"
- Menambahkan Fitur "Open Explore"
- Menambahkan Fitur "List Block File EXE"

Block Lauch Application Versi 1.2.5
- Menambahkan Fitur "VALID EXE FILE LIST"
- Menambahkan Fitur "Delete FILE"
- Menambahkan Fitur "Open Explore"
- Menambahkan Fitur "List Block File EXE"
- Menambahkan Fitur "History Block EXE"
- Menambahkan Fitur "Block In Drives"

Block Lauch Application Versi 2.1.0
- Menambahkan Fitur "UnBlock File n Folder" in Block Extension
  * tempat data2 File atau Folder yang tidak akan diBlock
- Menambahkan Fitur "Block Drive" in Block Extension
  * Fitur ini berguna untuk memblock beberapa Drive atau semua Drive di explorer
- Menambahkan Fitur "Block Folder" in Block Extension
  * Untuk mem Block semua folder atau beberapa folder
- Menambahkan Fitur "Block File" in Block Extension
  * Untuk mem Block semua file atau beberapa file
- Menambahkan Fitur "Delete File" in Histroy Block EXE
 * Fitur ini berguna untuk menghapus File yang anda anggap berbahaya, atau tidak digunakan lagi.
- Menambahkan Fitur "Open Explore" in Histroy Block EXE
  * Untuk Membuka Explorer pada path yang ditemukan oleh program ini.
- Menambahkan Fitur "History Block EXE"
  * Tempat menampilkan data2 file aplikasi yang dijalankan saat diblock
- Menambahkan Fitur "Cek Registry"
  * Akan menampilkan data2 registry, tempat dimana virus dapat berjalan secara otomatis.
- Menambahkan Fitur "Login, New Password and Change Password"
  * Saat anda ingin menggunakan program ini, anda diwajibkan memasukan password. jika password blm dibuat maka program akan meminta anda untuk membuat password baru. untuk change password masih blm dapat digunakan.

Block Lauch Application Versi3.3
- Memperbaiki Fitur "Login, New Password and Change Password"
  * Saat anda ingin menggunakan program ini, anda diwajibkan memasukan password. jika password blm dibuat maka program akan meminta anda untuk membuat password baru. untuk change password sudah dapat digunakan.
- Menambahkan Fitur "Cek Serangan Virus"
  * Kadang kita tidak tau apakah komputer atau laptop kita diserang virus atau tidak. Dalam fitur ini anda dapat melihat apakah terserang virus atau tidak.

- Menambahkan Fitur "Msconfig-Startup"
  *Pada fitur ini anda dapat melihat urutan Startup. nb : masih dalam pengembangan.


S'lamat mencoba.... >>>>>>>>>>> Download

Auto Scroll Up n Bottom

Buat 2 Command Button, 1 Listbox, 1 textbox.

Masukkan souce ini ke dalam Form :Private Const SBBOTTOM As Long = 7 Private Const SBUP As Long = 6 Private Const WMVSCROLL As Long = &H115 Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long Public Sub ScrollToBottom(ByVal hWnd As Long) SendMessage hWnd, WMVSCROLL, SBBOTTOM, ByVal 0& End Sub Public Sub ScrollToUp(ByVal hWnd As Long) SendMessage hWnd, WMVSCROLL, SBUP, ByVal 0& End Sub Private Sub Command1_Click() If Command1.Caption = "Scroll To Bottom" Then ScrollToBottom List1.hWnd Command1.Caption = "Scroll To Up" Else Command1.Caption = "Scroll To Bottom" ScrollToUp List1.hWnd End If End Sub Private Sub Command2_Click() If Command2.Caption = "Scroll To Bottom" Then ScrollToBottom Text1.hWnd Command2.Caption = "Scroll To Up" Else Command2.Caption = "Scroll To Bottom" ScrollToUp Text1.hWnd End If End Sub Private Sub Form_Load() Command1.Caption = "Scroll To Bottom" Command2.Caption = "Scroll To Bottom" Form1.Caption = "Auto Scroll" List1.AddItem "1" List1.AddItem "2" List1.AddItem "3" Text1.Text = "1" & vbNewLine & "2" & vbNewLine & "3" End Sub

Menambahkan GPEDIT.MSC pada Windows XP Home Edition

Bingung tentang GPEDIT.MSC coba cari google yah. Tanpa Basa Basi silahkan unduh >>>>Download

Membuang Space Yang Berlebih Pada Sebuah Kalimat

Masukkan souce ini ke dalam Form :Public Function TrimALL(ByVal TextIN As String) As String TrimALL = Trim(TextIN) While InStr(TrimALL, String(2, " ")) > 0 TrimALL = Replace(TrimALL, String(2, " "), " ") Wend End Function Private Sub Form_Load() MsgBox TrimALL("Hello ! ! ! This function removes all extra spaces from strings") End Sub

ARBI Resource

Aplikasi ini untuk membaca atau menampilkan isi file berextension .res, juga dapat mengextract isi file .res tersebut yang berextension .exe(aplikasi).

Silahkan Unduh Download

Context My Computer

aplikasi ini untuk menambahkan beberapa context(klik kanan) pada My Computer. cukup dengan memberikan centang pada aplikasi maka context akan bertambah pada My Computer. baru uji tes di WINDOWS XP, kemungkinan bisa dijalankan di WINDOWS 7
Silahkan Unduh >>>>>>>>>>>>>>>>>>>>>> Download

Menampilkan Context Menu (Right Click) WINDOWS XP

Ada beberapa cara utk Menampilkan Context menu :
1. Tahan Shift+F10
2. Klik kanan Pada mouse
3. Tekan Tombol bersimbol seperti gambar dibawah pada keyboard.

Context Menu Handle Shutdown

Aplikasi yg berguna utk menambahkan sub context pada semua drive,folder,dan file. cukup 1x klik PC/laptop anda akan mati (shutdown) dengan cepat...

Silahkan unduh >>>>>> Download

By: ARBI Blog's

Penjelasan Context Menu Windows XP

Context adalah text yg terhubung dalam sebuah command atau perintah. dapat juga diartikan bahwa context adalah sebuah jalan penghubung utk melakukan suatu command.

Delete Prefetch, Temp & Recent Document (DPTR)

sesuai namanya...buat apus2 file2 sampah diwindows XP.Download

Security Image Manager

wekekek...kita bisa simpan semua gambar-gambar kita disini...bisa pake password...xixix..tapi password na masih keliatan blm sempet dikembangin...
Silahkan Unduh >>>>>>>>>>>>>>>>> Download

Hide Drive (Sembunyikan Drive)

Aplikasi ini berguna utk menyembunyikan Drive. Drive disini dalam artian menyupir mobil ha..ha..ha.ha.h.a.h.a.. driver atuh tuh mah akang...!!!wkwkwkwkkw.....

Drive itu yg ada di explorer yg berisi folder-folder kita... Exp : Drive C: , Drive D , Drive E dst.
nah tuh semua bakal disembunyikan oleh nih aplikasi... kelebihan nih aplikasi bukan cuman bisa sembunyikan drive, drive yg disembunyikan tadi juga g bakal bisa diakses melalui DOS.

Silahkan Unduh >>>>>>>>>>>>>>>>>>>>>>>> download

CEA -> Create Extension Application

Aplikasi ini berguna utk membuat sebuah Extension khusus Aplikasi.

Extension adalah tiga angka terakhir dalam semua nama file.

Tiga angka tersebut berfungsi sebagai tanda pengenal....ha...ha.h.a.ha.. kalo didunia manusia mah namanya KTP/SIM/kartu pelajar dsb.

Kelebihan aplikasi ini menurut saia sih:
1.Ada fitur Context (klik kanan)
2.Fitur membuat Extension (sesuka Hati kita pastinya) Khusus aplikasi

mau coba silahkan Unduh >>>>>>>>>>>>>>>>>> Download

Get Name in SubFolder

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Form	1	Text	""	kosongkan

Masukkan souce ini ke dalam Form :Private Sub Form_Load() Dim TotalSplit As Variant Dim i As Integer Dim Directory As String Directory = "C:\Sub1\Sub2\Sub3" 'Get Total split TotalSplit = Split(Directory, "\") 'Get Info SubFolder For i = LBound(TotalSplit) To UBound(TotalSplit) MsgBox Split(Directory, "\")(i) Next i End Sub

Disable ALT+TAB

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Form	1

Masukkan souce ini ke dalam Form :Option Explicit Private Sub Form_Load() Dim ret As Long ret = SystemParametersInfo(97, True, ret, 0) KBDhwnd = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf CatchKeys, App.hInstance, 0) End Sub Private Sub Form_Unload(Cancel As Integer) Dim ret As Long ret = SystemParametersInfo(0, False, ret, 0) If KBDhwnd <> 0 Then UnhookWindowsHookEx KBDhwnd End Sub

Mendapatkan Posisi Mouse Di klik Kanan \ Kiri

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	Interval	KETERANGAN
1.	Form	1	Form1
2.	Timer	1		500

Masukkan souce ini ke dalam Form :Option Explicit Private Declare Function GetForegroundWindow Lib "user32" () As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Dim result As Integer Dim tmp As Integer Const Cap1 = "Capture Mouse Events" Private Sub Form_Load() Form1.Caption = Cap1 End Sub Private Sub Timer1_Timer() Dim x As Long, sclass As String, y As Integer, sclass1 As String sclass = Space$(1024) x = GetForegroundWindow If GetAsyncKeyState(1) <> 0 Then Label1.Caption = "Left Mouse Click" End If If GetAsyncKeyState(2) <> 0 Then Label1.Caption = "Right Mouse Click" End If End Sub

Disable Key Windows XP

ketikkan Kode dibawah dalam notepad dan simpan dengan nama Disable Key Windows.

Mendapatkan Value Lebar (Width) Pada Row (A1) MS.Excel

PERSIAPAN
NO	REFERENCES			KETERANGAN
1.	Microsoft Excel 11.0 Object Library			Cara menambahkannya adalah pilih menu : Project-references. Office yg Digunakan MS 2003
PERSIAPAN			PROPERTIES
NO	CONTROL	PCS	NAME	VALUE	KETERANGAN
2.	TextBox	1	Text	""	kosongkan
3.	ComboBox	1

Masukkan souce ini ke dalam Form :Dim xls As New Excel.Application Dim xlsw As Excel.Workbook Dim xlsws As Excel.Worksheet Private Sub Combo1_Click() Dim Cektext As String Cektext = Combo1.Text Set xlsw = xls.Workbooks.Open(App.Path & "\New Microsoft Excel Worksheet.xls") 'sheet yang ditampilkan xlsw.Sheets("Sheet1").Select Select Case Cektext Case "Point" Text1 = xlsw.Application.Range("A1").Width '& " Point" Case "PIXEL" Text1 = xlsw.Application.Range("A1").Width / 0.75 '& " Pixel" Case "MM" Text1 = (xlsw.Application.Range("A1").Width / 0.75) * 0.08 '& " mm" End Select xlsw.Close False xls.Quit Set xlsw = Nothing Set xls = Nothing End Sub Private Sub Command1_Click() Set xlsw = xls.Workbooks.Open(App.Path & "\New Microsoft Excel Worksheet.xls") 'sheet yang ditampilkan xlsw.Sheets("Sheet1").Select 'Menampilkan Tinggi Pada Text1 Text1 = xlsw.Application.Range("A1").Width '& " Point" xlsw.Close False xls.Quit Set xlsw = Nothing Set xls = Nothing End Sub Private Sub Form_Load() Combo1.AddItem "MM" Combo1.AddItem "PIXEL" Combo1.AddItem "Point" Combo1.Text = "Point" End Sub

Memeriksa Apakah Mouse Terinstall

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Form	1

Masukkan souce ini ke dalam Form :Public Function CheckMouse() As Boolean If GetSystemMetrics(SM_CMOUSEBUTTONS) > 0 Then CheckMouse = True 'Mouse terinstall Else CheckMouse = False 'Mouse tidak terinstall End If End Function Private Sub Form_Load() If CheckMouse Then MsgBox "Mouse terinstall di PC Anda!", vbInformation, "Terinstall" Else MsgBox "Mouse belum terinstall di PC Anda!", vbCritical, "Belum Terinstall" End If End Sub

Masukkan souce ini ke dalam Module :Public Const SM_CMOUSEBUTTONS = 43 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Memasukkan Gambar Pada ImageList

Pertama-tama saya akan memberi tahu cara menambahkan control ImageList.

Caranya :

1. Tekan tombol CTRL+T (Keyboard) maka akan muncul jendela Components seperti gambar dibawah.

Jendela Components

2. Beri tanda cek atau centang pada Microsoft Windows Common Controls 6.0 (Sp6)

3. Klik tombol OK

Kedua kita akan memasukkan sebuah gambar atau icon pada control ImageList.

Caranya :

1. Tambahkan control ImageList. pada Form.

2. Klik kanan Control ImageList. yang telah dimasukkan tadi. dan pilih Properties.

3. maka akan muncul jendela Properties Pages dan pilih tab Images seperti pada gambar dibawah ini.

4. Klik tombol Insert Picture dan anda cari gambar yg ingin anda masukkan.Finish.......

Cara Mendapatkan Kode ASCII Keyboard

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Form	1

Masukkan souce ini ke dalam Form :Private Sub Form_KeyPress(KeyAscii As Integer) MsgBox KeyAscii End Sub

Keyascii Codes

Keyascii Codes
Constant	Value	Description
vbKeyLButton	1	Left mouse button
vbKeyRButton	2	Right mouse button
vbKeyCancel	3	CANCEL key
vbKeyMButton	4	Middle mouse button
vbKeyBack	8	BACKSPACE key
vbKeyTab	9	TAB key
vbKeyClear	12	CLEAR key
vbKeyReturn	13	ENTER key
vbKeyShift	16	SHIFT key
vbKeyControl	17	CTRL key
vbKeyMenu	18	MENU key
vbKeyPause	19	PAUSE key
vbKeyCapital	20	CAPS lock key
vbKeyEscape	27	ESC key
vbKeySpace	32	SPACEBAR key
vbKeyPageUp	33	PAGE UP key
vbKeyPageDown	34	PAGE DOWN key
vbKeyEnd	35	END key
vbKeyHome	36	HOME key
vbKeyLeft	37	LEFT ARROW key
vbKeyUp	38	UP ARROW key
vbKeyRight	39	RIGHT ARROW key
vbKeyDown	40	DOWN ARROW key
vbKeySelect	41	SELECT key
vbKeyPrint	42	print SCREEN key
vbKeyExecute	43	EXECUTE key
vbKeySnapshot	44	SNAPSHOT key
vbKeyInsert	45	INS key
vbKeyDelete	46	DEL key
vbKeyHelp	47	HELP key
vbKey0	48	0 key
vbKey1	49	1 key
vbKey2	50	2 key
vbKey3	51	3 key
vbKey4	52	4 key
vbKey5	53	5 key
vbKey6	54	6 key
vbKey7	55	7 key
vbKey8	56	8 key
vbKey9	57	9 key
vbKeyA	65	A key
vbKeyB	66	B key
vbKeyC	67	C key
vbKeyD	68	D key
vbKeyE	69	E key
vbKeyF	70	F key
vbKeyG	71	G key
vbKeyH	72	H key
vbKeyI	73	I key
vbKeyJ	74	J key
vbKeyK	75	K key
vbKeyL	76	L key
vbKeyM	77	M key
vbKeyN	78	N key
vbKeyO	79	O key
vbKeyP	80	P key
vbKeyQ	81	Q key
vbKeyR	82	R key
vbKeyS	83	S key
vbKeyT	84	T key
vbKeyU	85	U key
vbKeyV	86	V key
vbKeyW	87	W key
vbKeyX	88	X key
vbKeyY	89	Y key
vbKeyZ	90	Z key
vbKeyNumpad0	96	0 key (Numeric Keypad)
vbKeyNumpad1	97	1 key (Numeric Keypad)
vbKeyNumpad2	98	2 key (Numeric Keypad)
vbKeyNumpad3	99	3 key (Numeric Keypad)
vbKeyNumpad4	100	4 key (Numeric Keypad)
vbKeyNumpad5	101	5 key (Numeric Keypad)
vbKeyNumpad6	102	6 key (Numeric Keypad)
vbKeyNumpad7	103	7 key (Numeric Keypad)
vbKeyNumpad8	104	8 key (Numeric Keypad)
vbKeyNumpad9	105	9 key (Numeric Keypad)
vbKeyMultiply	106	Multiplication Sign (*) key (Keypad)
vbKeyAdd	107	PLUS SIGN (+) key (Keypad)
vbKeySeparator	108	ENTER (keypad) key
vbKeySubtract	109	MINUS SIGN (-) key (Keypad)
vbKeyDecimal	110	DECIMAL POINT(.) key (Keypad)
vbKeyDivide	111	DIVISION SIGN (/) key (Keypad)
vbKeyF1	112	F1 key
vbKeyF2	113	F2 key
vbKeyF3	114	F3 key
vbKeyF4	115	F4 key
vbKeyF5	116	F5 key
vbKeyF6	117	F6 key
vbKeyF7	118	F7 key
vbKeyF8	119	F8 key
vbKeyF9	120	F9 key
vbKeyF10	121	F10 key
vbKeyF11	122	F11 key
vbKeyF12	123	F12 key
vbKeyF13	124	F13 key
vbKeyF14	125	F14 key
vbKeyF15	126	F15 key
vbKeyF16	127	F16 key
vbKeyNumlock	144	NUM lock key

tes

Masukkan souce ini ke dalam Form :Tulis text ataupun kode yang mau anda tampilkan disini dasdasd dasda

Tabel 1.1

Data Teknisi
No.	Nama
1.	Juned
2.	jaka kelana

Tabel 1.2

Data Teknisi Satu
No.	Nama	Alamat
1.	Juned
2.	jaka kelana

3D Text In Label

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Label	3	Text	""	kosongkan

Masukkan souce ini ke dalam Form :Static Sub FormLabelCaptionEmbossed(L1 As Label, L2 As Label, L3 As Label, _ label_text As String, label_effect As Integer, label_forecolor As Long, _ label_depth As Integer) Dim lt As String Dim savesm As Integer Dim f As Form Set f = L1.Parent L1.Visible = False L2.Visible = False L3.Visible = False savesm = f.ScaleMode f.ScaleMode = 3 If label_text = "" Then lt = L1 Else lt = label_text End If L1 = lt L2 = lt L3 = lt L1.BackStyle = 0 L1.ForeColor = label_forecolor L2.Width = L1.Width L2.Height = L1.Height L2.BackStyle = L1.BackStyle L2.ForeColor = BOX_DARKGRAY& L3.Width = L1.Width L3.Height = L1.Height L3.BackStyle = L1.BackStyle L3.ForeColor = BOX_WHITE& Select Case label_effect Case GFM_SUNKEN L2.Left = L1.Left - label_depth L2.Top = L1.Top - label_depth L3.Left = L1.Left + label_depth L3.Top = L1.Top + label_depth Case GFM_RAISED L2.Left = L1.Left + label_depth L2.Top = L1.Top + label_depth L3.Left = L1.Left - label_depth L3.Top = L1.Top - label_depth End Select f.ScaleMode = savesm L1.Visible = True L2.Visible = True L3.Visible = True L1.ZOrder End Sub Private Sub Form_Load() 'Replace the first '1' with '2' to change the 3D effect. 'Replace 'vbBlack' with the Text Color. FormLabelCaptionEmbossed Label1, Label2, Label3, "ARBI Blog's", 1, vbBlack, 1 End Sub

Masukkan souce ini ke dalam Module :Global Const GFM_STANDARD = 0 Global Const GFM_RAISED = 1 Global Const GFM_SUNKEN = 2 Global Const GFM_BACKSHADOW = 1 Global Const GFM_DROPSHADOW = 2 Global Const BOX_WHITE& = &HFFFFFF Global Const BOX_LIGHTGRAY& = &HC0C0C0 Global Const BOX_DARKGRAY& = &H808080 Global Const BOX_BLACK& = &H0

Gradient BackColor Label

PERSIAPAN			PROPERTIES
NO	CONTROL	PCS	NAME	VALUE	KETERANGAN
1.	Timer	1	Interval	100
2.	Label	1	Caption	ARBI Blog's

Masukkan souce ini ke dalam Form :Private Sub Timer1_Timer() Static A A = A + 10: If A > 510 Then A = 0 'To change the effect, put other numbers insted of the 0 below. 'You can also replace places between the 'Abs(A - 256)' and one of the zeros below. 'To decrease the pace of the animation, increase the Timer interval property. Label1.BackColor = RGB(Abs(A - 256), 0, 0) End Sub

Animasi Form Load & Unload (Explode \ Implode Effect)

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	CommandButton	1	Caption	Exit	Command1

Masukkan souce ini ke dalam Form Private Sub Command1_Click() 'Replace all the '500' below with the Speed of the Explode\Implode Effect. Call ImplodeForm(Me, 500) End Set Form1 = Nothing End Sub Private Sub Form_Load() Call ExplodeForm(Me, 5000) End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Call ImplodeForm(Me, 500) End Sub

Masukkan souce ini ke dalam Module #If Win16 Then Type RECT Left As Integer Top As Integer Right As Integer Bottom As Integer End Type #Else Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type #End If #If Win16 Then Declare Sub GetWindowRect Lib "User" (ByVal hwnd As Integer, lpRect As RECT) Declare Function GetDC Lib "User" (ByVal hwnd As Integer) As Integer Declare Function ReleaseDC Lib "User" (ByVal hwnd As Integer, ByVal hdc As _ Integer) As Integer Declare Sub SetBkColor Lib "GDI" (ByVal hdc As Integer, ByVal crColor As Long) Declare Sub Rectangle Lib "GDI" (ByVal hdc As Integer, ByVal X1 As Integer, _ ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer Declare Function SelectObject Lib "GDI" (ByVal hdc As Integer, ByVal hObject _ As Integer) As Integer Declare Sub DeleteObject Lib "GDI" (ByVal hObject As Integer) #Else Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _ lpRect As RECT) As Long Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal _ hdc As Long) As Long Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal _ crColor As Long) As Long Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, _ ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Declare Function SelectObject Lib "user32" (ByVal hdc As Long, ByVal hObject _ As Long) As Long Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long #End If Sub ExplodeForm(f As Form, Movement As Integer) Dim myRect As RECT Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy% Dim TheScreen As Long Dim Brush As Long GetWindowRect f.hwnd, myRect formWidth = (myRect.Right - myRect.Left) formHeight = myRect.Bottom - myRect.Top TheScreen = GetDC(0) Brush = CreateSolidBrush(f.BackColor) For i = 1 To Movement Cx = formWidth * (i / Movement) Cy = formHeight * (i / Movement) X = myRect.Left + (formWidth - Cx) / 2 Y = myRect.Top + (formHeight - Cy) / 2 Rectangle TheScreen, X, Y, X + Cx, Y + Cy Next i X = ReleaseDC(0, TheScreen) DeleteObject (Brush) End Sub Public Sub ImplodeForm(f As Form, Movement As Integer) Dim myRect As RECT Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy% Dim TheScreen As Long Dim Brush As Long GetWindowRect f.hwnd, myRect formWidth = (myRect.Right - myRect.Left) formHeight = myRect.Bottom - myRect.Top TheScreen = GetDC(0) Brush = CreateSolidBrush(f.BackColor) For i = Movement To 1 Step -1 Cx = formWidth * (i / Movement) Cy = formHeight * (i / Movement) X = myRect.Left + (formWidth - Cx) / 2 Y = myRect.Top + (formHeight - Cy) / 2 Rectangle TheScreen, X, Y, X + Cx, Y + Cy Next i X = ReleaseDC(0, TheScreen) DeleteObject (Brush) End Sub

Gradient Forms (Using API)

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	CommandButton	1

Masukkan souce ini ke dalam Form :Private Sub Form_Load() Me.ScaleMode = vbPixels Command1.Caption = "Gradient" End Sub Private Function LongToUShort(ULong As Long) As Integer LongToUShort = CInt(ULong - &H10000) End Function Private Function UShortToLong(Ushort As Integer) As Long UShortToLong = (CLng(Ushort) And &HFFFF&) End Function Sub Gradient() Dim vert(1) As TRIVERTEX Dim gRect As GRADIENT_RECT With vert(0) .x = 0 .y = 0 .Red = 0& .Green = &HFF& .Blue = 0& .Alpha = 0& End With With vert(1) .x = Me.ScaleWidth .y = Me.ScaleHeight .Red = 0& .Green = LongToUShort(&HFF00&) .Blue = LongToUShort(&HFF00&) .Alpha = 0& End With gRect.UpperLeft = 1 gRect.LowerRight = 0 'replace GRADIENT_FILL_RECT_H with GRADIENT_FILL_RECT_V to paint 'the form with vertically gradient, instead of horizontally gradient GradientFillRect Me.hdc, vert(0), 2, gRect, 1, GRADIENT_FILL_RECT_H End Sub Private Sub Command1_Click() If Command1.Caption = "Gradient" Then Call Gradient Command1.Caption = "Normal" Else Cls Command1.Caption = "Gradient" End If End Sub

Gradient Forms

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Form	1	AutoRedraw	True

Masukkan souce ini ke dalam Form :Sub Gradient(TheObject As Object, ByVal Redval As Long, ByVal Greenval As _ Long, ByVal Blueval As Long, ByVal Direction As Integer) Dim Step As Integer, Reps As Integer, FillTop As Integer Dim FillLeft As Integer, FillRight As Integer, FillBottom As Integer If Direction < 1 Or Direction > 4 Then Direction = 1 FillTop = 0 FillLeft = 0 If Direction < 3 Then Step = (TheObject.Height / 100) If Direction = 2 Then FillTop = TheObject.Height - Step FillBottom = FillTop + Step FillRight = TheObject.Width Else Step = (TheObject.Width / 100) If Direction = 4 Then FillLeft = TheObject.Width - Step FillRight = FillLeft + Step FillBottom = TheObject.Height End If For Reps = 1 To 100 If Direction = 2 And Reps = 100 Then FillTop = 0 If Direction = 4 And Reps = 100 Then FillLeft = 0 Redval = Redval - 3 Greenval = Greenval - 3 Blueval = Blueval - 3 If Redval <= 0 Then Redval = 0 If Greenval <= 0 Then Greenval = 0 If Blueval <= 0 Then Blueval = 0 TheObject.Line (FillLeft, FillTop)-(FillRight, FillBottom), RGB(Redval, _ Greenval, Blueval), BF If Direction < 3 Then If Direction = 1 Then FillTop = FillBottom Else FillTop = FillTop - Step End If FillBottom = FillTop + Step Else If Direction = 3 Then FillLeft = FillRight Else FillLeft = FillLeft - Step End If FillRight = FillLeft + Step End If Next Reps End Sub Private Sub Form_Activate() 'To make Gradient Picture Box, Replace the 'Me' below with the name of the Picture Box. 'Replace the '200, 100, 300' below with the RGB value of your desirable color. You can 'just try some numbers, till you satisfy. 'Replace the '1' below with the direction of painting. 1 - from top, 2 - from bottom, '3 - from left, 4 - from right. Gradient Me, 200, 100, 300, 1 End Sub Private Sub Form_Resize() 'Put here the same numbers as you put above Gradient Me, 200, 100, 300, 1 End Sub

3D Form

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	CommandButton	1	Caption	3D

Masukkan souce ini ke dalam Form :Public Sub ThreeDForm(frmForm As Form) Const cPi = 3.1415926 Dim intLineWidth As Integer intLineWidth = 5 Dim intSaveScaleMode As Integer intSaveScaleMode = frmForm.ScaleMode frmForm.ScaleMode = 3 Dim intScaleWidth As Integer Dim intScaleHeight As Integer intScaleWidth = frmForm.ScaleWidth intScaleHeight = frmForm.ScaleHeight frmForm.Cls frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, _ intScaleHeight), &H808080, BF frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, _ intScaleHeight), &H808080, BF Dim intCircleWidth As Integer intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth * intLineWidth) frmForm.FillStyle = 0 frmForm.FillColor = QBColor(15) frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), intCircleWidth, _ QBColor(15), -3.1415926, -3.90953745777778 frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), intCircleWidth, _ QBColor(15), -0.78539815, -1.5707963 frmForm.Line (0, intScaleHeight)-(0, 0), 0 frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0 frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, intScaleHeight - 1), 0 frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, intScaleHeight - 1), 0 frmForm.ScaleMode = intSaveScaleMode End Sub Private Sub Command1_Click() 'Replace all 'Me' below with the name of the form you want to transform to 3D ThreeDForm Me End Sub Private Sub Form_Resize() Command1_Click End Sub