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

'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

Xem chi tiết: Tài liệu Chiêu thức lập trình Visual Basic pdf