Lập trình Visual Basic với các chiêu thức

Chia sẻ: Hoang Nhan | Ngày: | Loại File: PDF | Số trang:46

Thêm vào BST

Báo xấu

462
lượt xem 225
download

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

Lập trình Visual Basic với chiêu thức sẽ giới thiệu đến bạn 27 độc chiêu giúp bạn lập trình Visual Basic hiệu quả. Mong rằng thông qua quyển sách này có thể giúp ích cho bạn trong việc lập trình.

Chủ đề:

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

Lưu

Nội dung Text: Lập trình Visual Basic với các chiêu thức

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ê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 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ẽ được nâ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ất của đời đệ là đậu vào khoa Công Nghệ Thông Tin Đại học Bách Khoa Hồ Chí Minh đệ mong rằ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 chiêu 1 : “Thả một câu từ tr cao xuống” (Có thể nó như vậy) Đôc c rên ói chiêu 2 : Hiện một câu bằn cách lần lư hiện từng chữ Đôc c ng ượt Đôc c chiêu 3 : Hiện con trỏ động tại một đối tư g ượng nào đó chiêu 4 : Form có hình dạn theo một hì ảnh bất k ỳ Đôc c m ng ình Đôc c chiêu 5 : “Chụ ảnh màn hì vào một P ụp ình Picture” Đôc c chiêu 6 : “Vô hiệu hoá butto close và m h on menu của form (cả Alt-F4 lu m uôn)” Đôc c chiêu 7 : “Kéo form di chuy từ một điể bất kỳ” o yển ểm Đôc c chiêu 8 : “Ghi lại tất cả nhữ phím gõ t bàn phím” ững tên ” Đôc c chiêu 9 : Đóng một ứng dụng bất kỳ g Đôc c chiêu 10 : Tạo phím nóng c chương t o cho trình Đôc c chiêu 11 : Tha đổi hình nề cho Deskto ay ền op Đôc c chiêu 12 : Đón mở khay C ng CD-ROM Đôc c chiêu 13 : Tạo một System o mTray cho ứng dụng của bạ g ạn Đôc c chiêu 14 : Tha đổi Font tiế việt cho M ay ếng Menu của Winndow Đôc c chiêu 15 : So sánh hai ảnh Đôc c chiêu 16 : Liệt kê danh sác các thành p t ch phần phần cứ trong máy ứng y Đôc c chiêu 17 : Chưương trình kh động cùng với Window hởi g wns Đôc c chiêu 18 : Play một file nhạ Midi y ạc chiêu 19 : Kho một file ảnh định dạng . Đôc c oá .bmp Đôc c chiêu 20 : Để form của bạn ở chế độ “Lu nổi” n uôn Đôc c chiêu 21 : TexxtBox chỉ “Chị nhận số ịu” chiêu 22 : Để form trở nên trong suốt Đôc c Đôc c chiêu 23 : Lấy tên người sử dung của W y ử Windowns chiêu 24 : Ché cả màn hìn làm việc vào một Pictur Đôc c ép nh re Đôc c chiêu 25 : Dấu dữ liệu dạng text vào 1 fi bất kỳ u g ile chiêu 26 :Mở từng hộp thoạ trong Control Panel Đôc c ại Đôc Đ chiêu 27 : Mã hoá dữ liệu dạng text t
Đô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 '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: overkillpage@gmx.net" '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)
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
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 12 : Đóng mở khay CD-ROM home Xuất xứ : www.caulacbovb.com Lưu ý: Chương trình này chỉ tác dụng tới ổ CD đầu tiên trên hệ thống của bạn (ổ có tên gần với tên Partition cuối cùng của máy). Binh khí sử dụng : 2 CommandButton Đoạn mã : Option Explicit Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hWndCallback As Long) As Long Function vbmciSendString(ByVal Command As String, ByVal hWnd As Long) As String Dim Buffer As String Dim dwRet As Long Buffer = Space$(100) dwRet = mciSendString(Command, ByVal Buffer, Len(Buffer), hWnd) vbmciSendString = Buffer End Function Private Sub Command1_Click() Dim Dummy As String Dummy = vbmciSendString("set cdaudio door open", 0) End Sub Private Sub Command2_Click() Dim Dummy As String Dummy = vbmciSendString("set cdaudio door closed ", 0) End Sub Đôc chiêu 13 : Tạo một SystemTray cho ứng dụng của bạn home Xuất xứ : www.ttvnol.com Binh khí sử dụng : Tương đối nhiều Đoạn mã : PHẦN I _ Tạo một OCX đặt tên là cSysTray.ocx Bạn vào VB tạo một ActiveX Control, sau đó add một Module đặt tên là: mSysTray.bas và có nội dung như sau : --------- Module mSysTray.bas ---------- Option Explicit Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long) Public Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Boolean Public Const GWL_USERDATA = (-21&) Public Const GWL_WNDPROC = (-4&) Public Const WM_USER = &H400& Public Const TRAY_CALLBACK = (WM_USER + 101&) Public Const NIM_ADD = &H0& Public Const NIM_MODIFY = &H1& Public Const NIM_DELETE = &H2& Public Const NIF_MESSAGE = &H1& Public Const NIF_ICON = &H2& Public Const NIF_TIP = &H4& Public Const WM_MOUSEMOVE = &H200& Public Const WM_LBUTTONDOWN = &H201& Public Const WM_LBUTTONUP = &H202& Public Const WM_LBUTTONDBLCLK = &H203& Public Const WM_RBUTTONDOWN = &H204& Public Const WM_RBUTTONUP = &H205& Public Const WM_RBUTTONDBLCLK = &H206& Public Const BDR_RAISEDOUTER = &H1& Public Const BDR_RAISEDINNER = &H4& Public Const BF_LEFT = &H1& Public Const BF_TOP = &H2& Public Const BF_RIGHT = &H4& Public Const BF_BOTTOM = &H8& Public Const BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM Public Const BF_SOFT = &H1000& Public Type NOTIFYICONDATA cbSize As Long hwnd As Long uID As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * 64 End Type Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type
Public PrevWndProc As Long '------------------------------------------------------------ Public Function SubWndProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '------------------------------------------------------------ Dim SysTray As cSysTray Dim ClassAddr As Long '------------------------------------------------------------ Select Case MSG Case TRAY_CALLBACK ClassAddr = GetWindowLong(hwnd, GWL_USERDATA) CopyMemory SysTray, ClassAddr, 4 SysTray.SendEvent lParam, wParam CopyMemory SysTray, 0&, 4 End Select SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam) '------------------------------------------------------------ End Function '------------------------------------------------------------ --------- End mSysTray.bas ------------------- Sau khi bạn tạo module trên rồi, bạn tạo tiếp một cSysTray.ctl như sau: ----------------- cSysTray.ctl--------------------- Option Explicit Private gInTray As Boolean Private gTrayId As Long Private gTrayTip As String Private gTrayHwnd As Long Private gTrayIcon As StdPicture Private gAddedToTray As Boolean Const MAX_SIZE = 510 Private Const defInTray = False Private Const defTrayTip = "System Tray Control" & vbNullChar Private Const sInTray = "InTray" Private Const sTrayIcon = "TrayIcon" Private Const sTrayTip = "TrayTip" Public Event MouseMove(Id As Long) Public Event MouseDown(Button As Integer, Id As Long) Public Event MouseUp(Button As Integer, Id As Long) Public Event MouseDblClick(Button As Integer, Id As Long) '------------------------------------------------------- Private Sub UserControl_Initialize() '-------------------------------------------------------
gInTray = defInTray gAddedToTray = False gTrayId = 0 gTrayHwnd = hwnd '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_InitProperties() '------------------------------------------------------- InTray = defInTray TrayTip = defTrayTip Set TrayIcon = Picture '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_Paint() '------------------------------------------------------- Dim edge As RECT '------------------------------------------------------- edge.Left = 0 edge.Top = 0 edge.Bottom = ScaleHeight edge.Right = ScaleWidth DrawEdge hDC, edge, BDR_RAISEDOUTER, BF_RECT Or BF_SOFT '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_ReadProperties(PropBag As PropertyBag) '------------------------------------------------------- With PropBag InTray = .ReadProperty(sInTray, defInTray) Set TrayIcon = .ReadProperty(sTrayIcon, Picture) TrayTip = .ReadProperty(sTrayTip, defTrayTip) End With '------------------------------------------------------- End Sub '------------------------------------------------------- '------------------------------------------------------- Private Sub UserControl_WriteProperties(PropBag As PropertyBag) '------------------------------------------------------- With PropBag .WriteProperty sInTray, gInTray .WriteProperty sTrayIcon, gTrayIcon .WriteProperty sTrayTip, gTrayTip End With '------------------------------------------------------- End Sub '-------------------------------------------------------
'------------------------------------------------------- Private Sub UserControl_Resize() '------------------------------------------------------- Height = MAX_SIZE 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 '-------------------------------------------------------