Các chiêu thức lập trình Visual Basic

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...

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

Email của mình : le.nguyendung@gmail.com

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ênbả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 thamgia 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ẽ đượcnâ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ấtcủa đời đệ là đậu vào khoa Công Nghệ Thông Tin Đại học Bách Khoa Hồ Chí Minh đệ mongrằ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 11C1 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ợ

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 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

For Looop = 1 To Len(Message)

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

'Looping throung the textmessage

For Looop = 1 To Len(Message)

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 Theupmovement is complete

picture1.ForeColor = TextColor(Looop) 'Setting the letters color

picture1.Print Mid(Message, Looop, 1) 'Text picture1put

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

Đ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

ReDim Preserve Letters(0)

ReDim Preserve Letters(Len(TXT))

// 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

'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

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 AsAny) 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)

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 LongDim 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&

If rgnMain& <> 0& Then

SetWindowRgn Frm.hwnd, rgnMain&, True

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

Private Const MF_BYPOSITION = &H400&

Private ReadyToClose As Boolean

Private Sub RemoveMenus(frm As Form, _

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

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

Private Declare Sub ReleaseCapture Lib "User32" ()

Const WM_NCLBUTTONDOWN = &HA1

Private Sub Form_Paint()

Me.Print "Hay keo tui di"

Public Const DT_CENTER = &H1

Public Const DT_WORDBREAK = &H10

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

Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse

As Long, ByVal lpTimerFunc As Long)

Private Sub Form_Load()

Me.Caption = "Key Spy"

SetTimer Me.hwnd, 0, 1, AddressOf TimerProc

SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight

DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0&

Đô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 AsAny) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate 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ềnlắ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)

‘ 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

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",

Dim bAns As Boolean

On Error GoTo ErrorHandler

Dim keyhand As Long

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

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) AsString

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)

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

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

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()

InTray = ReadProperty(sInTray, defInTray)

Set TrayIcon = ReadProperty(sTrayIcon, Picture)

TrayTip = ReadProperty(sTrayTip, defTrayTip)

.WriteProperty sInTray, gInTray

.WriteProperty sTrayIcon, gTrayIcon

.WriteProperty sTrayTip, gTrayTip

End With

' -End Sub

' -If Not (Icon Is Nothing) Then

If (Icon.Type = vbPicTypeIcon) Then

Set gTrayIcon = Icon

Set Picture = Icon

' -Public Property Get TrayIcon() As StdPicture

DeleteIcon gTrayHwnd, gTrayId

SetWindowLong gTrayHwnd, GWL_WNDPROC, PrevWndProc

gAddedToTray = False

End If

End If

' -Dim Tray As NOTIFYICONDATA

Dim tFlags As Long

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

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