Tài liệu Chiêu thức lập trình VB ppt

Chiêu thức lập trình VB

Tác giả : Lê Nguyên Dũng
Lớp 11C
1
Trường THPT Đắk Nông
Địa chỉ nhà : Thôn 1, thị trấn Đăk Mâm Huyện Krông Nô Tỉnh
Đắk Nông
(Thị xã Gia Nghĩa Tỉnh Đăk Nông ngày 9/9/2005)
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ứ

Lời nói đầu

Tôi hay nói cho lễ phép thì có thể là “Em” đã trải qua một khoảng thời gian dài, tìm hiểu và học
tập thì nhận thấy sự khó khăn khi ìm kiếm tài liệu để học lập trình, nhất là với những kỹ nâng lập
trình nâng cao vì trên thị trường hiện nay chỉ toàn là các sách dạy “Qua cho có” và rất sơ cấp.
Qua cuốn sách này tôi muốn chia sẽ kiến thức mình học được để chia sẽ với những người mới
học mong rằng bản than các ban sẽ viết được những phần mềm hay và hữu ích giúp ích cho
cộng đồng. Các bạn có thể tự hỏi tại sao tôi lại ngu ngô viết ra cuốn “Sổ tay” này rồi lại tung miễn
phí lên mạng ? Có thể là do quá tuyệt vọng vì ở “Cái xứ sở” của tôi một thằng con nít như tôi (Dù
lớp 11 nhưng tôi quá bé con để có thể gọi là người lớn nói rõ hơn là tôi mới chỉ cao 1m40 và
nặng vỏn vẹn 35kg), tôi thật sự rất buồn khi các phần mềm mình viết ra rồi lại “Tự mình sài” khi
đem “Khoe” với thầy cô thì họ chỉ nhìn thấy và Nhe răng cười đúng một cái “ rồi đi (Cho dù đó là
một phần mềm tôi rất kỳ vọng đã bỏ ra 5 tháng trời để viết cuối cùng sau một lần sơ ý làm hư
máy của mẹ rồi hoảng quá Ghost lại máy của mẹ lại mà quên “Cất” mã nguồn vậy là xong), tôi
muốn đem mấy cái phần mềm mình đi thi nhưng lại chẳng có cuộc thi nào để thi (Trí tuệ việt nam
thì quá cao còn ở cái tỉnh mới thành lập này thì tôi tìm hiểu mãi mà chưa cò), tôi lại nghĩ nên đi
thi ở Đăk Lăk nhưng ta lại là “Con nhà lính” nên chẳng có điều kiện, nhưng chuyện đã hết đâu
lên tỉnh này học trong cái lớp “ Có thể gọi là chuyện Toán” thì lại toàn là “Con quan” người nhỏ
con lại ứng xử kém bị chúng nó chèn ép (Thậm chí nhiều khi là chúng còn tìm cách hạ nhục vì

vốn học đã không giỏi lại thiếu “Phe cánh” nên điểm chẳng được cao chẳng bù mấy tụi nó, vậy là
bọn chúng cứ tìm cách mà “Khui” ra). Ngay bây giờ tôi đang “Chịu” một khoản nợ không đâu (Tới
30 ngàn mà trong người bây giờ không có tới 10 ngàn bố mẹ lại ở xa cách mình tận 120 cây số ,
mà đó làm bọn kia “Ép phe” chứ tôi đâu có làm gì tự nhiên thua lý oan 30 nghìn). À mà thôi hình
như do quá buồn nên tôi “Khai hết” mong các bạn thông cảm, thôi bây giờ ta vào việc :


Đôc chiêu 1 : “Thả một câu từ trên cao xuống” (Có thể nói như vậy)
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(Loo
o
p)
'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ữ
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ã :
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

Đôc chiêu 3 : Hiện con trỏ động tại một đối tượng nào đó
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)
Xuất xứ : www.ttvnol.com
Binh khí sử dụng : Chỉ cần một cái Form và một cái module
Yêu cầu hệ thống
Mọi Version Windows. Tuy nhiên, bạn nên dùng Win2k/XP để có thể làm 1 số hiệu ứng đặc biệt
cho Form như trong suốt chẳng hạn
Đoạn mã :

