Chiêu thức lập trình VB 6.0
Tác giả : Lê Nguyên Dũng
Lớp 12C
1
trường THPT Đăk Nông (Thị xã Gia Nghĩa - Đ ăk Nông)
Email :
Nick : dungcoi_vb
Địa chỉ nhà : Thôn 1, thị trấn Đăk Mâm Huyện Krông Nô Tỉnh Đắk Nông
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 1
Chiêu thức lập trình VB 6.0
Lời nói đầu
Dù tài liệu này không có mấy người đọc nhưng dù sao với trách nhiệm và sự “Rãnh rỗi” của mình mình sẽ
tiếp tục bổ xung thêm cuốn tài liệu này đến khi nào có thể
Trong sách tôi xin chỉ rõ xuất xứ, mong rằng các ban cũng sẽ tôn trọng 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ợ.
Cuốn tài liệu được chia sẽ hoàn toàn miễn phí. Nếu có thắc mác bạn hãy liên hệ với tác giả.
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 2
Chiêu thức lập trình VB 6.0
Mục lục
Đôc chiêu 1 : “Thả một câu từ trên cao xuống” (Có thể nói nh ư vậy)
Đôc chiêu 2 : Hiện một câu bằng cách lần lượt hiện từng chữ
Đôc chiêu 3 : Hiện con trỏ động tại một đối t ượng nào đó
Đôc chiêu 4 : Form có hình dạng theo một hình ảnh bất k ỳ
Đôc chiêu 5 : “Chụp ảnh màn hình vào một Picture”
Đôc chiêu 6 : “Vô hiệu hoá button close và menu của form (cả Alt-F4 luôn)”

Đôc chiêu 7 : “Kéo form di chuyển từ một điểm bất kỳ”
Đôc chiêu 8 : “Ghi lại tất cả những phím gõ tên bàn phím”
Đôc chiêu 9 : Đóng một ứng dụng bất kỳ
Đôc chiêu 10 : Tạo phím nóng cho chương trình
Đôc chiêu 11 : Thay đổi hình nền cho Desktop
Đôc chiêu 12 : Đóng mở khay CD-ROM
Đôc chiêu 13 : Tạo một SystemTray cho ứng dụng của bạn
Đôc chiêu 14 : Thay đổi Font tiếng việt cho Menu của Window
Đôc chiêu 15 : So sánh hai ảnh
Đôc chiêu 16 : Liệt kê danh sách các thành phần phần cứng trong máy
Đôc chiêu 17 : Chương trình khởi động cùng với Windowns
Đôc chiêu 18 : Play một file nhạc Midi
Đôc chiêu 19 : Khoá một file ảnh định dạng .bmp
Đôc chiêu 20 : Để form của bạn ở chế độ “Luôn nổi”
Đôc chiêu 21 : TextBox chỉ “Chịu” nhận số
Đôc chiêu 22 : Để form trở nên trong suốt
Đôc chiêu 23 : Lấy tên người sử dung của Windowns
Đôc chiêu 24 : Chép cả màn hình làm việc vào một Picture
Đôc chiêu 25 : Dấu dữ liệu dạng text vào 1 file bất kỳ
Đôc chiêu 26 :Mở từng hộp thoại trong Control Panel
Đôc chiêu 27 : Mã hoá dữ liệu dạng text
Đôc chiêu 28 : Lấy mật khẩu khi đang Chat trên Yahoo
Đôc chiêu 29 : Biến giao diện chương trình theo phong cách Windowns XP
Đôc chiêu 30 : Làm cho ứng dụng từ từ rõ dần khi Load và mờ dần khi Unload
Đôc chiêu 31 : Không cho dịch ngược phần mềm của bạn
Đôc chiêu 32 : Lấy kiểu (Type) của đĩa
Đôc chiêu 33 : Ẩn thanh Taskbar hoặc các thành phần khác
Đôc chiêu 34 : Nhìn Windowns XP CD Key
Đôc chiêu 35 : Tùy chọn hộp thoại thông báo của chương trình
Đôc chiêu 36 : Đưa con trỏ đến một vị trí nhất định

