Tài liệu Chiêu thức lập trình Visual Basic pdf

Tác giả : Lê Nguyên Dũng
Lớp 11C
1
trường THPT Đăk Nông (Thị xã Gia Nghĩa - Đ ăk Nông)

Email của mình :
Nick : nguyen_dung_vb

Địa chỉ nhà : Thôn 1, thị trấn Đăk Mâm Huyện Krông Nô Tỉnh Đắk Nông












Tự hào ghê cái Logo của cuốn sách mình thiết kế bằng Word và Paint đấy. Nhìn vô cũng
chuyên nghiệp đấy chứ

Lời nói đầu


Sau khi “Xuất bản” cuốn “Chiêu thức lập trình” mình quả thật rất buồn vì chẳng có lấy một lời
động viên từ bất kỳ ai (Ở Đăk Nông này mình có biết ai mà khoe) còn anh em ở việt nam nét thì
chẳng đoái hoài gì cả vì vậy mình đã thật sự nản, để cuối cùng sau một sự cố nghề nghiệp phiên
bản Chiêu thức lập trình phiên bản 2 mình viết gần hoàn thành bỗng tan vào sương khói mình đã
tuyệt vọ
ng. Nhưng mới hồi sáng khi mình “Viếng” www.caulacbovb.com một diễn đàn mình tham
gia từ khá lâu nhưng không mấy quan tâm mình đã thấy cuốn sách này được chia sẽ trên đó,
cùng với đó là lời khen của một nhân vật mình không nhớ tên đã làm mình rất vui, vì mình đã
nhận ra mình cũng được công nhận dù chỉ một chút. Cuốn Chiêu thức lập trình lần này sẽ được
nâng cấp lên với nhiều chiêu thức và hình vẽ minh hoạ để giúp các bạn nâng cao kiến thức.


Lời cầu cứ
u : Do từ năm lớp 9 đến nay mình chỉ tập trung vào học lập trình (Mà lại toàn tự học)
nên hiện nay đệ đã học sút rất nhiều nguy cơ rớt đại học ngày một đến gần mà ước mơ lớn nhất
của đời đệ là đậu vào khoa Công Nghệ Thông Tin Đại học Bách Khoa Hồ Chí Minh đệ mong
rằng có huynh nào đã từng phải nếm trải cảnh thi đại học thì chia sẻ kinh nghiệ
m học, học sách
gì Còn nếu có sách vở (Cũ cũng được) không cần dùng tới nhưng tốt để ôn thi đại học thì chia
sẽ cho đệ. Nếu có huynh nào có lòng “Hảo tâm” hãy gửi đến địa chỉ : (Đây là địa chỉ cô giáo dạy
Tin của trường đệ vào hết năm học này có thể thay đổi)
Phạm Thị Loan giáo viên trường Trung Học Phổ Thông Đăk Nông, xin ghi rõ là nhở gửi cho em

Lê Nguyên Dũng lớp 11C
1

Cuốn sách này là cuốn sách hoàn toàn miễn phí để chia sẽ trong cộng đồng lập trình nên nếu có
ai múôn sử dụng để in sách thì cũng nên ghi rõ xuất sứ.
Trong sách tôi xin chỉ rõ xuất xứ, mong rằng các ban cũng sẽ tôn trong tác giả không chỉnh sửa
tác giả hay các xuất xứ
Cuốn sách này đi theo định hướng là sử dụng các hàm API hoặc các lệnh đơn giản để tạo thành
những thủ thuật và hạn chế tối đa phải s
ử dụng các công cụ hỗ trợ.

Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c

Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c

Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c
Đ
ôc
c

Đ

c
hiêu 1 : “Thả
c
hiêu 2 : Hiện
c
hiêu 3 : Hiện
c
hiêu 4 : For
m
c
hiêu 5 : “Ch

ụ
c
hiêu 6 : “Vô
h
c
hiêu 7 : “Ké
o
c
hiêu 8 : “Ghi
c
hiêu 9 : Đón
g
c
hiêu 10 : Tạ
o
c
hiêu 11 : Th
a
c
hiêu 12 : Đó
n
c
hiêu 13 : Tạ
o
c
hiêu 14 : Th
a
c
hiêu 15 : So
c

hiêu 16 : Liệ
t
c
hiêu 17 : Ch
ư
c
hiêu 18 : Pla
y
c
hiêu 19 : Kh
o
c
hiêu 20 : Để
c
hiêu 21 : Te
x
c
hiêu 22 : Để
c
hiêu 23 : Lấ
y
c
hiêu 24 : Ch
é
c
hiêu 25 : Dấ
u
c
hiêu 26 :Mở
Đ

ôc chiêu 27
:
một câu từ t
r
một câu bằ
n
con trỏ độn
g
m
có hình dạ
n
ụ
p ảnh màn h
ì
h
iệu hoá butt
o
o
form di chu
y
lại tất cả nh
ữ
g
một ứng dụ
o
phím nóng
c
a
y đổi hình n
ề

n
g mở khay
C
o
một Syste
m
a
y đổi Font ti
ế
sánh hai ảnh
t
kê danh sá
c
ư
ơng trình k
h
y
một file nh
ạ
o
á một file ản
form của bạ
n
x
tBox chỉ “Ch
ị
form trở nên
y
tên người s
ử