‘ Trong Module
Option Explicit
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 Const RGN_OR = 2
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As

Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As
Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Public Const BITMAP_SIZE = 24 ''=Len(BITMAP)
Dim bmByte() As Byte

Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA"
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam
As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
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 SetLayeredWindowAttributes Lib "user32" (ByVal
hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags
As Long) As Long
Public Const WS_EX_LAYERED = &H80000

Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte =
vbNull)
Dim X As Long, Y As Long
Dim Rgn1 As Long, Rgn2 As Long
Dim SPos As Long, EPos As Long
Dim bm As BITMAP
Dim hbm As Long
Dim Wid As Long, Hgt As Long
Dim xoff As Long, yoff As Long
''Lấy thông tin về hình nền
hbm = hForm.Picture ''Lấy Handle của hình trong Form
GetObjectAPI hbm, Len(bm), bm ''Lấy thông tin về hình nền trong Form và
lưu trong biến bm
Wid = bm.bmWidth ''Chiều rộng bức hình được lưu vào bộ đệm Buffer
Hgt = bm.bmHeight ''Chiều cao bức hình được lưu vào bộ đệm Buffer
''Xử lí cho Form
With hForm
.ScaleMode = vbPixels ''Chuyển sang chế độ pixels cho Form
xoff = (.ScaleX(.Width, vbTwips, vbPixels) - .ScaleWidth) / 2
yoff = .ScaleY(.Height, vbTwips, vbPixels) - .ScaleHeight - xoff
.Width = (Wid + xoff * 2) * Screen.TwipsPerPixelX ''Định lại chiều rộng
của Form cho vừa với hình nền
.Height = (Hgt + xoff + yoff) * Screen.TwipsPerPixelY ''Định lại chiều
cao củ
a Form cho vừa với hình nền
End With

''Khởi tạo mảng động bmByte() trong phạm vi diện tích của hình
ReDim bmByte(1 To Wid, 1 To Hgt)
''Chép toàn bộ bức hình vào bộ đệm Buffer của bộ nhớ
GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1)

If transColor = vbNull Then transColor = bmByte(1, 1)

''Khởi tạo miền chữ nhật đầu tiên
Rgn1 = CreateRectRgn(0, 0, 0, 0)

''Duyệt từng pixels của hình
For Y = 1 To Hgt
X = 0 ''Khởi tạo giá trị X ban đầu
Do
'' Bắt đầu dịch chuyển vị trí pixels của hình theo chiều ngang
X = X + 1

While (bmByte(X, Y) = transColor) And (X < Wid)
X = X + 1
Wend
SPos = X ''Nếu có dấu hiệu màu khác thì đánh dấu vị trí bắt đầu
While (bmByte(X, Y) <> transColor) And (X < Wid)
X = X + 1
Wend
EPos = X - 1 ''Nếu có dấu hiệu màu giống thì đánh dấu vị trí kết thúc

If SPos <= EPos Then
''Khởi tạo miền hình chữ nhật thứ hai
Rgn2 = CreateRectRgn(SPos - 1 + xoff, Y - 1 + yoff, EPos + xoff, Y +
yoff)

''Chồng 2 miền hình chữ nhật đã tạo với toán tử OR để loại trừ những
điểm ảnh giống nhau
'' Và lưu vào giá trị của miền chữ nhật thứ nhất
CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
DeleteObject Rgn2
End If
Loop Until X >= Wid
Next Y

''Định lại hình dáng của Form theo Rgn1
SetWindowRgn hForm.hwnd, Rgn1, True
DeleteObject Rgn1

End Sub
‘ Trong Form
Option Explicit
Private Sub Form_DblClick()
Unload Me
End Sub
Private Sub Form_Load()
Me.P.Picture = LoadPicture("C:\skin.jpg") ‘Đường dẫn file ảnh cần thiết
If Me.Picture <> 0 Then
Call SetAutoRgn(Me)
End If
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
If Button = vbLeftButton Then
ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&

End If
End Sub
Đôc chiêu 5 : “Chụp ảnh màn hình vào một Picture”
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)”
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ỳ”
Xuất xứ : www.allapi.com
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”
Xuất xứ : www.allapi.com
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 10 : Đóng một ứng dụng bất kỳ
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 n ẫ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 11 : Tạo phím nóng cho chương trình :
Xuất xứ : www.allapi.com
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)
En

d Sub
Đôc chiêu 12 : Thay đổi hình nền cho Desktop
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 13 : Đóng mở khay CD-ROM
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

- Sau khi họp phụ huynh về “Được” thầy chủ nhiệm “Tuyên bố” hiện nay mình
đang nằm trong tốp “Báo động đỏ” hay như thầy nói nguyên văn là “Tốp dưới”
cậu mình đã áp dụng biện pháp mạnh cho thằng cháu thân yêu, với phương
châm “Chơi là chửi” mình đã phải “Cai máy tính máy ngày rồi”,vì vậy hiện nay
cuốn sách phải “Tạm ngừng” để tui còn phải “Leo lên” thứ hạng khác trong lớp.
Hẹn gặp lại ở phiên bãn nâng cấp tiếp theo của cuốn sách
À quên kèm theo cuốn sách tui có gửi thêm 1 bộ mã nguồn làm đẹp cho các chắc hẳn điều này
sẽ làm các bạn hài lòng, và cũng xin nhắc Ai ở đ ịa b àn tỉnh Đắk Nông thì có thể liên hệ trực tiếp
để trao đổi thêm đặc biệt là tại Gia Nghĩa và Huyện Krông Nô)
Bye ( Lần này là thiệt)