Đôc chiêu 37 : Hiệu ứng khi Click vào
Đôc chiêu 38 : Hàm dùng để đoc số ra chữ
Đôc chiêu 39 : Để chương trình bạn có giao diện “Nữa trong suốt”
Đôc chiêu 40 : Gửi thông điệp tới một máy tinh bất kỳ
Đôc chiêu 41 : Quét tất cả các máy trong mạng LAN
Đôc chiêu 42 : Liệt kê tất cả các tài nguyên mạng đang trong trạng thái “Mở”
Đôc chiêu 43 : Kiểm tra máy tính của bạn có kết nối Internet hay không
Đôc chiêu 44 : Liệt kê tất cả các Process đang hoạt động trong máy
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 3
Chiêu thức lập trình VB 6.0
Đô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 'Khởi tạo
‘Khai báo
Dim StartTime(100) 'Thời gian bắt đầu di chuyển lên
xuống
Dim DownMovement(100) As Boolean ' Chúng ta phải lên xuông bao nhiêu
??????
Dim MoveDistance As Double ' Khoảng cách đích đến
Dim YPos(100) As Double ' Tọa độ Y của chữ
Dim MovementDone(100) As Boolean ' Là đúng khi lên / xuống hoàn
thành
Dim StartHeight(100) As Double ' Chiều cào phải đi xuống ???
Dim UpMovementTime(100) As Double ' Chiều dài mà ký tự sẽ lấy để

đi lên
Dim PowerLoss(100) As Double ' Đã chạm tới điểm dưới
dung ?????
Dim Message As String ' Thông điệp bạn cần hiển thị
Dim Looop As Integer ' Biến vòng lặp
Dim TextColor(100) As ColorConstants ' Màu sắc của mỗi ký tự

' Thiết lập

picture1.ScaleMode = 4
picture1.FontName = "Courier New" ' Font chữ của ký tự

Message = "Ô hiệu ứng chữ !!! Mail của tác giả nè (-_-) :
" ' Thông điệp bạn muốn hiển thị

For Looop = 1 To Len(Message)

PowerLoss(Looop) = 0.2 + ((Rnd * 25) / 100)
StartHeight(Looop) = 0
TextColor(Looop) = RGB(80 + Looop * 2, 80 + Looop * 2, 255)

Next Looop

For Looop = 1 To Len(Message)
StartTime(Looop) = Timer 'Đặt thời gian xuống,
cần phải tính tóan vị trí
Next Looop

Do


picture1.Cls ' Xóa Picture

‘ Vòng lặp để tiến hành đếm từng ký tự
For Looop = 1 To Len(Message)


If DownMovement(Looop) = True Then

MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 * ((Timer -
StartTime(Looop)) ^ 2))) ' Tính khoảng cách rơi

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 4
Chiêu thức lập trình VB 6.0
If YPos(Looop) >= picture1.ScaleHeight - 1 Then
MovementDone(Looop) = True ' Ký tự chạm phần đáy dưới Downmovement (Di
chuyển xuống) hoàn thành

Else
MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 *
(UpMovementTime(Looop) - (Timer - StartTime(Looop))) ^ 2)) ' Yónh khoảng cách
rơi

If YPos(Looop) <= StartHeight(Looop) + 0.1 Then
MovementDone(Looop) = True ' Ký tự chạm đến điểm cao nhất upmovement (Di
chuyển lên trên) hòan thành

End If


YPos(Looop) = MoveDistance

If YPos(Looop) > picture1.ScaleHeight - 1 Then
' Nếu ký tự thỏa điều kiện này phải sửa lại chúng
YPos(Looop) = picture1.ScaleHeight - 1
' Tại vị trí dưới cùng
End If

picture1.CurrentX = picture1.ScaleWidth / 2 - Int((Len(Message) /
2)) + Looop
picture1.CurrentY = YPos(Looop)
' Đặt vị tọa độ Y cho ký tự
picture1.ForeColor = TextColor(Looop)
' Đặt màu cho ký tự
picture1.Print Mid(Message, Looop, 1)
' Đặt chử vào picture1

Next Looop

DoEvents

For Looop = 1 To Len(Message)

If MovementDone(Looop) = True Then

If DownMovement(Looop) = True Then ' Khoảng cách chuyển đổi
giữa up/downmovement (Di chuyển lên/Di chuyển xuống)
DownMovement(Looop) = False
StartHeight(Looop) = StartHeight(Looop) +
((picture1.ScaleHeight - StartHeight(Looop)) * PowerLoss(Looop)) '