é
p cả màn hì
n
u
dữ liệu dạn
g
từng hộp tho
ạ
:
Mã hoá dữ l
r
ên cao xuốn
n
g cách lần l
ư
g
tại một đối t
ư
n
g theo một h
ì
ì
nh vào một
P
o
n close và
m
y
ển từ một đi
ể

ữ
ng phím gõ
t
ng bất kỳ
c
ho chương
t
ề
n cho Deskt
o
C
D-ROM
m
Tray cho ứn
g
ế
ng việt cho
M

c
h các thành
p
h
ởi động cùn
g
ạ
c Midi
h định dạng
.
n

ở chế độ “L
u
ị
u” nhận số
trong suốt
ử
dung của
W
n
h làm việc v
g
text vào 1 f
i
ạ
i trong Cont
iệu dạng tex
t
Mục lục
g” (Có thể n
ó
ư
ợt hiện từng
ư
ợng nào đó
ì
nh ảnh bất k
P
icture”
m
enu của for

m
ể
m bất kỳ”
t
ên bàn phím
”
t
rình
o
p
g
dụng của b
ạ
M
enu của Wi
n
p
hần phần c
ứ
g
với Windo
w
.
bmp
u
ôn nổi”
W
indowns
ào một Pictu
r

i
le bất kỳ
rol Panel
t

ó
i như vậy)
chữ
ỳ

m
(cả Alt-F4 l
u
”

ạ
n
n
dow
ứ
ng trong má
y
w
ns
r
e
u
ôn)”
y

Đôc chiêu 1 : “Thả một câu từ trên cao xuống” (Có thể nói như vậy) home
Xuất xứ : www.pscode.com
Binh khí sử dụng : Một Picture và một CommandButton
Đoạn mã :
Option Explicit

Private Sub command1_Click()
Randomize Timer 'Init Rnd

'Declarations
Dim StartTime(100) 'Starttime of a up/down
movement
Dim DownMovement(100) As Boolean 'are we doing a up or down
movement ???
Dim MoveDistance As Double 'distance target has moved
since the start of the movement
Dim YPos(100) As Double 'Holds the y position of a
letter
Dim MovementDone(100) As Boolean 'Is set to true when a up /
down movement is completed
Dim StartHeight(100) As Double 'From which hight will
the letter fall down ?
Dim UpMovementTime(100) As Double 'How long will it the
letter take to move up
Dim PowerLoss(100) As Double 'losing xx% of power
when touching the ground
Dim Message As String 'Message you want to
display
Dim Looop As Integer 'Loop var
Dim TextColor(100) As ColorConstants 'Color of one letter

'Settings

picture1.ScaleMode = 4
picture1.FontName = "Courier New"

Message = "Ohh my god ! It's raining letters today !!! Contact me:
" 'Message you want to display

For Looop = 1 To Len(Message)

PowerLoss(Looop) = 0.2 + ((Rnd * 25) / 100)
'losing xx% of power when touching the ground
StartHeight(Looop) = 0
TextColor(Looop) = RGB(80 + Looop * 2, 80 + Looop * 2, 255)

Next Looop

For Looop = 1 To Len(Message)
StartTime(Looop) = Timer 'Setting up
startime for a following movement, needed for calculation of position
Next Looop

Do

picture1.Cls 'Clear picturebox

'Looping throung the textmessage
For Looop = 1 To Len(Message)

If DownMovement(Looop) = True Then

MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 *
((Timer - StartTime(Looop)) ^ 2))) 'Calculating falling distance

If YPos(Looop) >= picture1.ScaleHeight - 1 Then
MovementDone(Looop) = True 'The letter reached the bottom border.
The Downmovement is complete

Else
MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 *
(UpMovementTime(Looop) - (Timer - StartTime(Looop))) ^ 2)) 'Calculating
falling distance

If YPos(Looop) <= StartHeight(Looop) + 0.1 Then
MovementDone(Looop) = True 'The letter reached the max. height.
The upmovement is complete

End If

YPos(Looop) = MoveDistance

If YPos(Looop) > picture1.ScaleHeight -
1
Then
'If the letter fell picture1 of our picturebox ;) we fix it
YPos(Looop) = picture1.ScaleHeight -
1

'At the bottom position
End If

picture1.CurrentX = picture1.ScaleWidth / 2 -
Int((Len(Message) / 2)) + Looop
picture1.CurrentY = YPos(Looop)
'Setting the letters y position
picture1.ForeColor = TextColor(Looop)
'Setting the letters color
picture1.Print Mid(Message, Looop, 1)
'Text picture1put

Next Looop

DoEvents

For Looop = 1 To Len(Message)

If MovementDone(Looop) = True Then

If DownMovement(Looop) = True Then 'Switch between
up/downmovement
DownMovement(Looop) = False
StartHeight(Looop) = StartHeight(Looop) +
((picture1.ScaleHeight - StartHeight(Looop)) * PowerLoss(Looop)) 'New
Startheight, because of speed lost ?!?!
UpMovementTime(Looop) = Sqr((picture1.ScaleHeight -
StartHeight(Looop)) / (0.5 * 9.81)) 'How long will the NEXT
upmovement last ???

