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

Menampilkan Form Dalam Form

DESKRIPSI
Tampilannya seperti Form MDI.
PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Fomr	2

Masukkan souce ini ke dalam Form1 :Private Sub Form_Load() Load Form2 Form2.Show End Sub Private Sub Form_Unload(Cancel As Integer) Dim Form As Form For Each Form In Forms Unload Form Set Form = Nothing Next Form End Sub

Masukkan souce ini ke dalam Form2 :Private Sub Form_Load() r = SetParent(Me.hWnd, Form1.hWnd) End Sub

Masukkan souce ini ke dalam Module :Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Mendeteksi Form Sedang Di Load Atau Tidak

PERSIAPAN			PROPERTIES
NO	CONTROL	PCS	NAME	VALUE	KETERANGAN
1.	CommandButton	2	Caption	Cek	Command1
				Load Form2	Command2

Masukkan souce ini ke dalam Form Private Sub Command1_Click() If FormLoadedByName("Form2") = True Then MsgBox "The Form2 is loaded" Else MsgBox "The Form2 is not loaded" End If End Sub Private Sub Command2_Click() If Command2.Caption = "Load Form2" Then Load Form2 Command2.Caption = "Unload Form2" Else Unload Form2 Command2.Caption = "Load Form2" End If End Sub

Masukkan souce ini ke dalam ModulePublic Function FormLoadedByName(FormName As String) As Boolean Dim i As Integer, fnamelc As String fnamelc = LCase$(FormName) FormLoadedByName = False For i = 0 To Forms.Count - 1 If LCase$(Forms(i).Name) = fnamelc Then FormLoadedByName = True Exit Function End If Next End Function

Unload Semua Form

PERSIAPAN			PROPERTIES
NO	CONTROL	PCS	NAME	VALUE	KETERANGAN
1.	CommandButton	1	Caption	Unload All	Command1

Masukkan souce ini ke dalam Form Private Sub Command1_Click() Dim Form As Form For Each Form In Forms Unload Form Set Form = Nothing Next Form End Sub

Gradient TitleBar Form

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

Masukkan souce ini ke dalam Form Private Sub Form_Load() GradForceColors = True 'Replace the 'True' below with 'False' if you want that the gradient will 'be drawn horizonally. GradVerticalGradient = True 'Set colors for active caption GradForcedText = vbWhite 'Replace the two color values below to change the active title bar color GradForcedFirst = &H800000 GradForcedSecond = &H8000 'Set colors for Inactive caption GradForcedTextA = &HC0C0C0 'Replace the two color values below to change the inactive title bar color GradForcedFirstA = vbBlack GradForcedSecondA = vbBlue GradientGetCapsFont GradientForm Me End Sub Private Sub Form_Unload(Cancel As Integer) GradientReleaseForm Me End Sub