Startheight mới, bởi vì tốc độ bị sai ?!?!
UpMovementTime(Looop) = Sqr((picture1.ScaleHeight -
StartHeight(Looop)) / (0.5 * 9.81)) ' D9ộ dài bao nhiêu sẽ upmovement
(Di chuyển lên trên) sau đó???
Else
DownMovement(Looop) = True
End If

StartTime(Looop) = Timer ' Đặt thời gian bắt đầu
di chuyển
MovementDone(Looop) = False
End If

Next Looop

Loop ' Đến khi StartHeight = picture1.ScaleHeight

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 5
Chiêu thức lập trình VB 6.0
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) cả hai cái đồng hồ đều phải Enabled=
False 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 ' Chuỗi ký tự
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") ' Nhập ký tự
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 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

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 6
Chiêu thức lập trình VB 6.0
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
Đô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
Chú ý : Phần này trong lần xuất bản 1 có lỗi

Xuất xứ : www.pscode.com
Binh khí sử dụng :
- 1 picture mang tên : picMainSkin trong đó có chứa sẵn một hình ảnh bất kỳ mà bạn muốn làm giao
diện chương trình màu tượng trưng cho trong suốt là màu ở câu lệnh TransparentColor =
GetPixel(hDC, 0, 0) có nghĩa là sẽ chính là màu của điểm có tọa độ (0,0) trên Picture này đây chính
là một trong những điểm thú vị của đọan Code này.
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 7
Chiêu thức lập trình VB 6.0
- 1 Module
Đoạn mã :
‘Trong Module :
Option Explicit
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As
Long, ByVal y As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal
hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1
As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal
hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Public Const RGN_OR = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

Public Function MakeRegion(picSkin As PictureBox) As Long
Dim x As Long, y As Long, StartLineX As Long
Dim FullRegion As Long, LineRegion As Long
Dim TransparentColor As Long
Dim InFirstRegion As Boolean
Dim InLine As Boolean
Dim hDC As Long
Dim PicWidth As Long
Dim PicHeight As Long

hDC = picSkin.hDC
PicWidth = picSkin.ScaleWidth
PicHeight = picSkin.ScaleHeight

InFirstRegion = True: InLine = False
x = y = StartLineX = 0
TransparentColor = GetPixel(hDC, 0, 0)

For y = 0 To PicHeight - 1
For x = 0 To PicWidth - 1

If GetPixel(hDC, x, y) = TransparentColor Or x = PicWidth Then
If InLine Then
InLine = False
LineRegion = CreateRectRgn(StartLineX, y, x, y + 1)

If InFirstRegion Then
FullRegion = LineRegion
InFirstRegion = False
Else

CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
DeleteObject LineRegion
End If
End If
Else
If Not InLine Then
InLine = True
StartLineX = x
End If
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 8
Chiêu thức lập trình VB 6.0
End If
Next
Next

MakeRegion = FullRegion
End Function
‘Trong Form:
Option Explicit
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
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Sub Form_Load()
Dim WindowRegion As Long
picMainSkin.ScaleMode = vbPixels