Else
DownMovement(Looop) = True
End If

StartTime(Looop) = Timer 'Set the
StartTime of a new movement
MovementDone(Looop) = False
End If

Next Looop

Loop 'Until StartHeight = picture1.ScaleHeight

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
End
End Sub
Đôc chiêu 2 : Hiện một câu bằng cách lần lượt hiện từng chữ home

Xuất xứ : www.pscode.com
Binh khí sử dụng : Một Module , ba CommandButton lần lượt có các tên cmdStart, cmdClear,
cmdExit, thêm hai cái đồng hồ tên là Timer1 (Interval =50) và Timer2(Interval =5) cuối cùng là
một label tên là lblText
Đoạn mã :

Module :
Public ASCC(5) As String
Public Letters() As String
Public TXT As String

Public CurLetter As Integer
Public TEXTT As String
Public r As Integer
Form :

Private Sub cmdClear_Click()
lblText.Caption = ""
End Sub

Private Sub cmdExit_Click()
End
End Sub

Private Sub cmdStart_Click()
TXT = InputBox("Enter Text")

ReDim Preserve Letters(0)
ReDim Preserve Letters(Len(TXT))
lblText = ""
CurLetter = 0

For l = 1 To Len(TXT)
Letters(l) = Mid(TXT, l, 1)
Next

Timer2.Enabled = True
End Sub

Private Sub Form_Load()

End Sub

Private Sub Timer1_Timer()
r = r + 1
lblText.Caption = TEXTT
lblText.Caption = lblText.Caption & "_"
If r = 6 Then
r = 0
If 65 < Asc(Letters(CurLetter)) < 90 Then
lblText.Caption = TEXTT
lblText.Caption = lblText.Caption & Letters(CurLetter)
TEXTT = lblText
Timer2.Enabled = True
Timer1.Enabled = False
Else
lblText.Caption = TEXTT
lblText.Caption = lblText.Caption & Chr$(Asc(Letters(CurLetter)) -
32)
TEXTT = lblText
Timer2.Enabled = True
Timer1.Enabled = False
End If

End If

End Sub

Private Sub Timer2_Timer()
CurLetter = CurLetter + 1

If CurLetter > Len(TXT) Then
GoTo HERE:
End If

TEXTT = lblText
Timer1.Enabled = True
Timer2.Enabled = False

HERE:
Timer2.Enabled = False
End Sub

// neu co loi thi de 2 timer = False ->> tui ko phai tac gia


Đôc chiêu 3 : Hiện con trỏ động tại một đối tượng nào đó home
Xuất xứ : www.ttvnol.com
Binh khí sử dụng : Chỉ cần một cái Form
Đoạn mã :

'Hằng được sử dụng
private Const ConTro=(-12)
'Các hàm API được sử dụng
Private Declare Function SetClasslong Lib "user32" Alias
"SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal
wNewWord As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias
"LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Dim NewCur as long
Dim OldCur as long

Private Sub Form_Load
'Giả sử rằng bạn đã có sẵn file Clock.ani ở ổ C:\
NewCur=LoadCursorFromFile("C:\Clock.ani")
OldCur=SetClassLong(Me.hwnd, ConTro,NewCur)
End sub
Private Sub Form_UnLoad(Cancel as Integer)
SetClassLong me.hwnd, Contro,OldCur
End Sub
- Ta rút ra được một “Công thức” : Thay vì đặt con trỏ động trong Form ta có thể thay Me.hwnd
trong dòng lệnh : OldCur=SetClassLong(Me.hwnd, ConTro,NewCur) bằng đối tựợng.hwnd (Nếu
đối tượng đó hổ trợ )


