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

Chia sẻ: Bui Thuy Huong | Ngày: | Loại File: DOC | Số trang:62

Thêm vào BST

Báo xấu

100
lượt xem 13
download

Download Vui lòng tải xuống để xem tài liệu đầy đủ

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

Chủ đề:

Bình luận(0) Đăng nhập để gửi bình luận!

Lưu

Nội dung Text: Chiêu thức lập trình VB 6.0

Chiêu thức lập trình VB 6.0 Tác giả : Lê Nguyên Dũng Lớp 12C1 trường THPT Đăk Nông (Thị xã Gia Nghĩa - Đ ăk Nông) Email : dungcoivb@gmail.com 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 12C1 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 12C1 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 12C1 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() 'Khởi tạo Randomize Timer ‘Khai báo 'Thời gian bắt đầu di chuyển lên Dim StartTime(100) xuống ' Chúng ta phải lên xuông bao nhiêu Dim DownMovement(100) As Boolean ?????? ' Khoảng cách đích đến Dim MoveDistance As Double ' Tọa độ Y của chữ Dim YPos(100) As Double ' Là đúng khi lên / xuống hoàn Dim MovementDone(100) As Boolean thành ' Chiều cào phải đi xuống ??? Dim StartHeight(100) As Double ' Chiều dài mà ký tự sẽ lấy để Dim UpMovementTime(100) As Double đi lên ' Đã chạm tới điểm dưới Dim PowerLoss(100) As Double dung ????? ' Thông điệp bạn cần hiển thị Dim Message As String ' Biến vòng lặp Dim Looop As Integer ' Màu sắc của mỗi ký tự Dim TextColor(100) As ColorConstants ' Thiết lập picture1.ScaleMode = 4 ' Font chữ của ký tự picture1.FontName = "Courier New" Message = "Ô hiệu ứng chữ !!! Mail của tác giả nè (-_-) : ' Thông điệp bạn muốn hiển thị overkillpage@gmx.net" 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) 'Đặt thời gian xuống, StartTime(Looop) = Timer 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 12C1 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 ' Ký tự chạm phần đáy dưới Downmovement (Di MovementDone(Looop) = True 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)
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 ' Chuỗi ký tự 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() ' Nhập ký tự 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 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 12C1 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 = Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 7
Chiêu thức lập trình VB 6.0 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. - 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 Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 8
Chiêu thức lập trình VB 6.0 StartLineX = x End If 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 Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 9
Chiêu thức lập trình VB 6.0 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 Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 10
Chiêu thức lập trình VB 6.0 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 Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 11
Chiêu thức lập trình VB 6.0 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 Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 12
Chiêu thức lập trình VB 6.0 Public Const HK_ALTZ = &H45A 'The value of the key-combination has to 'declared in lowbyte/highbyte-format 'That means as a hex-number: the last two 'characters specify the lowbyte (e.g.: 41 = a), 'the first the highbyte (e.g.: 01 = 1 = Shift) Trong Form : Private Sub Form_Load() Me.WindowState = vbMinimized 'Let windows know what hotkey you want for 'your app, setting of lParam has no effect erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0) 'Check if succesfull If erg& 1 Then MsgBox "You need another hotkey", vbOKOnly, "Error" End If 'Tell windows what it should do, when the hotkey 'is pressed -> show the window! 'The setting of wParam and lParam has no effect erg& = DefWindowProc(Me.hwnd, WM_SHOWWINDOW, 0, 0) End Sub Đôc chiêu 11 : Thay đổi hình nền cho Desktop home Xuất xứ : www.caulacbovb.com Binh khí sử dụng : Một CommandButton Đoạn mã : Option Explicit ‘ Các hằng số và hàm phục vụ cho việc thay đổi WallPaper Private Const SPIF_UPDATEINIFILE = &H1 Private Const SPI_SETDESKWALLPAPER = 20 Private Const SPIF_SENDWININICHANGE = &H2 Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long ‘Phục vụ cho việc ghi giá trị vào Registry Public Enum REG_TOPLEVEL_KEYS HKEY_CLASSES_ROOT = &H80000000 HKEY_CURRENT_CONFIG = &H80000005 HKEY_CURRENT_USER = &H80000001 HKEY_DYN_DATA = &H80000006 HKEY_LOCAL_MACHINE = &H80000002 HKEY_PERFORMANCE_DATA = &H80000004 HKEY_USERS = &H80000003 End Enum Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long Private Const REG_SZ = 1 Public Function ChangeWallPaper(ImageFile As String, Optional Tile As Boolean = True, Optional Center As Boolean = True) As Boolean Dim lRet As Long On Error Resume Next If Tile Then 'Kieu Tile WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper", "1" Else 'Center or Stretch WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper", "0" Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 13
Chiêu thức lập trình VB 6.0 'Center If Center Then WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "WallpaperStyle", "0" _ Else: WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper", "2" ' Stretch End If lRet = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ImageFile, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) ChangeWallPaper = lRet 0 End Function Private Function WriteStringToRegistry(Hkey As REG_TOPLEVEL_KEYS, strPath As String, strValue As String, strdata As String) As Boolean Dim bAns As Boolean On Error GoTo ErrorHandler Dim keyhand As Long Dim r As Long r = RegCreateKey(Hkey, strPath, keyhand) If (r = 0) Then r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata)) r = RegCloseKey(keyhand) End If WriteStringToRegistry = (r = 0) Exit Function ErrorHandler: WriteStringToRegistry = False MsgBox "Thay doi gia tri Registry khong thanh cong", , "Loi :" End Function Private Sub Command1_Click() ‘ Load file ảnh cần thiết ChangeWallPaper "C:\Ben Tre.bmp" ‘Kiểu Tile ‘ChangeWallPaper "C:\Ben Tre.bmp", False ‘Kiểu Center ‘ChangeWallPaper "C:\Ben Tre.bmp", False, False ‘Kiểu Stretch End Sub Đôc chiêu 12 : Đóng mở khay CD-ROM home Xuất xứ : www.caulacbovb.com Lưu ý: Chương trình này chỉ tác dụng tới ổ CD đầu tiên trên hệ thống của bạn (ổ có tên g ần v ới tên Partition cuối cùng của máy). Binh khí sử dụng : 2 CommandButton Đoạn mã : Option Explicit Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hWndCallback As Long) As Long Function vbmciSendString(ByVal Command As String, ByVal hWnd As Long) As String Dim Buffer As String Dim dwRet As Long Buffer = Space$(100) dwRet = mciSendString(Command, ByVal Buffer, Len(Buffer), hWnd) vbmciSendString = Buffer End Function Private Sub Command1_Click() Dim Dummy As String Dummy = vbmciSendString("set cdaudio door open", 0) End Sub Private Sub Command2_Click() Dim Dummy As String Dummy = vbmciSendString("set cdaudio door closed ", 0) End Sub Đôc chiêu 13 : Tạo một SystemTray cho ứng dụng của bạn home Xuất xứ : www.ttvnol.com Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 14
Chiêu thức lập trình VB 6.0 Binh khí sử dụng : Tương đối nhiều Đoạn mã : PHẦN I _ Tạo một OCX đặt tên là cSysTray.ocx Bạn vào VB tạo một ActiveX Control, sau đó add một Module đ ặt tên là: mSysTray.bas và có n ội dung nh ư sau : --------- Module mSysTray.bas ---------- Option Explicit Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long) Public Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Boolean Public Const GWL_USERDATA = (-21&) Public Const GWL_WNDPROC = (-4&) Public Const WM_USER = &H400& Public Const TRAY_CALLBACK = (WM_USER + 101&) Public Const NIM_ADD = &H0& Public Const NIM_MODIFY = &H1& Public Const NIM_DELETE = &H2& Public Const NIF_MESSAGE = &H1& Public Const NIF_ICON = &H2& Public Const NIF_TIP = &H4& Public Const WM_MOUSEMOVE = &H200& Public Const WM_LBUTTONDOWN = &H201& Public Const WM_LBUTTONUP = &H202& Public Const WM_LBUTTONDBLCLK = &H203& Public Const WM_RBUTTONDOWN = &H204& Public Const WM_RBUTTONUP = &H205& Public Const WM_RBUTTONDBLCLK = &H206& Public Const BDR_RAISEDOUTER = &H1& Public Const BDR_RAISEDINNER = &H4& Public Const BF_LEFT = &H1& Public Const BF_TOP = &H2& Public Const BF_RIGHT = &H4& Public Const BF_BOTTOM = &H8& Public Const BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM Public Const BF_SOFT = &H1000& Public Type NOTIFYICONDATA cbSize As Long hwnd As Long uID As Long uFlags As Long Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 15
Chiêu thức lập trình VB 6.0 uCallbackMessage As Long hIcon As Long szTip As String * 64 End Type Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public PrevWndProc As Long '------------------------------------------------------------ Public Function SubWndProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '------------------------------------------------------------ Dim SysTray As cSysTray Dim ClassAddr As Long '------------------------------------------------------------ Select Case MSG Case TRAY_CALLBACK ClassAddr = GetWindowLong(hwnd, GWL_USERDATA) CopyMemory SysTray, ClassAddr, 4 SysTray.SendEvent lParam, wParam CopyMemory SysTray, 0&, 4 End Select SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam) '------------------------------------------------------------ End Function '------------------------------------------------------------ --------- End mSysTray.bas ------------------- Sau khi bạn tạo module trên rồi, bạn tạo tiếp một cSysTray.ctl nh ư sau: ----------------- cSysTray.ctl--------------------- Option Explicit Private gInTray As Boolean Private gTrayId As Long Private gTrayTip As String Private gTrayHwnd As Long Private gTrayIcon As StdPicture Private gAddedToTray As Boolean Const MAX_SIZE = 510 Private Const defInTray = False Private Const defTrayTip = "System Tray Control" & vbNullChar Private Const sInTray = "InTray" Private Const sTrayIcon = "TrayIcon" Private Const sTrayTip = "TrayTip" Public Event MouseMove(Id As Long) Public Event MouseDown(Button As Integer, Id As Long) Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 16
Chiêu thức lập trình VB 6.0 Public Event MouseUp(Button As Integer, Id As Long) Public Event MouseDblClick(Button As Integer, Id As Long) '------------------------------------------------------- Private Sub UserControl_Initialize() '------------------------------------------------------- gInTray = defInTray gAddedToTray = False gTrayId = 0 gTrayHwnd = hwnd '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_InitProperties() '------------------------------------------------------- InTray = defInTray TrayTip = defTrayTip Set TrayIcon = Picture '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_Paint() '------------------------------------------------------- Dim edge As RECT '------------------------------------------------------- edge.Left = 0 edge.Top = 0 edge.Bottom = ScaleHeight edge.Right = ScaleWidth DrawEdge hDC, edge, BDR_RAISEDOUTER, BF_RECT Or BF_SOFT '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_ReadProperties(PropBag As PropertyBag) '------------------------------------------------------- With PropBag InTray = .ReadProperty(sInTray, defInTray) Set TrayIcon = .ReadProperty(sTrayIcon, Picture) TrayTip = .ReadProperty(sTrayTip, defTrayTip) End With '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_WriteProperties(PropBag As PropertyBag) '------------------------------------------------------- With PropBag .WriteProperty sInTray, gInTray .WriteProperty sTrayIcon, gTrayIcon .WriteProperty sTrayTip, gTrayTip End With '------------------------------------------------------- Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 17
Chiêu thức lập trình VB 6.0 End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_Resize() '------------------------------------------------------- Height = MAX_SIZE Width = MAX_SIZE '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_Terminate() '------------------------------------------------------- If InTray Then InTray = False End If '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Public Property Set TrayIcon(Icon As StdPicture) '------------------------------------------------------- Dim Tray As NOTIFYICONDATA Dim rc As Long '------------------------------------------------------- If Not (Icon Is Nothing) Then If (Icon.Type = vbPicTypeIcon) Then If gAddedToTray Then Tray.uID = gTrayId Tray.hwnd = gTrayHwnd Tray.hIcon = Icon.Handle Tray.uFlags = NIF_ICON Tray.cbSize = Len(Tray) rc = Shell_NotifyIcon(NIM_MODIFY, Tray) End If Set gTrayIcon = Icon Set Picture = Icon PropertyChanged sTrayIcon End If End If '------------------------------------------------------- End Property '------------------------------------------------------- '------------------------------------------------------- Public Property Get TrayIcon() As StdPicture '------------------------------------------------------- Set TrayIcon = gTrayIcon '------------------------------------------------------- End Property '------------------------------------------------------- '------------------------------------------------------- Public Property Let TrayTip(Tip As String) '------------------------------------------------------- Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 18
Chiêu thức lập trình VB 6.0 Dim Tray As NOTIFYICONDATA Dim rc As Long '------------------------------------------------------- If gAddedToTray Then Tray.uID = gTrayId Tray.hwnd = gTrayHwnd Tray.szTip = Tip & vbNullChar Tray.uFlags = NIF_TIP Tray.cbSize = Len(Tray) rc = Shell_NotifyIcon(NIM_MODIFY, Tray) End If gTrayTip = Tip PropertyChanged sTrayTip '------------------------------------------------------- End Property '------------------------------------------------------- '------------------------------------------------------- Public Property Get TrayTip() As String '------------------------------------------------------- TrayTip = gTrayTip '------------------------------------------------------- End Property '------------------------------------------------------- '------------------------------------------------------- Public Property Let InTray(Show As Boolean) '------------------------------------------------------- Dim ClassAddr As Long '------------------------------------------------------- If (Show gInTray) Then If Show Then If Ambient.UserMode Then PrevWndProc = SetWindowLong(gTrayHwnd, GWL_WNDPROC, AddressOf SubWndProc) SetWindowLong gTrayHwnd, GWL_USERDATA, ObjPtr(Me) AddIcon gTrayHwnd, gTrayId, TrayTip, TrayIcon gAddedToTray = True End If Else If gAddedToTray Then DeleteIcon gTrayHwnd, gTrayId SetWindowLong gTrayHwnd, GWL_WNDPROC, PrevWndProc gAddedToTray = False End If End If gInTray = Show PropertyChanged sInTray End If '------------------------------------------------------- End Property '------------------------------------------------------- Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 19
Chiêu thức lập trình VB 6.0 '------------------------------------------------------- Public Property Get InTray() As Boolean '------------------------------------------------------- InTray = gInTray '------------------------------------------------------- End Property '------------------------------------------------------- '------------------------------------------------------- Private Sub AddIcon(hwnd As Long, Id As Long, Tip As String, Icon As StdPicture) '------------------------------------------------------- Dim Tray As NOTIFYICONDATA Dim tFlags As Long Dim rc As Long '------------------------------------------------------- Tray.uID = Id Tray.hwnd = hwnd If Not (Icon Is Nothing) Then Tray.hIcon = Icon.Handle Tray.uFlags = Tray.uFlags Or NIF_ICON Set gTrayIcon = Icon End If If (Tip "") Then Tray.szTip = Tip & vbNullChar Tray.uFlags = Tray.uFlags Or NIF_TIP gTrayTip = Tip End If Tray.uCallbackMessage = TRAY_CALLBACK Tray.uFlags = Tray.uFlags Or NIF_MESSAGE Tray.cbSize = Len(Tray) rc = Shell_NotifyIcon(NIM_ADD, Tray) '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub DeleteIcon(hwnd As Long, Id As Long) '------------------------------------------------------- Dim Tray As NOTIFYICONDATA Dim rc As Long '------------------------------------------------------- Tray.uID = Id Tray.hwnd = hwnd Tray.uFlags = 0& Tray.cbSize = Len(Tray) rc = Shell_NotifyIcon(NIM_DELETE, Tray) '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Friend Sub SendEvent(MouseEvent As Long, Id As Long) '------------------------------------------------------- Select Case MouseEvent Case WM_MOUSEMOVE Tác giả : Lê Nguyên Dũng lớp 12C1 trường THPT Đăk Nông Trang 20