Masukkan souce ini ke dalam ModulePublic GradForceColors As Boolean Public GradVerticalGradient As Boolean Public GradForcedText As Long, GradForcedTextA As Long Public GradForcedFirst As Long, GradForcedSecond As Long Public GradForcedFirstA As Long, GradForcedSecondA As Long Dim GradhWnd As Long, GradIcon As Long Dim DrawDC As Long, tmpDC As Long Dim hRgn As Long Dim tmpGradFont As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Const GWL_WNDPROC = (-4) Private Const GWL_STYLE = (-16) Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetProp Lib "user32" Alias "GetPropA" _ (ByVal hWnd As Long, ByVal lpString As String) As Long Private Declare Function SetProp Lib "user32" Alias "SetPropA" _ (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _ (ByVal hWnd As Long, ByVal lpString As String) As Long Private Const LF_FACESIZE = 32 Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(1 To LF_FACESIZE) As Byte End Type Private Declare Function SystemParametersInfo Lib "user32" Alias _ "SystemParametersInfoA" (ByVal uAction As Long, _ ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long Private Const SPI_GETNONCLIENTMETRICS = 41 Private Type NONCLIENTMETRICS cbSize As Long iBorderWidth As Long iScrollWidth As Long iScrollHeight As Long iCaptionWidth As Long iCaptionHeight As Long lfCaptionFont As LOGFONT iSMCaptionWidth As Long iSMCaptionHeight As Long lfSMCaptionFont As LOGFONT iMenuWidth As Long iMenuHeight As Long lfMenuFont As LOGFONT lfStatusFont As LOGFONT lfMessageFont As LOGFONT End Type Dim CaptionFont As LOGFONT Private Declare Function CreateFontIndirect Lib "gdi32" Alias _ "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) _ As Long Private Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) _ As Long Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" _ (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long Private Const IDC_SIZENS = 32645& Private Const IDC_SIZEWE = 32644& Private Const IDC_SIZENWSE = 32642& Private Const IDC_SIZENESW = 32643& Private Declare Function GetWindowText Lib "user32" Alias _ "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, _ ByVal cch As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, _ lpRect As RECT) As Long Private Declare Function GetActiveWindow Lib "user32" () As Long Private Const WS_BORDER = &H800000 Private Const WS_CAPTION = &HC00000 Private Const WS_DLGFRAME = &H400000 Private Const WS_MINIMIZE = &H20000000 Private Const WS_MAXIMIZE = &H1000000 Private Const WS_MAXIMIZEBOX = &H10000 Private Const WS_MINIMIZEBOX = &H20000 Private Const WS_OVERLAPPED = &H0& Private Const WS_SYSMENU = &H80000 Private Const WS_THICKFRAME = &H40000 Private Const WS_POPUP = &H80000000 Private Const WS_SIZEBOX = WS_THICKFRAME Private Const WS_TILED = WS_OVERLAPPED Private Const WS_VISIBLE = &H10000000 Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _ ByVal hDC As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function OffsetClipRgn Lib "gdi32" (ByVal hDC As Long, _ ByVal x As Long, ByVal Y As Long) As Long Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, _ ByVal x As Long, ByVal Y As Long) As Long Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, _ ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, _ ByVal cxWidth As Long, ByVal cyWidth As Long, _ ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, _ ByVal diFlags 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_SINGLELINE = &H20 Private Const DT_VCENTER = &H4 Private Const DT_END_ELLIPSIS = &H8000& Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, _ ByVal hRgn As Long) As Long Private Declare Function GetClipRgn Lib "gdi32" (ByVal hDC As Long, _ ByVal hRgn As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, _ ByVal hObject As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, _ ByVal x As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, _ ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _ ByVal dwRop As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) _ As Long Private Const COLOR_ACTIVECAPTION = 2 Private Const COLOR_CAPTIONTEXT = 9 Private Const COLOR_INACTIVECAPTION = 3 Private Const COLOR_INACTIVECAPTIONTEXT = 19 Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, _ ByVal nBkMode As Long) As Long Private Const TRANSPARENT = 1 Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, _ ByVal crColor As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Long) As Long Private Const SM_CXBORDER = 5 Private Const SM_CXDLGFRAME = 7 Private Const SM_CXFRAME = 32 Private Const SM_CXICON = 11 Private Const SM_CXSMSIZE = 30 Private Const SM_CYBORDER = 6 Private Const SM_CYCAPTION = 4 Private Const SM_CYDLGFRAME = 8 Private Const SM_CYFRAME = 33 Private Const SM_CYICON = 12 Private Const SM_CYMENU = 15 Private Const SM_CYSMSIZE = 31 Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, _ lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) _ As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" _ (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateRectRgnIndirect Lib "gdi32" _ (lpRect As RECT) 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 ExcludeClipRect Lib "gdi32" (ByVal hDC As Long, _ ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" _ (ByVal crColor As Long) As Long Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC As Long, _ lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long Private Const DFC_CAPTION = 1 Private Const DFCS_CAPTIONRESTORE = &H3 Private Const DFCS_CAPTIONMIN = &H1 Private Const DFCS_CAPTIONMAX = &H2 Private Const DFCS_CAPTIONHELP = &H4 Private Const DFCS_CAPTIONCLOSE = &H0 Private Const DFCS_INACTIVE = &H100 Private Const WM_SIZE = &H5 Private Const WM_SETCURSOR = &H20 Private Const WM_GETICON = &H7F Private Const WM_SETICON = &H80 Private Const WM_NCACTIVATE = &H86 Private Const WM_MDIACTIVATE = &H222 Private Const WM_KILLFOCUS = &H8 Private Const WM_MOUSEACTIVATE = &H21 Private Const WM_MDIGETACTIVE = &H229 Private Const MA_ACTIVATE = 1 Private Const WM_SETTEXT = &HC Private Const WM_NCPAINT = &H85 Private Const WM_NCLBUTTONDOWN = &HA1 Private Const WM_NCRBUTTONDOWN = &HA4 Private Const WM_SYSCOMMAND = &H112 Private Const WM_INITMENUPOPUP = &H117 Private Const SC_MOUSEMENU = &HF090& Private Const SC_MOVE = &HF010& Private Const HTCAPTION = 2 Private Const HTSYSMENU = 3 Private Const HTLEFT = 10 Private Const HTRIGHT = 11 Private Const HTTOP = 12 Private Const HTTOPLEFT = 13 Private Const HTTOPRIGHT = 14 Private Const HTBOTTOM = 15 Private Const HTBOTTOMLEFT = 16 Private Const HTBOTTOMRIGHT = 17 Private Function LoWord(LongIn As Long) As Integer If (LongIn And &HFFFF&) > &H7FFF Then LoWord = (LongIn And &HFFFF&) - &H10000 Else LoWord = LongIn And &HFFFF& End If End Function Private Sub GetColors(IsActive As Boolean, LColor As Long, RColor As Long) If IsActive Then If GradForceColors Then LColor = GradForcedFirst RColor = GradForcedSecond Else LColor = vbBlack RColor = GetSysColor(COLOR_ACTIVECAPTION) End If Else If GradForceColors Then LColor = GradForcedFirstA RColor = GradForcedSecondA Else LColor = vbBlack RColor = GetSysColor(COLOR_INACTIVECAPTION) End If End If End Sub Public Sub GradientGetCapsFont() Dim NCM As NONCLIENTMETRICS Dim lfNew As LOGFONT NCM.cbSize = Len(NCM) Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, NCM, 0) CaptionFont = NCM.lfCaptionFont End Sub Private Sub GetCaptionRect(hWnd As Long, rct As RECT) Dim XBorder As Long Dim fStyle As Long Dim YHeight As Long YHeight = GetSystemMetrics(SM_CYCAPTION) fStyle = GetWindowLong(hWnd, GWL_STYLE) Select Case fStyle And &H80 Case &H80 XBorder = GetSystemMetrics(SM_CXDLGFRAME) Case Else XBorder = GetSystemMetrics(SM_CXFRAME) End Select rct.Left = XBorder rct.Right = XBorder rct.Top = XBorder rct.Bottom = rct.Top + YHeight - 1 End Sub Private Sub GradateColors(Colors() As Long, ByVal Color1 As Long, _ ByVal Color2 As Long) Dim i As Long Dim dblR As Double, dblG As Double, dblB As Double Dim addR As Double, addG As Double, addB As Double Dim bckR As Double, bckG As Double, bckB As Double dblR = CDbl(Color1 And &HFF) dblG = CDbl(Color1 And &HFF00&) / 255 dblB = CDbl(Color1 And &HFF0000) / &HFF00& bckR = CDbl(Color2 And &HFF&) bckG = CDbl(Color2 And &HFF00&) / 255 bckB = CDbl(Color2 And &HFF0000) / &HFF00& addR = (bckR - dblR) / UBound(Colors) addG = (bckG - dblG) / UBound(Colors) addB = (bckB - dblB) / UBound(Colors) For i = 0 To UBound(Colors) dblR = dblR + addR dblG = dblG + addG dblB = dblB + addB If dblR > 255 Then dblR = 255 If dblG > 255 Then dblG = 255 If dblB > 255 Then dblB = 255 If dblR < 0 Then dblR = 0 If dblG < 0 Then dblG = 0 If dblG < 0 Then dblB = 0 Colors(i) = RGB(dblR, dblG, dblB) Next End Sub Private Function DrawGradient(ByVal Color1 As Long, _ ByVal Color2 As Long) As Long Dim i As Long Dim DestWidth As Long, DestHeight As Long Dim StartPnt As Long, EndPnt As Long Dim PixelStep As Long, XBorder As Long Dim WndRect As RECT Dim OldFont As Long Dim fStyle As Long, fText As String Dim SMSize As Long, SMSizeY As Long On Error Resume Next SMSize = GetSystemMetrics(SM_CXSMSIZE) SMSizeY = GetSystemMetrics(SM_CYSMSIZE) GetWindowRect GradhWnd, WndRect With WndRect DestWidth = .Right - .Left End With DestHeight = GetSystemMetrics(SM_CYCAPTION) fText = Space$(255) Call GetWindowText(GradhWnd, fText, 255) fText = Trim$(fText) fStyle = GetWindowLong(GradhWnd, GWL_STYLE) Select Case fStyle And &H80 Case &H80 XBorder = GetSystemMetrics(SM_CXDLGFRAME) DestWidth = (DestWidth - XBorder) Case Else XBorder = GetSystemMetrics(SM_CXFRAME) DestWidth = DestWidth - XBorder End Select StartPnt = XBorder EndPnt = XBorder + DestWidth - 4 Dim rct As RECT Dim hBr As Long With rct If Not GradVerticalGradient Then PixelStep = DestWidth \ 8 ReDim Colors(PixelStep) As Long GradateColors Colors(), Color1, Color2 .Top = XBorder .Left = XBorder .Right = XBorder + (DestWidth \ PixelStep) .Bottom = (XBorder + DestHeight - 1) If (fStyle And &H80) = &H80 Then EndPnt = EndPnt + 1 For i = 0 To PixelStep - 1 hBr = CreateSolidBrush(Colors(i)) FillRect DrawDC, rct, hBr DeleteObject hBr OffsetRect rct, (DestWidth \ PixelStep), 0 If i = PixelStep - 2 Then .Right = EndPnt Next Else PixelStep = DestHeight \ 1 ReDim Colors(PixelStep) As Long GradateColors Colors(), Color2, Color1 .Top = XBorder .Left = XBorder If (fStyle And &H80) = &H80 Then .Right = (XBorder * 2) + DestWidth + 2 Else .Right = (XBorder * 2) + DestWidth End If .Bottom = XBorder + (DestHeight \ PixelStep) For i = 0 To PixelStep - 1 hBr = CreateSolidBrush(Colors(i)) FillRect DrawDC, rct, hBr DeleteObject hBr OffsetRect rct, 0, (DestHeight \ PixelStep) If i = PixelStep - 2 Then .Bottom = XBorder + (DestHeight - 1) .Bottom = XBorder + (DestHeight - 1) Next End If .Top = XBorder If GradIcon <> 0 Then .Left = XBorder + SMSize + 2 DrawIconEx DrawDC, XBorder + 1, XBorder + 1, GradIcon, _ SMSize - 2, SMSize - 2, ByVal 0&, ByVal 0&, 2 Else .Left = XBorder End If tmpGradFont = CreateFontIndirect(CaptionFont) OldFont = SelectObject(DrawDC, tmpGradFont) SetBkMode DrawDC, TRANSPARENT If GradForceColors Then If Color1 = GradForcedFirst Then SetTextColor DrawDC, GradForcedText Else SetTextColor DrawDC, GradForcedTextA End If Else If Color2 = GetSysColor(COLOR_ACTIVECAPTION) Then SetTextColor DrawDC, GetSysColor(COLOR_CAPTIONTEXT) Else SetTextColor DrawDC, GetSysColor(COLOR_INACTIVECAPTIONTEXT) End If End If .Left = .Left + 2 .Right = .Right - 10 DrawText DrawDC, fText, Len(fText) - 1, rct, _ DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_VCENTER SelectObject DrawDC, OldFont DeleteObject tmpGradFont tmpGradFont = 0 Dim frct As RECT If (fStyle And WS_SYSMENU) = WS_SYSMENU Then Dim CurMaxPic As Long If IsZoomed(GradhWnd) Then CurMaxPic = DFCS_CAPTIONRESTORE Else CurMaxPic = DFCS_CAPTIONMAX End If With frct .Right = DestWidth - 2 .Left = .Right - SMSize + 2 .Top = XBorder + 2 .Bottom = .Top + (DestHeight - 5) End With DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONCLOSE OffsetRect frct, -(SMSize), 0 If (fStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX And _ (fStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic OffsetRect frct, -(SMSize) + 2, 0 DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN ElseIf (fStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX Then DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic OffsetRect frct, -(SMSize) + 2, 0 DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN _ Or DFCS_INACTIVE ElseIf (fStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic Or DFCS_INACTIVE OffsetRect frct, -(SMSize) + 2, 0 DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN End If End If .Left = XBorder .Right = .Right + 12 If tmpDC <> 0 Then BitBlt tmpDC, .Left, .Top, .Right - .Left - 10, .Bottom - .Top, _ DrawDC, .Left, .Top, vbSrcCopy ExcludeClipRect tmpDC, XBorder, XBorder, DestWidth, _ XBorder + (DestHeight - 1) End If '.Right - .Left - 8 End With End Function Public Function GradientCallback(ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Dim OldGradProc As Long Dim OldBMP As Long, NewBMP As Long Dim rcWnd As RECT Dim tmpFrm As Form Dim tmpCol1 As Long, tmpCol2 As Long Static GettingIcon As Boolean GradhWnd = hWnd OldGradProc = GetProp(GradhWnd, "OldMeProc") If Not GettingIcon Then GettingIcon = True GradIcon = SendMessage(hWnd, WM_GETICON, 0, ByVal 0&) GettingIcon = False End If Select Case wMsg Case WM_NCACTIVATE, WM_MDIACTIVATE, WM_KILLFOCUS, WM_MOUSEACTIVATE GetWindowRect GradhWnd, rcWnd tmpDC = GetWindowDC(GradhWnd) DrawDC = CreateCompatibleDC(tmpDC) NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50) OldBMP = SelectObject(DrawDC, NewBMP) With rcWnd hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom) SelectClipRgn tmpDC, hRgn OffsetClipRgn tmpDC, -.Left, -.Top End With If wMsg = WM_KILLFOCUS And GetParent(GradhWnd) <> 0 Then GetColors False, tmpCol1, tmpCol2 ElseIf wMsg = WM_NCACTIVATE And wParam And _ (GetParent(GradhWnd) = 0) Then GetColors True, tmpCol1, tmpCol2 ElseIf wMsg = WM_NCACTIVATE And wParam = 0 And _ (GetParent(GradhWnd) = 0) Then GetColors False, tmpCol1, tmpCol2 ElseIf wParam = GradhWnd And GetParent(GradhWnd) <> 0 Then GetColors False, tmpCol1, tmpCol2 ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, _ 0, 0) = GradhWnd Then GetColors True, tmpCol1, tmpCol2 ElseIf GetActiveWindow() = GradhWnd Then GetColors True, tmpCol1, tmpCol2 Else GetColors False, tmpCol1, tmpCol2 End If DrawGradient tmpCol1, tmpCol2 SelectObject DrawDC, OldBMP DeleteObject NewBMP DeleteDC DrawDC OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top GetClipRgn tmpDC, hRgn If wMsg = WM_MOUSEACTIVATE Then GradientCallback = MA_ACTIVATE Else GradientCallback = 1 End If ReleaseDC GradhWnd, tmpDC DeleteObject hRgn tmpDC = 0 Exit Function Case WM_SETTEXT, WM_NCPAINT, WM_NCLBUTTONDOWN, _ WM_NCRBUTTONDOWN, WM_SYSCOMMAND, WM_INITMENUPOPUP GetWindowRect GradhWnd, rcWnd tmpDC = GetWindowDC(GradhWnd) DrawDC = CreateCompatibleDC(tmpDC) NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50) OldBMP = SelectObject(DrawDC, NewBMP) With rcWnd hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom) SelectClipRgn tmpDC, hRgn OffsetClipRgn tmpDC, -.Left, -.Top End With If (GetActiveWindow() = GradhWnd) Then GetColors True, tmpCol1, tmpCol2 ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, _ 0, 0) = GradhWnd Then GetColors True, tmpCol1, tmpCol2 Else GetColors False, tmpCol1, tmpCol2 End If DrawGradient tmpCol1, tmpCol2 SelectObject DrawDC, OldBMP DeleteObject NewBMP DeleteDC DrawDC OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top GetClipRgn tmpDC, hRgn GradientCallback = CallWindowProc(OldGradProc, hWnd, WM_NCPAINT, _ hRgn, lParam) ReleaseDC GradhWnd, tmpDC DeleteObject hRgn tmpDC = 0 If wMsg = (WM_NCLBUTTONDOWN And wParam <> HTSYSMENU And _ wParam <> HTCAPTION) Or wMsg = _ (WM_SYSCOMMAND And Not (wParam = SC_MOUSEMENU)) Then GetCaptionRect GradhWnd, rcWnd ExcludeClipRect tmpDC, rcWnd.Left, rcWnd.Top, _ rcWnd.Right, rcWnd.Bottom ElseIf wMsg = WM_NCLBUTTONDOWN And wParam = HTCAPTION Then If IsZoomed(GradhWnd) = 0 Then GradientCallback = SendMessage(GradhWnd, WM_SYSCOMMAND, _ SC_MOVE, ByVal 0&) End If Exit Function Else Exit Function End If Case WM_SIZE If hWnd = GradhWnd Then SendMessage GradhWnd, WM_NCPAINT, 0, 0 End If Case WM_SETCURSOR Select Case LoWord(lParam) Case HTTOP, HTBOTTOM SetCursor LoadCursor(ByVal 0&, IDC_SIZENS) Case HTLEFT, HTRIGHT SetCursor LoadCursor(ByVal 0&, IDC_SIZEWE) Case HTTOPLEFT, HTBOTTOMRIGHT SetCursor LoadCursor(ByVal 0&, IDC_SIZENWSE) Case HTTOPRIGHT, HTBOTTOMLEFT SetCursor LoadCursor(ByVal 0&, IDC_SIZENESW) Case Else GoTo JustCallBack End Select GradientCallback = 1 Exit Function End Select JustCallBack: GradientCallback = CallWindowProc(OldGradProc, hWnd, wMsg, wParam, lParam) End Function Public Sub GradientForm(frm As Form) Dim tmpProc As Long tmpProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, _ AddressOf GradientCallback) SetProp frm.hWnd, "OldMeProc", tmpProc End Sub Public Sub GradientReleaseForm(frm As Form) Dim tmpProc As Long tmpProc = GetProp(frm.hWnd, "OldMeProc") RemoveProp frm.hWnd, "OldMeProc" If tmpProc = 0 Then Exit Sub SetWindowLong frm.hWnd, GWL_WNDPROC, tmpProc End Sub