Đôc chiêu 4 : Form có hình dạng theo một hình ảnh bất kỳ (Tất nhiên có màu tượng trưng
cho form trong suốt) home
Xuất xứ : www.pscode.com
Binh khí sử dụng : Chỉ cần một cái Form, trong form c ó s ẵn h ình n ền (Màu đen sẽ là màu chỉ
định trong suốt)
Đoạn mã : Bản thân đoạn mã này cũng có thêm một vài chức năng ngoài nhưng đều rất thích
hợp cho 1 ứng dụng
Option Explicit
Private Declare Function ReleaseCapture Lib "user32" () 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 SetWindowPos Lib "user32" (ByVal hwnd As Long,
ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal
cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2

Private Const SWP_NOSIZE = &H1
Private Const Flags = SWP_NOMOVE Or SWP_NOSIZE

'Transparency Declarations and Constants
'I copied these from Robert Gainor's Example
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 OffsetRgn Lib "gdi32" (ByVal hRgn As Long,
ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long,
ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long,
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As
Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As
Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As
Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal
X As Long, ByVal Y As Long) As Long
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5

'FormMove and FormOnTop Subs
Private Sub FormOnTop(Frm As Form)
Call SetWindowPos(Frm.hwnd, HWND_TOPMOST, 0&, 0&, 0&, 0&, Flags)
End Sub

Private Sub FormMoveXP(Frm As Form)
Call ReleaseCapture
Call SendMessage(Frm.hwnd, &HA1, 2, 0&)
End Sub

Private Sub CenterForm(Frm As Form)
Frm.Left = Screen.Width / 2 - Frm.Width / 2
Frm.Top = Screen.Height / 2 - Frm.Height / 2
End Sub

'Transparency Function
'I copied this from Robert Gainor's Example
Private Function MakeTransparent(ByRef Frm As Form, ByVal
TransparentColor As Long) As Long
Dim rgnMain As Long, rgnPixel As Long, bmpMain As Long, dcMain As Long
Dim Width As Long, Height As Long, X As Long, Y As Long
Dim ScaleSize As Long, RGBColor As Long
ScaleSize& = Frm.ScaleMode
Frm.ScaleMode = 3
Frm.BorderStyle = 0
Width& = Frm.ScaleX(Frm.Picture.Width, vbHimetric, vbPixels)
Height& = Frm.ScaleY(Frm.Picture.Height, vbHimetric, vbPixels)
Frm.Width = Width& * Screen.TwipsPerPixelX
Frm.Height = Height& * Screen.TwipsPerPixelY
rgnMain& = CreateRectRgn(0&, 0&, Width&, Height&)

dcMain& = CreateCompatibleDC(Frm.hDC)
bmpMain& = SelectObject(dcMain&, Frm.Picture.Handle)
For Y& = 0& To Height&
For X& = 0& To Width&
RGBColor& = GetPixel(dcMain&, X&, Y&)
If RGBColor& = TransparentColor& Then
rgnPixel& = CreateRectRgn(X&, Y&, X& + 1&, Y& + 1&)
CombineRgn rgnMain&, rgnMain&, rgnPixel&, RGN_XOR
DeleteObject rgnPixel&
End If
Next X&
Next Y&
SelectObject dcMain&, bmpMain&
DeleteDC dcMain&
DeleteObject bmpMain&
If rgnMain& <> 0& Then
SetWindowRgn Frm.hwnd, rgnMain&, True
MakeTransparent = rgnMain&
End If
Frm.ScaleMode = ScaleSize&
End Function

'Form Code
Private Sub Form_Load()
Call FormOnTop(Me)
Call CenterForm(Me)
Call MakeTransparent(Me, CLng(0))
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As

Single, Y As Single)
Call FormMoveXP(Me)
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Đôc chiêu 5 : “Chụp ảnh màn hình vào một Picture” home

Xuất xứ : www.ttvnol.com
Binh khí sử dụng : Một Picture và một CommandButton
Đoạn mã :
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As
Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long)
As Long
Private Sub Command1_Click()
Dim wScreen As Long
Dim hScreen As Long
Dim w As Long
Dim h As Long
Picture1.Cls
wScreen = Screen.Width \ Screen.TwipsPerPixelX
hScreen = Screen.Height \ Screen.TwipsPerPixelY
Picture1.ScaleMode = vbPixels
w = Picture1.ScaleWidth
h = Picture1.ScaleHeight

hdcScreen = GetDC(0)
r = StretchBlt(Picture1.hdc, 0, 0, w, h, hdcScreen, 0, 0, wScreen,
hScreen, vbSrcCopy)
End Sub

Đôc chiêu 6 : “Vô hiệu hoá button close và menu của form (cả Alt-F4 luôn)” home

Xuất xứ : www.ttvnol.com
Binh khí sử dụng : Chẳng cần gì ta chỉ cần tay không bắt hổ
Đoạn mã :
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long,
ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As
Long, ByVal bRevert As Long) As Long
Private Const MF_BYPOSITION = &H400&
Private ReadyToClose As Boolean
Private Sub RemoveMenus(frm As Form, _
remove_restore As Boolean, _
remove_move As Boolean, _
remove_size As Boolean, _
remove_minimize As Boolean, _
remove_maximize As Boolean, _
remove_seperator As Boolean, _
remove_close As Boolean)
Dim hMenu As Long

hMenu = GetSystemMenu(hwnd, False)

If remove_close Then DeleteMenu hMenu, 6, MF_BYPOSITION

If remove_seperator Then DeleteMenu hMenu, 5, MF_BYPOSITION
If remove_maximize Then DeleteMenu hMenu, 4, MF_BYPOSITION
If remove_minimize Then DeleteMenu hMenu, 3, MF_BYPOSITION
If remove_size Then DeleteMenu hMenu, 2, MF_BYPOSITION
If remove_move Then DeleteMenu hMenu, 1, MF_BYPOSITION
If remove_restore Then DeleteMenu hMenu, 0, MF_BYPOSITION
End Sub
Private Sub cmdClose_Click()
ReadyToClose = True
Unload Me
End Sub
Private Sub Form_Load()
RemoveMenus Me, False, False, _
False, False, False, True, True
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = Not ReadyToClose
End Sub
Đôc chiêu 7 : “Kéo form di chuyển từ một điểm bất kỳ” home

Xuất xứ : www.allapi.net
Binh khí sử dụng : Lại cũng tay không tập bắt hổ
Đoạn mã :

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 Sub ReleaseCapture Lib "User32" ()
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim lngReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
lngReturnValue = SendMessage(Me.hWnd, WM_NCLBUTTONDOWN,
HTCAPTION, 0&)
End If
End Sub
Private Sub Form_Paint()
Me.Print "Hay keo tui di"
End Sub