picMainSkin.AutoRedraw = True
picMainSkin.AutoSize = True
picMainSkin.BorderStyle = vbBSNone
Me.BorderStyle = vbBSNone
Set picMainSkin.Picture = picMainSkin.Picture
Me.Width = picMainSkin.Width
Me.Height = picMainSkin.Height
WindowRegion = MakeRegion(picMainSkin)
SetWindowRgn Me.hwnd, WindowRegion, True
End Sub
Private Sub picMainSkin_MouseDown(Button As Integer, Shift As Integer, x As
Single, y As Single)
ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
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)
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 9
Chiêu thức lập trình VB 6.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ã :
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 10
Chiêu thức lập trình VB 6.0

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"

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 11
Chiêu thức lập trình VB 6.0
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
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 12
Chiêu thức lập trình VB 6.0
'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",
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 13
Chiêu thức lập trình VB 6.0
"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
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 14
Chiêu thức lập trình VB 6.0
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
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 15
Chiêu thức lập trình VB 6.0
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()
'-------------------------------------------------------
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 16
Chiêu thức lập trình VB 6.0

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
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 17
Chiêu thức lập trình VB 6.0
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
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 18
Chiêu thức lập trình VB 6.0
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
'-------------------------------------------------------
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 19
Chiêu thức lập trình VB 6.0
'-------------------------------------------------------
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)
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 20
Chiêu thức lập trình VB 6.0
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
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 21
Chiêu thức lập trình VB 6.0
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
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 22
Chiêu thức lập trình VB 6.0

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)
RestoreFont
End
End Sub
Đôc chiêu 14 : Hiện Icon đại diện cho một loại file home
Xuất xứ : www.ttvnol.com
Binh khí sử dụng : 1 Module
Đoạn mã :
'Bạn tạo một module mới và dán đoạn mã này vào
'Các hàm API cần thiết
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 RegSetValue Lib "advapi32.dll" _
Alias "RegSetValueA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal dwType As Long, _
ByVal lpData As String, _
ByVal cbData As Long) As Long
'Thực chất của việc tạo Icon riêng cho ứng dụng là việc bạn đăng kí cho Registry của Window biết là bạn đã
đăng nhập vào "quốc gia" của họ
'Các hằng số mang giá trị phản hồi từ Registry
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1&
Const ERROR_BADKEY = 2&
Const ERROR_CANTOPEN = 3&
Const ERROR_CANTREAD = 4&
Const ERROR_CANTWRITE = 5&
Const ERROR_OUTOFMEMORY = 6&
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 23
Chiêu thức lập trình VB 6.0
Const ERROR_INVALID_PARAMETER = 7&
Const ERROR_ACCESS_DENIED = 8&
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const MAX_PATH = 260&
Private Const REG_SZ = 1
'Hàm API cần thiết
Private Declare Sub SHChangeNotify Lib "shell32.dll" _
(ByVal wEventId As Long, _

ByVal uFlags As Long, _
dwItem1 As Any, _
dwItem2 As Any)
Const SHCNE_ASSOCCHANGED = &H8000000
Const SHCNF_IDLIST = &H0&
'THủ tục dùng để đăng kí Icon cho chương trình
Public Sub Tao_File_He_Thong()
'Giả sử rằng chương trình của bạn sẽ đăng kí ch việc thay đổi các tập tin có phần mở rộng là "*.mp3".
Dim sKeyName As String 'Nắm tên khoá trong Reg
Dim sKeyValue As String ''Nắm một giá trị của khoá trong Reg
Dim Ret&
Dim lphKey&
Dim Path As String
Path = App.Path
If Right(Path, 1) <> "\" Then
Path = Path & "\"
End If
'Đăng kí cho một giá trị khoá gốc là tên ứng dụng của bạn. Ví dụ, bạn đặt tên cho chương trình là
"Khunglongbeo.exe" thì giá trị của nó là "Khunglongbeo" và khi hoàn tất, tập tin sẽ có thuộc tính là
"Khunglongbeo's File " (một hàng chữ mờ mờ bên dưới các file mà bạn thương gặp)
sKeyName = "Khunglongbeo"
sKeyValue = "Khunglongbeo's File"
Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
Ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
'Đăng kí phần mở rộng "*.mp3" liên kết với ứng dụng mang tên "khunglongbeo" của bạn
sKeyName = ".mp3"
sKeyValue = "Khunglongbeo"
Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
Ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
sKeyName = "Khunglongbeo"

sKeyValue = Path & "Khunglongbeo.exe %1"
Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
Ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, _
sKeyValue, MAX_PATH)
'Lấy một Icon làm ảnh đại diện
sKeyName = "Khunglongbeo"
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 24
Chiêu thức lập trình VB 6.0
'Bạn hãy tìm một file .Ico bất kì và lưu vào đường dẫn sẽ qui định bên dưới (đường dẫn này tuỳ bạn qui định)
sKeyValue = Path & "KLB.ico"
Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
Ret& = RegSetValue&(lphKey&, "DefaultIcon", REG_SZ, _
sKeyValue, MAX_PATH)
'Đổi Icon
SHChangeNotify SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0
End Sub
'**************************
'Phần mã này bạn hãy nhập vào Form1
Private Sub Form_Load()
Tao_File_He_Thong
End Sub
Đôc chiêu 15 : So sánh hai ảnh home
Xuất xứ : www.ttvnol.com
Binh khí sử dụng :
Bạn vẽ lên form1 các control sau :
2 picture box (picture1 và picture2)
2 label edit (label1 và label2)
1 command button (command1)

Bạn trang trí form như hình sau:
Đoạn mã :
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 25