Đôc chiêu 8 : “Ghi lại tất cả những phím gõ tên bàn phím” home

Xuất xứ : www.allapi.net
Binh khí sử dụng : Cần một cái Module
Đoạn mã :
Trong Module :
Public Const DT_CENTER = &H1
Public Const DT_WORDBREAK = &H10
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC
As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal
un As Long, ByVal lpDrawTextParams As Any) As Long

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal
nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As
Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal
nIDEvent As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
Integer
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
Global Cnt As Long, sSave As String, sOld As String, Ret As String
Dim Tel As Long
Function GetPressedKey() As String
For Cnt = 32 To 128
If GetAsyncKeyState(Cnt) <> 0 Then
GetPressedKey = Chr$(Cnt)
Exit For
End If
Next Cnt
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse
As Long, ByVal lpTimerFunc As Long)
Ret = GetPressedKey
If Ret <> sOld Then
sOld = Ret
sSave = sSave + sOld
End If
End Sub
Trong Form :
Private Sub Form_Load()
Me.Caption = "Key Spy"

SetTimer Me.hwnd, 0, 1, AddressOf TimerProc
End Sub
Private Sub Form_Paint()
Dim R As RECT
Const mStr = "Nao bat dau go di khi ban an dau X de thoat ban se
thay bat ngo thu vi day."
Me.Cls
Me.ScaleMode = vbPixels
SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight
DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER,
ByVal 0&
End Sub
Private Sub Form_Resize()
Form_Paint
End Sub
Private Sub Form_Unload(Cancel As Integer)
KillTimer Me.hwnd, 0
MsgBox sSave
End Sub
Đôc chiêu 9 : Đóng một ứng dụng bất kỳ home

Xuất xứ : www.echip.com.vn
(Báo eChip)
Binh khí sử dụng : Cần một cái đồng hồ(Timer) chú ý thuộc tính Interval (Riêng tôi cho là 1)
Gíơi thiệu : Đoạn mã đóng một cửa sổ bất ỳ nào đó dựa vào tên của nó
Đoạn mã :
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA"
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam
As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA"

(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub tmrkiemtra_Timer()
Do While FindWindow(vbNullString, "Windows Task Manager") <> 0
‘Gia su toi muon “Thu tieu “ hop thoai “Windows Task Manager”
PostMessage FindWindow(vbNullString, "Windows Task Manager"), &H10, 0&,
0&
Loop
End Sub

- Đây là một chiêu thức rất quan trọng của một phần mềm bảo mật nên có thể đang rất cần cho
nhiều bạn. Riêng tôi do quá “Bất mãn” với cái bọn bạn quỷ quái nên đây s ẽ là một trong những
tuyệt chiêu tôi sử dụng để viết Virus (Theo dự tính tiết thực hành thứ 2 tuần tới sẽ có vài cái máy
tính của trường phải “Nhập viện”) he he nhưng tôi không tàn nhẫn tới mức phá hoại đ
âu tui “Hiền
lắm” chỉ cho bọn bạn gà mờ “Biết ít khoe nhiều trên trường” không “Thực hành” thôi, Chúc các
bạn có những giây phút “Sản khoái” như tôi với độc chiêu này.
Đôc chiêu 10 : Tạo phím nóng cho chương trình : home

Xuất xứ : www.allapi.net
Binh khí sử dụng : Cần một cái Module (Form thì luôn luôn cần rồi)
Đoạn mã : (Bẫy phím Alt+Z)
Trong Module :
Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long
Declare Function DefWindowProc Lib "user32" _
Alias "DefWindowProcA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Public Const WM_SETHOTKEY = &H32
Public Const WM_SHOWWINDOW = &H18
Public Const HK_SHIFTA = &H141 'Shift + A
Public Const HK_SHIFTB = &H142 'Shift * B
Public Const HK_CONTROLA = &H241 'Control + A
Public Const HK_ALTZ = &H45A

'The value of the key-combination has to
'declared in lowbyte/highbyte-format
'That means as a hex-number: the last two
'characters specify the lowbyte (e.g.: 41 = a),
'the first the highbyte (e.g.: 01 = 1 = Shift)
Trong Form :
Private Sub Form_Load()
Me.WindowState = vbMinimized
'Let windows know what hotkey you want for
'your app, setting of lParam has no effect
erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0)
'Check if succesfull
If erg& <> 1 Then
MsgBox "You need another hotkey", vbOKOnly, "Error"
End If
'Tell windows what it should do, when the hotkey
'is pressed -> show the window!
'The setting of wParam and lParam has no effect
erg& = DefWindowProc(Me.hwnd, WM_SHOWWINDOW, 0, 0)
End Sub

Đôc chiêu 11 : Thay đổi hình nền cho Desktop home

Xuất xứ : www.caulacbovb.com
Binh khí sử dụng : Một
CommandButton
Đoạn mã :
Option Explicit
‘ Các hằng số và hàm phục vụ cho việc thay đổi WallPaper
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_SENDWININICHANGE = &H2

Private Declare Function SystemParametersInfo Lib "user32" Alias
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal
lpvParam As Any, ByVal fuWinIni As Long) As Long

‘Phục vụ cho việc ghi giá trị vào Registry
Public Enum REG_TOPLEVEL_KEYS
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_USERS = &H80000003
End Enum

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA"
(ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As
Long
Private 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
Private Const REG_SZ = 1


Public Function ChangeWallPaper(ImageFile As String, Optional Tile As Boolean =
True, Optional Center As Boolean = True) As Boolean
Dim lRet As Long
On Error Resume Next
If Tile Then 'Kieu Tile
WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop",
"TileWallpaper", "1"
Else 'Center or Stretch
WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop",
"TileWallpaper", "0"
'Center
If Center Then WriteStringToRegistry HKEY_CURRENT_USER, "Control
Panel\desktop", "WallpaperStyle", "0" _
Else: WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop",
"TileWallpaper", "2" ' Stretch
End If
lRet = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ImageFile,
SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
ChangeWallPaper = lRet <> 0
End Function

Private Function WriteStringToRegistry(Hkey As REG_TOPLEVEL_KEYS, strPath As
String, strValue As String, strdata As String) As Boolean
Dim bAns As Boolean

On Error GoTo ErrorHandler
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
If (r = 0) Then
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End If
WriteStringToRegistry = (r = 0)
Exit Function
ErrorHandler:
WriteStringToRegistry = False
MsgBox "Thay doi gia tri Registry khong thanh cong", , "Loi :"
End Function

Private Sub Command1_Click()
‘ Load file ảnh c
ần thiết
ChangeWallPaper "C:\Ben Tre.bmp" ‘Kiểu Tile
‘ChangeWallPaper "C:\Ben Tre.bmp", False ‘Kiểu Center
‘ChangeWallPaper "C:\Ben Tre.bmp", False, False ‘Kiểu Stretch
End Sub

Đôc chiêu 12 : Đóng mở khay CD-ROM home
Xuất xứ : www.caulacbovb.com

Lưu ý: Chương trình này chỉ tác dụng tới ổ CD đầu tiên trên hệ thống của bạn (ổ có tên gần với
tên Partition cuối cùng của máy).
Binh khí sử dụng : 2 CommandButton
Đoạn mã :

Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias
"mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString
As String, ByVal uReturnLength As Long, ByVal hWndCallback As Long) As
Long
Function vbmciSendString(ByVal Command As String, ByVal hWnd As Long)
As String
Dim Buffer As String
Dim dwRet As Long
Buffer = Space$(100)
dwRet = mciSendString(Command, ByVal Buffer, Len(Buffer), hWnd)
vbmciSendString = Buffer
End Function
Private Sub Command1_Click()
Dim Dummy As String
Dummy = vbmciSendString("set cdaudio door open", 0)
End Sub
Private Sub Command2_Click()
Dim Dummy As String
Dummy = vbmciSendString("set cdaudio door closed ", 0)

End Sub

Đôc chiêu 13 : Tạo một SystemTray cho ứng dụng của bạn home

Xuất xứ : www.ttvnol.com

Binh khí sử dụng : Tương đối nhiều
Đoạn mã :
PHẦN I _ Tạo một OCX đặt tên là cSysTray.ocx

Bạn vào VB tạo một ActiveX Control, sau đó add một Module đặt tên là: mSysTray.bas và có nội
dung như sau :
Module mSysTray.bas
Option Explicit

Public 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
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As
Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As
Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal
dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource
As Any, ByVal ByteLen As Long)
Public Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge
As Long, ByVal grfFlags As Long) As Boolean
Public Const GWL_USERDATA = (-21&)
Public Const GWL_WNDPROC = (-4&)
Public Const WM_USER = &H400&
Public Const TRAY_CALLBACK = (WM_USER + 101&)
Public Const NIM_ADD = &H0&
Public Const NIM_MODIFY = &H1&
Public Const NIM_DELETE = &H2&
Public Const NIF_MESSAGE = &H1&
Public Const NIF_ICON = &H2&
Public Const NIF_TIP = &H4&
Public Const WM_MOUSEMOVE = &H200&
Public Const WM_LBUTTONDOWN = &H201&

Public Const WM_LBUTTONUP = &H202&
Public Const WM_LBUTTONDBLCLK = &H203&
Public Const WM_RBUTTONDOWN = &H204&
Public Const WM_RBUTTONUP = &H205&
Public Const WM_RBUTTONDBLCLK = &H206&
Public Const BDR_RAISEDOUTER = &H1&
Public Const BDR_RAISEDINNER = &H4&
Public Const BF_LEFT = &H1&
Public Const BF_TOP = &H2&
Public Const BF_RIGHT = &H4&
Public Const BF_BOTTOM = &H8&
Public Const BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM
Public Const BF_SOFT = &H1000&
Public 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 Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public PrevWndProc As Long
'

Public Function SubWndProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As
Long, ByVal lParam As Long) As Long
'
Dim SysTray As cSysTray
Dim ClassAddr As Long
'
Select Case MSG
Case TRAY_CALLBACK
ClassAddr = GetWindowLong(hwnd, GWL_USERDATA)
CopyMemory SysTray, ClassAddr, 4

SysTray.SendEvent lParam, wParam

CopyMemory SysTray, 0&, 4
End Select

SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam)
'
End Function
'
End mSysTray.bas
Sau khi bạn tạo module trên rồi, bạn tạo tiếp một cSysTray.ctl như sau:
cSysTray.ctl
Option Explicit
Private gInTray As Boolean
Private gTrayId As Long
Private gTrayTip As String
Private gTrayHwnd As Long
Private gTrayIcon As StdPicture
Private gAddedToTray As Boolean

Const MAX_SIZE = 510
Private Const defInTray = False
Private Const defTrayTip = "System Tray Control" & vbNullChar
Private Const sInTray = "InTray"
Private Const sTrayIcon = "TrayIcon"
Private Const sTrayTip = "TrayTip"
Public Event MouseMove(Id As Long)
Public Event MouseDown(Button As Integer, Id As Long)
Public Event MouseUp(Button As Integer, Id As Long)
Public Event MouseDblClick(Button As Integer, Id As Long)
'
Private Sub UserControl_Initialize()
'
gInTray = defInTray
gAddedToTray = False
gTrayId = 0
gTrayHwnd = hwnd
'
End Sub
'
'
Private Sub UserControl_InitProperties()
'
InTray = defInTray
TrayTip = defTrayTip
Set TrayIcon = Picture
'
End Sub
'
'

Private Sub UserControl_Paint()
'
Dim edge As RECT
'
edge.Left = 0
edge.Top = 0
edge.Bottom = ScaleHeight
edge.Right = ScaleWidth
DrawEdge hDC, edge, BDR_RAISEDOUTER, BF_RECT Or BF_SOFT
'
End Sub
'
'
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
'
With PropBag
InTray = .ReadProperty(sInTray, defInTray)
Set TrayIcon = .ReadProperty(sTrayIcon, Picture)
TrayTip = .ReadProperty(sTrayTip, defTrayTip)
End With
'
End Sub
'
'
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'
With PropBag
.WriteProperty sInTray, gInTray
.WriteProperty sTrayIcon, gTrayIcon
.WriteProperty sTrayTip, gTrayTip

End With
'
End Sub
'
'
Private Sub UserControl_Resize()
'
Height = MAX_SIZE
Width = MAX_SIZE
'
End Sub
'
'
Private Sub UserControl_Terminate()
'
If InTray Then
InTray = False
End If
'
End Sub
'
'
Public Property Set TrayIcon(Icon As StdPicture)
'
Dim Tray As NOTIFYICONDATA
Dim rc As Long
'
If Not (Icon Is Nothing) Then
If (Icon.Type = vbPicTypeIcon) Then
If gAddedToTray Then

Tray.uID = gTrayId
Tray.hwnd = gTrayHwnd
Tray.hIcon = Icon.Handle
Tray.uFlags = NIF_ICON
Tray.cbSize = Len(Tray)

rc = Shell_NotifyIcon(NIM_MODIFY, Tray)
End If

Set gTrayIcon = Icon
Set Picture = Icon
PropertyChanged sTrayIcon
End If
End If
'
End Property
'
'
Public Property Get TrayIcon() As StdPicture
'
Set TrayIcon = gTrayIcon
'
End Property
'
'
Public Property Let TrayTip(Tip As String)
'
Dim Tray As NOTIFYICONDATA
Dim rc As Long
'

If gAddedToTray Then
Tray.uID = gTrayId
Tray.hwnd = gTrayHwnd
Tray.szTip = Tip & vbNullChar
Tray.uFlags = NIF_TIP
Tray.cbSize = Len(Tray)

rc = Shell_NotifyIcon(NIM_MODIFY, Tray)
End If

gTrayTip = Tip
PropertyChanged sTrayTip
'
End Property
'
'
Public Property Get TrayTip() As String
'
TrayTip = gTrayTip
'
End Property
'
'
Public Property Let InTray(Show As Boolean)
'
Dim ClassAddr As Long
'
If (Show <> gInTray) Then
If Show Then
If Ambient.UserMode Then

PrevWndProc = SetWindowLong(gTrayHwnd, GWL_WNDPROC, AddressOf SubWndProc)


SetWindowLong gTrayHwnd, GWL_USERDATA, ObjPtr(Me)

AddIcon gTrayHwnd, gTrayId, TrayTip, TrayIcon
gAddedToTray = True
End If
Else
If gAddedToTray Then
DeleteIcon gTrayHwnd, gTrayId

SetWindowLong gTrayHwnd, GWL_WNDPROC, PrevWndProc
gAddedToTray = False
End If
End If

gInTray = Show
PropertyChanged sInTray
End If
'
End Property
'
'
Public Property Get InTray() As Boolean
'
InTray = gInTray
'
End Property
'

'
Private Sub AddIcon(hwnd As Long, Id As Long, Tip As String, Icon As StdPicture)
'
Dim Tray As NOTIFYICONDATA
Dim tFlags As Long
Dim rc As Long
'
Tray.uID = Id
Tray.hwnd = hwnd

If Not (Icon Is Nothing) Then
Tray.hIcon = Icon.Handle
Tray.uFlags = Tray.uFlags Or NIF_ICON
Set gTrayIcon = Icon
End If

If (Tip <> "") Then
Tray.szTip = Tip & vbNullChar
Tray.uFlags = Tray.uFlags Or NIF_TIP
gTrayTip = Tip
End If

Tray.uCallbackMessage = TRAY_CALLBACK
Tray.uFlags = Tray.uFlags Or NIF_MESSAGE
Tray.cbSize = Len(Tray)

rc = Shell_NotifyIcon(NIM_ADD, Tray)
'
End Sub
'

'
Private Sub DeleteIcon(hwnd As Long, Id As Long)
'
Dim Tray As NOTIFYICONDATA
Dim rc As Long
'
Tray.uID = Id
Tray.hwnd = hwnd
Tray.uFlags = 0&
Tray.cbSize = Len(Tray)

rc = Shell_NotifyIcon(NIM_DELETE, Tray)
'
End Sub
'
'
Friend Sub SendEvent(MouseEvent As Long, Id As Long)
'
Select Case MouseEvent
Case WM_MOUSEMOVE
RaiseEvent MouseMove(Id)
Case WM_LBUTTONDOWN
RaiseEvent MouseDown(vbLeftButton, Id)
Case WM_LBUTTONUP
RaiseEvent MouseUp(vbLeftButton, Id)
Case WM_LBUTTONDBLCLK
RaiseEvent MouseDblClick(vbLeftButton, Id)
Case WM_RBUTTONDOWN
RaiseEvent MouseDown(vbRightButton, Id)
Case WM_RBUTTONUP

RaiseEvent MouseUp(vbRightButton, Id)
Case WM_RBUTTONDBLCLK
RaiseEvent MouseDblClick(vbRightButton, Id)
End Select
'
End Sub
'
End cSysTray.ctl
Sau khi tạo xong hai phần trên, bạn biên dịch nó thành một Control OCX và đặt tên là
cSysTray.ocx Vậy là bạn đã xong phần thứ nhất
PHẦN II: tạo một project mới để dùng OCX cSysTray.ocx
Bạn nhập đoạn mã sau vào :
Private Sub cSysTray1_MouseUp(Button As Integer, Id As Long)
'Nếu bạn nhấn chuột phải lên systray Icon
Select Case Button
Case vbRightButton
PopupMenu MainMenu
End Select
End Sub
Private Sub Form_Load()
Me.Visible=False
cSysTray1.InTray=True
cSysTray1.TrayTip=" />
End Sub
Đôc chiêu 14 : Thay đổi Font tiếng việt cho Menu của Window home

Xuất xứ : www.pcworld.com.vn

Binh khí sử dụng : Không
Đoạn mã :

'Các hằng được dùng cho các hàm API
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 Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScoolHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long

lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type
Const SPI_SetNonClientMetrics = 42
Const SPI_GettNonClientMetrics = 41
'Các hàm API cần thiết
'Hàm SystemParametersInfo sẽ gọi lại tất cả thông tin các tham số ngoài hệ thống. Nó còn có
khả năng cập nhật những thông tin do người dùng tự phát triển. Chính vì thế bạn dùng nó để
thay đổi Font là rất hợp lí
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA"
(ByVal uAction As Long, Byval uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As
Long) As Long
Private Const REF_StructureSize = 340 ` Sizeof( NONCLIENTMETRICS)
Private Const VNI_FontHeight = -13
Private Const VNI_FontWeight = 700
Private Const VNI_FontName = "VNI-Palatin"
Private Const VNI_FontLen = 11 `Len(VNI_FontName)

Private FontMetric As NONCLIENTMETRICS
Private OldFontMetric As NONCLIENTMETRICS
'Thủ tục này dùng để thay đổi Font của Menu
Private Sub ChangeFont()
Dim I As Integer
Dim VarGT As Long
Dim VarHeight As Long
Dim VarWeight As Long
Dim VarStr As String
FontMetric.cbSize = REG_StructureSize
VarGT = SystemParametersInfo(SPI_GetNonClientMetrics,REG_StructureSize, FontMetric, 0)

OldFontMetric =FontMetric
FontMetric.lfCaptionFont.lfHeight = VNI_FontHeight
FontMetric.lfCaptionFont.lfWeight = VNI_FontWeight
VarStr = VNI_FontName
For I=1 To LF_FaceSize
If I <= VNI_FontLen Then
FontMetric.lfCaptionFont.lfFaceName(I)= CByte(Asc(Mid(VarStr,I,1)))
FontMetric.lfMenuFont.lfFaceName(I)= CByte(Asc(Mid(VarStr,I,1)))
Else
FontMetric.lfCaptionFont.lfFaceName(I) = 0
FontMetric.lfMenuFont.lfFaceName(I) = 0
End If
Next I
VarGT= SystemParametersInfo
(SPI_SetNonClientMetrics, REG_StructureSize, FontMetric,0)
End Sub
'THủ tục để phục hồi lại font cho menu
Private Sub RestoreFont()
Dim VarGT As Long
VarGT= SystemParametersInfo (SPI_SetNonClientMetrics, REG_StructureSize, OldFontMetric,0)
End Sub
'Khi form được khởi tạo thì đổi Font

Private Sub Form_Load()
ChangeFont
End Sub
'Khi form thoát thì khởi tạo lại font mặc định cho hệ thống bước này quan trọng vì nếu bạn không
phục hồi lại font hệ thống thì các menu khác trong Window sẽ nhảy lộn xộn cả lên
Private Sub Form_UnLoad(Cancel As Integer)