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

Email của mình : le.nguyendung@gmail.comNick : 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

Đô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.comBinh 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) <= 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) EndEnd 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.comBinh 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 StringPublic Letters() As StringPublic TXT As StringPublic CurLetter As IntegerPublic TEXTT As StringPublic r As IntegerForm :Private Sub cmdClear_Click()lblText.Caption = ""End Sub

Private Sub cmdExit_Click()EndEnd 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 + 1lblText.Caption = TEXTTlblText.Caption = lblText.Caption & "_"If r = 6 Thenr = 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 = lblTextTimer1.Enabled = TrueTimer2.Enabled = False

HERE:Timer2.Enabled = FalseEnd 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.comBinh 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ụngPrivate 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 longDim 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,OldCurEnd 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.comBinh 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ụngOption ExplicitPrivate Declare Function ReleaseCapture Lib "user32" () As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate 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 LongPrivate Const HWND_TOPMOST = -1Private Const SWP_NOMOVE = &H2Private Const SWP_NOSIZE = &H1Private Const Flags = SWP_NOMOVE Or SWP_NOSIZE

'Transparency Declarations and Constants'I copied these from Robert Gainor's ExamplePrivate Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPrivate Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As LongPrivate 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 LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As LongPrivate Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As LongPrivate Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As LongPrivate Const RGN_AND = 1Private Const RGN_OR = 2Private Const RGN_XOR = 3Private Const RGN_DIFF = 4Private Const RGN_COPY = 5

'FormMove and FormOnTop SubsPrivate 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 ReleaseCaptureCall SendMessage(Frm.hwnd, &HA1, 2, 0&)End Sub

Private Sub CenterForm(Frm As Form)Frm.Left = Screen.Width / 2 - Frm.Width / 2Frm.Top = Screen.Height / 2 - Frm.Height / 2End Sub

'Transparency Function'I copied this from Robert Gainor's ExamplePrivate Function MakeTransparent(ByRef Frm As Form, ByVal TransparentColor As Long) As LongDim rgnMain As Long, rgnPixel As Long, bmpMain As Long, dcMain As LongDim Width As Long, Height As Long, X As Long, Y As LongDim ScaleSize As Long, RGBColor As LongScaleSize& = Frm.ScaleModeFrm.ScaleMode = 3Frm.BorderStyle = 0Width& = Frm.ScaleX(Frm.Picture.Width, vbHimetric, vbPixels)Height& = Frm.ScaleY(Frm.Picture.Height, vbHimetric, vbPixels)Frm.Width = Width& * Screen.TwipsPerPixelXFrm.Height = Height& * Screen.TwipsPerPixelYrgnMain& = 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 IfFrm.ScaleMode = ScaleSize&End Function

'Form CodePrivate 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)EndEnd SubĐôc chiêu 5 : “Chụp ảnh màn hình vào một Picture” home Xuất xứ : www.ttvnol.comBinh 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 LongPrivate 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 LongDim hScreen As LongDim w As LongDim h As LongPicture1.Cls

wScreen = Screen.Width \ Screen.TwipsPerPixelXhScreen = Screen.Height \ Screen.TwipsPerPixelY

Picture1.ScaleMode = vbPixelsw = Picture1.ScaleWidthh = 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.comBinh 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 LongPrivate Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Private Const MF_BYPOSITION = &H400&

Private ReadyToClose As BooleanPrivate 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_BYPOSITIONIf remove_seperator Then DeleteMenu hMenu, 5, MF_BYPOSITIONIf remove_maximize Then DeleteMenu hMenu, 4, MF_BYPOSITIONIf remove_minimize Then DeleteMenu hMenu, 3, MF_BYPOSITIONIf remove_size Then DeleteMenu hMenu, 2, MF_BYPOSITIONIf remove_move Then DeleteMenu hMenu, 1, MF_BYPOSITIONIf remove_restore Then DeleteMenu hMenu, 0, MF_BYPOSITIONEnd Sub

Private Sub cmdClose_Click()ReadyToClose = TrueUnload MeEnd Sub

Private Sub Form_Load()RemoveMenus Me, False, False, _False, False, False, True, TrueEnd Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)Cancel = Not ReadyToCloseEnd 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.netBinh 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 LongPrivate Declare Sub ReleaseCapture Lib "User32" ()Const WM_NCLBUTTONDOWN = &HA1Const HTCAPTION = 2Private 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 IfEnd SubPrivate 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.netBinh khí sử dụng : Cần một cái ModuleĐoạn mã :Trong Module :Public Const DT_CENTER = &H1Public Const DT_WORDBREAK = &H10Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypeDeclare 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 LongDeclare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As LongDeclare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As LongDeclare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As IntegerDeclare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongGlobal Cnt As Long, sSave As String, sOld As String, Ret As StringDim Tel As LongFunction GetPressedKey() As String

For Cnt = 32 To 128 If GetAsyncKeyState(Cnt) <> 0 Then GetPressedKey = Chr$(Cnt) Exit For End If Next CntEnd FunctionSub 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 IfEnd Sub

Trong Form :Private Sub Form_Load() Me.Caption = "Key Spy" SetTimer Me.hwnd, 0, 1, AddressOf TimerProcEnd SubPrivate 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 SubPrivate Sub Form_Resize() Form_PaintEnd SubPrivate Sub Form_Unload(Cancel As Integer) KillTimer Me.hwnd, 0 MsgBox sSaveEnd 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 LongPrivate 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&LoopEnd 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.netBinh 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 LongDeclare Function DefWindowProc Lib "user32" _Alias "DefWindowProcA" (ByVal hwnd As Long, _ByVal wMsg As Long, ByVal wParam As Long, _ByVal lParam As Long) As LongPublic Const WM_SETHOTKEY = &H32Public Const WM_SHOWWINDOW = &H18Public Const HK_SHIFTA = &H141 'Shift + APublic Const HK_SHIFTB = &H142 'Shift * BPublic Const HK_CONTROLA = &H241 'Control + APublic 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.comBinh 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ếtChangeWallPaper "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.comLư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 ExplicitPrivate 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 LongFunction vbmciSendString(ByVal Command As String, ByVal hWnd As Long) As StringDim Buffer As StringDim dwRet As LongBuffer = Space$(100)dwRet = mciSendString(Command, ByVal Buffer, Len(Buffer), hWnd)vbmciSendString = BufferEnd FunctionPrivate Sub Command1_Click()Dim Dummy As StringDummy = vbmciSendString("set cdaudio door open", 0)End SubPrivate Sub Command2_Click()Dim Dummy As StringDummy = 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.comBinh 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 LongPublic Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As

Long, ByVal nIndex As Long) As LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As LongPublic 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_BOTTOMPublic Const BF_SOFT = &H1000&

Public Type NOTIFYICONDATAcbSize As Longhwnd As LonguID As LonguFlags As LonguCallbackMessage As LonghIcon As LongszTip As String * 64End TypePublic Type RECTLeft As LongTop As LongRight As LongBottom As LongEnd 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 cSysTrayDim ClassAddr As Long'------------------------------------------------------------Select Case MSGCase TRAY_CALLBACKClassAddr = GetWindowLong(hwnd, GWL_USERDATA)CopyMemory SysTray, ClassAddr, 4

SysTray.SendEvent lParam, wParam

CopyMemory SysTray, 0&, 4End 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 ExplicitPrivate gInTray As BooleanPrivate gTrayId As LongPrivate gTrayTip As StringPrivate gTrayHwnd As LongPrivate gTrayIcon As StdPicturePrivate gAddedToTray As BooleanConst MAX_SIZE = 510

Private Const defInTray = FalsePrivate 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 = defInTraygAddedToTray = FalsegTrayId = 0gTrayHwnd = hwnd'-------------------------------------------------------End Sub'-------------------------------------------------------

'-------------------------------------------------------Private Sub UserControl_InitProperties()'-------------------------------------------------------InTray = defInTrayTrayTip = defTrayTipSet TrayIcon = Picture'-------------------------------------------------------End Sub'-------------------------------------------------------

'-------------------------------------------------------Private Sub UserControl_Paint()'-------------------------------------------------------Dim edge As RECT'-------------------------------------------------------edge.Left = 0edge.Top = 0edge.Bottom = ScaleHeightedge.Right = ScaleWidthDrawEdge hDC, edge, BDR_RAISEDOUTER, BF_RECT Or BF_SOFT'-------------------------------------------------------End Sub'-------------------------------------------------------

'-------------------------------------------------------Private Sub UserControl_ReadProperties(PropBag As PropertyBag)'-------------------------------------------------------With PropBagInTray = .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, gTrayTipEnd With'-------------------------------------------------------End Sub'-------------------------------------------------------

'-------------------------------------------------------Private Sub UserControl_Resize()'-------------------------------------------------------Height = MAX_SIZEWidth = MAX_SIZE'-------------------------------------------------------End Sub'-------------------------------------------------------

'-------------------------------------------------------Private Sub UserControl_Terminate()'-------------------------------------------------------If InTray ThenInTray = FalseEnd If'-------------------------------------------------------End Sub'-------------------------------------------------------

'-------------------------------------------------------Public Property Set TrayIcon(Icon As StdPicture)'-------------------------------------------------------Dim Tray As NOTIFYICONDATADim rc As Long'-------------------------------------------------------If Not (Icon Is Nothing) ThenIf (Icon.Type = vbPicTypeIcon) ThenIf gAddedToTray ThenTray.uID = gTrayIdTray.hwnd = gTrayHwndTray.hIcon = Icon.HandleTray.uFlags = NIF_ICONTray.cbSize = Len(Tray)

rc = Shell_NotifyIcon(NIM_MODIFY, Tray)End If

Set gTrayIcon = IconSet Picture = IconPropertyChanged sTrayIconEnd IfEnd If'-------------------------------------------------------End Property'-------------------------------------------------------

'-------------------------------------------------------Public Property Get TrayIcon() As StdPicture'-------------------------------------------------------Set TrayIcon = gTrayIcon'-------------------------------------------------------End Property'-------------------------------------------------------

'-------------------------------------------------------Public Property Let TrayTip(Tip As String)'-------------------------------------------------------Dim Tray As NOTIFYICONDATADim rc As Long'-------------------------------------------------------If gAddedToTray ThenTray.uID = gTrayIdTray.hwnd = gTrayHwndTray.szTip = Tip & vbNullCharTray.uFlags = NIF_TIPTray.cbSize = Len(Tray)

rc = Shell_NotifyIcon(NIM_MODIFY, Tray)End If

gTrayTip = TipPropertyChanged 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) ThenIf Show ThenIf Ambient.UserMode ThenPrevWndProc = SetWindowLong(gTrayHwnd, GWL_WNDPROC, AddressOf SubWndProc)

SetWindowLong gTrayHwnd, GWL_USERDATA, ObjPtr(Me)

AddIcon gTrayHwnd, gTrayId, TrayTip, TrayIcongAddedToTray = TrueEnd IfElseIf gAddedToTray ThenDeleteIcon gTrayHwnd, gTrayId

SetWindowLong gTrayHwnd, GWL_WNDPROC, PrevWndProcgAddedToTray = FalseEnd IfEnd If

gInTray = ShowPropertyChanged sInTrayEnd If'-------------------------------------------------------End Property'-------------------------------------------------------

'-------------------------------------------------------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 NOTIFYICONDATADim tFlags As LongDim rc As Long'-------------------------------------------------------Tray.uID = IdTray.hwnd = hwnd

If Not (Icon Is Nothing) ThenTray.hIcon = Icon.HandleTray.uFlags = Tray.uFlags Or NIF_ICONSet gTrayIcon = IconEnd If

If (Tip <> "") ThenTray.szTip = Tip & vbNullCharTray.uFlags = Tray.uFlags Or NIF_TIPgTrayTip = TipEnd If

Tray.uCallbackMessage = TRAY_CALLBACKTray.uFlags = Tray.uFlags Or NIF_MESSAGETray.cbSize = Len(Tray)

rc = Shell_NotifyIcon(NIM_ADD, Tray)'-------------------------------------------------------End Sub'-------------------------------------------------------

'-------------------------------------------------------Private Sub DeleteIcon(hwnd As Long, Id As Long)'-------------------------------------------------------Dim Tray As NOTIFYICONDATADim rc As Long'-------------------------------------------------------Tray.uID = IdTray.hwnd = hwndTray.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 MouseEventCase WM_MOUSEMOVERaiseEvent MouseMove(Id)Case WM_LBUTTONDOWNRaiseEvent MouseDown(vbLeftButton, Id)Case WM_LBUTTONUPRaiseEvent MouseUp(vbLeftButton, Id)Case WM_LBUTTONDBLCLKRaiseEvent MouseDblClick(vbLeftButton, Id)Case WM_RBUTTONDOWNRaiseEvent MouseDown(vbRightButton, Id)Case WM_RBUTTONUPRaiseEvent MouseUp(vbRightButton, Id)Case WM_RBUTTONDBLCLKRaiseEvent MouseDblClick(vbRightButton, Id)End Select'-------------------------------------------------------End Sub'------------------------------------------------------------------------End cSysTray.ctl------------------------

Sau khi tạo xong hai phần trên, bạn biên dịch nó thành một Control OCX và đặt tên là cSysTray.ocx... Vậy là bạn đã xong phần thứ nhất

PHẦN II: tạo một project mới để dùng OCX cSysTray.ocxBạ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 ButtonCase vbRightButtonPopupMenu MainMenuEnd SelectEnd Sub

Private Sub Form_Load()Me.Visible=FalsecSysTray1.InTray=TruecSysTray1.TrayTip="http://www.khunglongbeo.com/End Sub

Đôc chiêu 14 : Thay đổi Font tiếng việt cho Menu của Window home Xuất xứ : www.pcworld.com.vn Binh khí sử dụng : KhôngĐoạn mã :

'Các hằng được dùng cho các hàm API

Private Const LF_FaceSize=32

Private Type LOGFONT

lfHeight As LonglfWidth As LonglfEscapement As LonglfOrientation As LonglfWeight As LonglfItalic As BytelfUnderline As BytelfStrikeOut As Byte lfCharset As BytelfOutPrecision As BytelfClipPrecision As BytelfQuality As BytelfPitchAndFamily As BytelfFaceName(1 To LF_FaceSize) As Byte

End Type

Private Type NONCLIENTMETRICS

cbSize As LongiBorderWidth As LongiScrollWidth As LongiScoolHeight As LongiCaptionWidth As LongiCaptionHeight As LongiSMCaptionWidth As LongiSMCaptionHeight As LonglfCaptionFont As LOGFONTiMenuWidth As LongiMenuHeight As LonglfMenuFont As LOGFONTlfStatusFont As LOGFONTlfMessageFont As LOGFONT

End Type

Const SPI_SetNonClientMetrics = 42Const SPI_GettNonClientMetrics = 41

'Các hàm API cần thiết

'Hàm SystemParametersInfo sẽ gọi lại tất cả thông tin các tham số ngoài hệ thống. Nó còn có khả năng cập nhật những thông tin do người dùng tự phát triển. Chính vì thế bạn dùng nó để thay đổi Font là rất hợp líPrivate Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, Byval uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Const REF_StructureSize = 340 ` Sizeof( NONCLIENTMETRICS)Private Const VNI_FontHeight = -13Private Const VNI_FontWeight = 700Private Const VNI_FontName = "VNI-Palatin"Private Const VNI_FontLen = 11 `Len(VNI_FontName)

Private FontMetric As NONCLIENTMETRICSPrivate OldFontMetric As NONCLIENTMETRICS

'Thủ tục này dùng để thay đổi Font của MenuPrivate Sub ChangeFont()

Dim I As IntegerDim VarGT As LongDim VarHeight As LongDim VarWeight As LongDim VarStr As String

FontMetric.cbSize = REG_StructureSize

VarGT = SystemParametersInfo(SPI_GetNonClientMetrics,REG_StructureSize, FontMetric, 0)

OldFontMetric =FontMetricFontMetric.lfCaptionFont.lfHeight = VNI_FontHeightFontMetric.lfCaptionFont.lfWeight = VNI_FontWeightVarStr = VNI_FontNameFor I=1 To LF_FaceSizeIf I <= VNI_FontLen ThenFontMetric.lfCaptionFont.lfFaceName(I)= CByte(Asc(Mid(VarStr,I,1)))FontMetric.lfMenuFont.lfFaceName(I)= CByte(Asc(Mid(VarStr,I,1)))Else FontMetric.lfCaptionFont.lfFaceName(I) = 0FontMetric.lfMenuFont.lfFaceName(I) = 0End IfNext IVarGT= SystemParametersInfo(SPI_SetNonClientMetrics, REG_StructureSize, FontMetric,0)End Sub

'THủ tục để phục hồi lại font cho menuPrivate Sub RestoreFont()Dim VarGT As LongVarGT= SystemParametersInfo (SPI_SetNonClientMetrics, REG_StructureSize, OldFontMetric,0)End Sub

'Khi form được khởi tạo thì đổi FontPrivate Sub Form_Load()ChangeFontEnd Sub

'Khi form thoát thì khởi tạo lại font mặc định cho hệ thống bước này quan trọng vì nếu bạn không phục hồi lại font hệ thống thì các menu khác trong Window sẽ nhảy lộn xộn cả lênPrivate Sub Form_UnLoad(Cancel As Integer)

RestoreFontEndEnd Sub

Đôc chiêu 14 : Hiện Icon đại diện cho một loại file home Xuất xứ : www.ttvnol.com Binh khí sử dụng : 1 ModuleĐoạn mã :

'Bạn tạo một module mới và dán đoạn mã này vào

'Các hàm API cần thiết

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 RegSetValue Lib "advapi32.dll" _Alias "RegSetValueA" (ByVal hKey As Long, _ByVal lpSubKey As String, _ByVal dwType As Long, _ByVal lpData As String, _ByVal cbData As Long) As Long

'Thực chất của việc tạo Icon riêng cho ứng dụng là việc bạn đăng kí cho Registry của Window biết là bạn đã đăng nhập vào "quốc gia" của họ

'Các hằng số mang giá trị phản hồi từ Registry Const ERROR_SUCCESS = 0&Const ERROR_BADDB = 1&Const ERROR_BADKEY = 2&Const ERROR_CANTOPEN = 3&Const ERROR_CANTREAD = 4&Const ERROR_CANTWRITE = 5&Const ERROR_OUTOFMEMORY = 6&Const ERROR_INVALID_PARAMETER = 7&Const ERROR_ACCESS_DENIED = 8&

Private Const HKEY_CLASSES_ROOT = &H80000000Private Const MAX_PATH = 260&Private Const REG_SZ = 1

'Hàm API cần thiếtPrivate Declare Sub SHChangeNotify Lib "shell32.dll" _(ByVal wEventId As Long, _ByVal uFlags As Long, _dwItem1 As Any, _dwItem2 As Any)

Const SHCNE_ASSOCCHANGED = &H8000000Const SHCNF_IDLIST = &H0&

'THủ tục dùng để đăng kí Icon cho chương trình

Public Sub Tao_File_He_Thong()'Giả sử rằng chương trình của bạn sẽ đăng kí ch việc thay đổi các tập tin có phần mở rộng là "*.mp3".

Dim sKeyName As String 'Nắm tên khoá trong RegDim sKeyValue As String ''Nắm một giá trị của khoá trong Reg

Dim Ret& Dim lphKey& Dim Path As String

Path = App.PathIf Right(Path, 1) <> "\" ThenPath = Path & "\"End If

'Đăng kí cho một giá trị khoá gốc là tên ứng dụng của bạn. Ví dụ, bạn đặt tên cho chương trình là "Khunglongbeo.exe" thì giá trị của nó là "Khunglongbeo" và khi hoàn tất, tập tin sẽ có thuộc tính là "Khunglongbeo's File " (một hàng chữ mờ mờ bên dưới các file mà bạn thương gặp)

sKeyName = "Khunglongbeo"sKeyValue = "Khunglongbeo's File"Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)Ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)

'Đăng kí phần mở rộng "*.mp3" liên kết với ứng dụng mang tên "khunglongbeo" của bạnsKeyName = ".mp3"sKeyValue = "Khunglongbeo"Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)Ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)

sKeyName = "Khunglongbeo"sKeyValue = Path & "Khunglongbeo.exe %1"Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)Ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, _sKeyValue, MAX_PATH)

'Lấy một Icon làm ảnh đại diệnsKeyName = "Khunglongbeo"'Bạn hãy tìm một file .Ico bất kì và lưu vào đường dẫn sẽ qui định bên dưới (đường dẫn này tuỳ bạn qui định)sKeyValue = Path & "KLB.ico"Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)Ret& = RegSetValue&(lphKey&, "DefaultIcon", REG_SZ, _sKeyValue, MAX_PATH)

'Đổi IconSHChangeNotify SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0

End Sub

'**************************'Phần mã này bạn hãy nhập vào Form1

Private Sub Form_Load()Tao_File_He_ThongEnd Sub

Đôc chiêu 15 : So sánh hai ảnh home Xuất xứ : www.ttvnol.com Binh khí sử dụng :

Bạn vẽ lên form1 các control sau :2 picture box (picture1 và picture2)2 label edit (label1 và label2)1 command button (command1)Bạn trang trí form như hình sau:

Đoạn mã :

''Mã nguồn so sánh hai hình ảnh có định dạng bất kìĐược viết bởi khunglongbeoEmail Address: khunglongbeo@hotmail.comNgày viết : 11/06/2003

‘ Do tôn trọng tác giả n ên tôi xin đ ược giữ nguyên phần này''Cac ham API can thietPrivate Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long'---------------------------------------------------------------------------------''Ham dung de so sanh xem hai hinh co giong nhau khong ? Private Sub So_Sanh(lpHinh1 As PictureBox, lpHinh2 As PictureBox)Dim i As LongDim j As LongDim Mang1() As LongDim Mang2() As LongDim Co As Integer''Chuyen tung anh sang che do pixels lpHinh1.ScaleMode = vbPixelslpHinh2.ScaleMode = vbPixelsCo = 0''Duyet gia tri cho tung pixel anh ReDim Mang1(lpHinh1.Width, lpHinh1.Height) As LongFor i = 0 To lpHinh1.Width - 1 For j = 0 To lpHinh1.Height - 1 ''Luu tung gia tri pixel vao trong Mang1 Mang1(i, j) = GetPixel(lpHinh1.hdc, i, j) ''Tao thanh truot gia dinh dang quet tung pixel SetPixel lpHinh1.hdc, i, j, vbRed SetPixel lpHinh1.hdc, i - 1, j, Mang1(i, j) lpHinh1.Refresh ''Dinh vi tri pixel hien hanh lbl1.Caption = "X : Y = " & i & ":" & j DoEvents Next jNext i''Doan ma nay giong ma tren dung de xu li anh 2 ReDim Mang2(lpHinh2.Width, lpHinh2.Height) As LongFor i = 0 To lpHinh2.Width - 1 For j = 0 To lpHinh2.Height - 1 Mang2(i, j) = GetPixel(lpHinh2.hdc, i, j) SetPixel lpHinh2.hdc, i, j, vbRed SetPixel lpHinh2.hdc, i - 1, j, Mang2(i, j) lpHinh2.Refresh lbl2.Caption = "X : Y = " & i & ":" & j DoEvents Next jNext i''So sanh tung pixel tu hai mang trung gianOn Error Resume NextIf (lpHinh1.Width * lpHinh1.Height) >= (lpHinh2.Width * lpHinh2.Height) Then For i = 0 To lpHinh1.Width - 1 For j = 0 To lpHinh1.Height - 1 If Mang1(i, j) <> Mang2(i, j) Then Co = Co + 1 MsgBox "The nay ma bao giong nhau a ???" Exit Sub End If Next j Next i If Co = 0 Then MsgBox "Hai hinh nay giong y nhau ta oi !"

End IfElseFor i = 0 To lpHinh2.Width - 1 For j = 0 To lpHinh2.Height - 1 If Mang1(i, j) <> Mang2(i, j) Then Co = Co + 1 MsgBox "The nay ma bao giong nhau a ???" Exit Sub End If Next j Next i If Co = 0 Then MsgBox "Hai hinh nay giong y nhau ta oi!" End IfEnd IfEnd SubPrivate Sub CmdSS_Click() Call So_Sanh(Pic1, Pic2)End SubPrivate Sub Form_Load()On Error Resume Next 'Doi voi picture1 Picture1.Name = "Pic1" Picture1.AutoRedraw = True Picture1.AutoSize = True Picture1.Appearance = True Picture1.BorderStyle = 0 ''Doi voi picture2 Picture2.Name = "Pic2" Picture2.AutoRedraw = True Picture2.AutoSize = True Picture2.Appearance = True Picture2.BorderStyle = 0 ''Doi voi cac label Label1.Name = "lbl1" Label2.Name = "lbl2" ''Doi voi command button Command1.Name = "CmdSS" Command1.Font = "VNI-Palatin" Command1.Caption = "So sánh" ''Doi voi form Me.AutoRedraw = True Me.ScaleMode = vbPixelsEnd Sub

Lời kết Bạn chạy thử và xem điều gì sẽ xảy ra. Chương trình sẽ chạy rất chậm nếu như hình có kích thước lớn. Tuy nhiên, kết quả cũng không tệ... Đối với những hình có độ nhoè, bạn có thể qui định bằng cách thêm một số nguyên trong hàm để qui định phần trăm độ nhoè.... Kĩ thuật nhận dạng giới hạn độ nhoè cho phép bảo mật bằng sinh trắc học thực ra cũng không khó về thuật toán. Chỉ cần có máy móc kĩ thuật cao một tí là các bạn có thể làm mọi thứ mình cần

Đôc chiêu 16 : Liệt kê danh sách các thành phần phần cứng trong máy home Xuất xứ : www.ttvnol.com Binh khí sử dụng : KhôngĐoạn mã :

Dim Ports(0 To 100) As PORT_INFO_2Const KT_TYPE = 0Const PRINTER_ENUM_LOCAL = &H2Private Type PRINTER_INFO_1flags As LongpDescription As StringpName As StringpComment As StringEnd TypePrivate Type DISPLAY_DEVICEcb As LongDeviceName As String * 32DeviceString As String * 128StateFlags As LongDeviceID As String * 128DeviceKey As String * 128End TypePrivate Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)Private Type SYSTEM_INFOdwOemID As LongdwPageSize As LonglpMinimumApplicationAddress As LonglpMaximumApplicationAddress As LongdwActiveProcessorMask As LongdwNumberOrfProcessors As LongdwProcessorType As LongdwAllocationGranularity As LongdwReserved As LongEnd TypePrivate Type PORT_INFO_2pPortName As StringpMonitorName As StringpDescription As StringfPortType As LongReserved As LongEnd TypePrivate Type API_PORT_INFO_2pPortName As LongpMonitorName As LongpDescription As LongfPortType As LongReserved As LongEnd TypeConst MAX_HOSTNAME_LEN = 132Const MAX_DOMAIN_NAME_LEN = 132Const MAX_SCOPE_ID_LEN = 260Const MAX_ADAPTER_NAME_LENGTH = 260Const MAX_ADAPTER_ADDRESS_LENGTH = 8Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132Const ERROR_BUFFER_OVERFLOW = 111Const MIB_IF_TYPE_ETHERNET = 1Const MIB_IF_TYPE_TOKENRING = 2Const MIB_IF_TYPE_FDDI = 3Const MIB_IF_TYPE_PPP = 4Const MIB_IF_TYPE_LOOPBACK = 5Const MIB_IF_TYPE_SLIP = 6

Private Type IP_ADDR_STRINGNext As LongIpAddress As String * 16IpMask As String * 16Context As LongEnd Type

Private Type IP_ADAPTER_INFONext As LongComboIndex As LongAdapterName As String * MAX_ADAPTER_NAME_LENGTHDescription As String * MAX_ADAPTER_DESCRIPTION_LENGTHAddressLength As LongAddress(MAX_ADAPTER_ADDRESS_LENGTH - 1) As ByteIndex As LongType As LongDhcpEnabled As LongCurrentIpAddress As LongIpAddressList As IP_ADDR_STRINGGatewayList As IP_ADDR_STRINGDhcpServer As IP_ADDR_STRINGHaveWins As BooleanPrimaryWinsServer As IP_ADDR_STRINGSecondaryWinsServer As IP_ADDR_STRINGLeaseObtained As LongLeaseExpires As LongEnd Type

Private Type FIXED_INFOHostName As String * MAX_HOSTNAME_LENDomainName As String * MAX_DOMAIN_NAME_LENCurrentDnsServer As LongDnsServerList As IP_ADDR_STRINGNodeType As LongScopeId As String * MAX_SCOPE_ID_LENEnableRouting As LongEnableProxy As LongEnableDns As LongEnd Type

Private Declare Function GetNetworkParams Lib "IPHlpApi" (FixedInfo As Any, pOutBufLen As Long) As LongPrivate Declare Function GetAdaptersInfo Lib "IPHlpApi" (IpAdapterInfo As Any, pOutBufLen As Long) As LongPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA" (ByVal pName As String, ByVal Level As Long, ByVal lpbPorts As Long, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As LongPrivate Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As LongPrivate Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function GetProcessHeap Lib "kernel32" () As LongPrivate Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long

Private Declare Function EnumDisplayDevices Lib "user32" Alias "EnumDisplayDevicesA" (Unused As Any, ByVal iDevNum As Long, lpDisplayDevice As DISPLAY_DEVICE, ByVal dwFlags As Long) As BooleanPrivate Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal flags As Long, ByVal name As String, ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As LongPrivate Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As LongPrivate Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Long) As LongPrivate Declare Function GetKeyboardType Lib "user32" (ByVal nTypeFlag As Long) As Long'*********************************************************************'Liệt kê tên của Card Màn hìnhPrivate Sub Ten_Card_ManHinh()Dim DD As DISPLAY_DEVICEDD.cb = Len(DD)If EnumDisplayDevices(ByVal 0&, 0, DD, ByVal 0&) ThenMe.Print "Teân cuûa card maøn hình : " + Left$(DD.DeviceString, InStr(1, DD.DeviceString, Chr$(0)) - 1)ElseMe.Print "Khoâng thaáy card maøn hình"End IfEnd Sub'*********************************************************************'LIệt kê danh sách tên máy inPrivate Sub Ten_Cac_May_In()Dim longbuffer() As LongDim printinfo() As PRINTER_INFO_1Dim numbytes As LongDim numneeded As LongDim numprinters As LongDim c As Integer, retval As Longnumbytes = 3076ReDim longbuffer(0 To numbytes / 4) As Longretval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters)If retval = 0 Thennumbytes = numneededReDim longbuffer(0 To numbytes / 4) As Longretval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters)If retval = 0 ThenDebug.Print "Could not successfully enumerate the printes."EndEnd IfEnd IfIf numprinters <> 0 Then ReDim printinfo(0 To numprinters - 1) As PRINTER_INFO_1For c = 0 To numprinters - 1printinfo(c).flags = longbuffer(4 * c)

printinfo(c).pDescription = Space(lstrlen(longbuffer(4 * c + 1)))retval = lstrcpy(printinfo(c).pDescription, longbuffer(4 * c + 1))printinfo(c).pName = Space(lstrlen(longbuffer(4 * c + 2)))retval = lstrcpy(printinfo(c).pName, longbuffer(4 * c + 2))printinfo(c).pComment = Space(lstrlen(longbuffer(4 * c + 3)))retval = lstrcpy(printinfo(c).pComment, longbuffer(4 * c + 3))Next cFor c = 0 To numprinters - 1Me.Print "Teân cuûa maùy in thöù "; c + 1; " laø : "; printinfo(c).pNameNext cEnd Sub'*********************************************************************'Hàm dùng để kiểu bàn phímPrivate Sub Ban_Phim()Select Case GetKeyboardType(KT_TYPE)Case 1Me.Print "Keyboard type: IBM PC/XT or compatible (83-key) keyboard"Case 2Me.Print "Keyboard type: Olivetti “ICO” (102-key) keyboard"Case 3Me.Print "Keyboard type: IBM PC/AT (84-key) or similar keyboard"Case 4Me.Print "Keyboard type: IBM enhanced (101- or 102-key) keyboard"Case 5Me.Print "Keyboard type: Nokia 1050 and similar keyboards"Case 6Me.Print "Keyboard type: Nokia 9140 and similar keyboards"Case 7Me.Print "Keyboard type: Japanese keyboard"Case ElseMe.Print "Keyboard type: Unknown"End SelectEnd Sub'*********************************************************************'Hàm lấy số serial và hiệu của CPUPrivate Sub Lay_CPU()Dim SInfo As SYSTEM_INFOGetSystemInfo SInfoMe.Print "soá löôïng CPU : " + Str$(SInfo.dwNumberOrfProcessors)Me.Print "Ñôøi CPU : " + Str$(SInfo.dwProcessorType)Me.Print "Ñòa chæ boä nhôù döôùi : " + Str$(SInfo.lpMinimumApplicationAddress)Me.Print "Ñòa chæ boä nhôù treân : " + Str$(SInfo.lpMaximumApplicationAddress)End Sub

'*********************************************************************'Danh sách các Ports trong máyPublic Function TrimStr(strName As String) As StringDim x As Integerx = InStr(strName, vbNullChar)If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strNameEnd FunctionPublic Function LPSTRtoSTRING(ByVal lngPointer As Long) As StringDim lngLength As LonglngLength = lstrlenW(lngPointer) * 2

LPSTRtoSTRING = String(lngLength, 0)CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLengthLPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))End FunctionPublic Function GetAvailablePorts(ServerName As String) As LongDim ret As LongDim PortsStruct(0 To 100) As API_PORT_INFO_2Dim pcbNeeded As LongDim pcReturned As LongDim TempBuff As LongDim i As Integerret = EnumPorts(ServerName, 2, TempBuff, 0, pcbNeeded, pcReturned)TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)ret = EnumPorts(ServerName, 2, TempBuff, pcbNeeded, pcbNeeded, pcReturned)If ret ThenCopyMem PortsStruct(0), ByVal TempBuff, pcbNeededFor i = 0 To pcReturned - 1Ports(i).pDescription = LPSTRtoSTRING(PortsStruct(i).pDescription)Ports(i).pPortName = LPSTRtoSTRING(PortsStruct(i).pPortName)Ports(i).pMonitorName = LPSTRtoSTRING(PortsStruct(i).pMonitorName)Ports(i).fPortType = PortsStruct(i).fPortTypeNextEnd IfGetAvailablePorts = pcReturnedIf TempBuff Then HeapFree GetProcessHeap(), 0, TempBuffEnd FunctionPrivate Sub Lay_Ports()Dim NumPorts As LongDim i As IntegerNumPorts = GetAvailablePorts("")Me.Print "Daùnh saùch caùc Port hieän taïi"For i = 0 To NumPorts - 1Me.Print Ports(i).pPortNameNextEnd Sub'*********************************************************************'Thôngt tin về tình trạng mạng và thông số card mạngPrivate Sub Lay_Adepter()Dim error As LongDim FixedInfoSize As LongDim AdapterInfoSize As LongDim i As IntegerDim PhysicalAddress As StringDim NewTime As DateDim AdapterInfo As IP_ADAPTER_INFODim Adapt As IP_ADAPTER_INFODim AddrStr As IP_ADDR_STRINGDim FixedInfo As FIXED_INFODim Buffer As IP_ADDR_STRINGDim pAddrStr As LongDim pAdapt As LongDim Buffer2 As IP_ADAPTER_INFODim FixedInfoBuffer() As ByteDim AdapterInfoBuffer() As Byte

FixedInfoSize = 0

error = GetNetworkParams(ByVal 0&, FixedInfoSize)If error <> 0 ThenIf error <> ERROR_BUFFER_OVERFLOW ThenMe.Print "GetNetworkParams sizing failed with error " & errorExit SubEnd IfEnd IfReDim FixedInfoBuffer(FixedInfoSize - 1)

error = GetNetworkParams(FixedInfoBuffer(0), FixedInfoSize)If error = 0 ThenCopyMemory FixedInfo, FixedInfoBuffer(0), Len(FixedInfo)Me.Print "Host Name: " & FixedInfo.HostName 'host nameMe.Print "DNS Servers: " & FixedInfo.DnsServerList.IpAddress 'dns server IPpAddrStr = FixedInfo.DnsServerList.NextDo While pAddrStr <> 0CopyMemory Buffer, ByVal pAddrStr, Len(Buffer)Me.Print "DNS Servers: " & Buffer.IpAddress 'dns server IPpAddrStr = Buffer.NextLoop

Select Case FixedInfo.NodeType 'node typeCase 1Me.Print "Node type: Broadcast"Case 2Me.Print "Node type: Peer to peer"Case 4Me.Print "Node type: Mixed"Case 8Me.Print "Node type: Hybrid"Case ElseMe.Print "Unknown node type"End Select

Me.Print "NetBIOS Scope ID: " & FixedInfo.ScopeId 'scope ID'routingIf FixedInfo.EnableRouting ThenMe.Print "IP Routing Enabled "ElseMe.Print "IP Routing not enabled"End If' proxyIf FixedInfo.EnableProxy ThenMe.Print "WINS Proxy Enabled "ElseMe.Print "WINS Proxy not Enabled "End If' netbiosIf FixedInfo.EnableDns ThenMe.Print "NetBIOS Resolution Uses DNS "ElseMe.Print "NetBIOS Resolution Does not use DNS "End IfElseMe.Print "GetNetworkParams failed with error " & error

Exit SubEnd If

AdapterInfoSize = 0error = GetAdaptersInfo(ByVal 0&, AdapterInfoSize)If error <> 0 ThenIf error <> ERROR_BUFFER_OVERFLOW ThenMe.Print "GetAdaptersInfo sizing failed with error " & errorExit SubEnd IfEnd IfReDim AdapterInfoBuffer(AdapterInfoSize - 1)

error = GetAdaptersInfo(AdapterInfoBuffer(0), AdapterInfoSize)If error <> 0 ThenMe.Print "GetAdaptersInfo failed with error " & errorExit SubEnd IfCopyMemory AdapterInfo, AdapterInfoBuffer(0), Len(AdapterInfo)pAdapt = AdapterInfo.Next

Do While pAdapt <> 0CopyMemory Buffer2, AdapterInfo, Len(Buffer2)Select Case Buffer2.TypeCase MIB_IF_TYPE_ETHERNETMe.Print "Ethernet adapter "Case MIB_IF_TYPE_TOKENRINGMe.Print "Token Ring adapter "Case MIB_IF_TYPE_FDDIMe.Print "FDDI adapter "Case MIB_IF_TYPE_PPPMe.Print "PPP adapter"Case MIB_IF_TYPE_LOOPBACKMe.Print "Loopback adapter "Case MIB_IF_TYPE_SLIPMe.Print "Slip adapter "Case ElseMe.Print "Other adapter "End SelectMe.Print " AdapterName: " & Buffer2.AdapterNameMe.Print "AdapterDescription: " & Buffer2.Description 'adatpter name

For i = 0 To Buffer2.AddressLength - 1PhysicalAddress = PhysicalAddress & Hex(Buffer2.Address(i))If i < Buffer2.AddressLength - 1 ThenPhysicalAddress = PhysicalAddress & "-"End If

NextMe.Print "Physical Address: " & PhysicalAddress 'mac addressIf Buffer2.DhcpEnabled ThenMe.Print "DHCP Enabled "ElseMe.Print "DHCP disabled"End If

pAddrStr = Buffer2.IpAddressList.NextDo While pAddrStr <> 0CopyMemory Buffer, Buffer2.IpAddressList, LenB(Buffer)Me.Print "IP Address: " & Buffer.IpAddressMe.Print "Subnet Mask: " & Buffer.IpMaskpAddrStr = Buffer.NextIf pAddrStr <> 0 ThenCopyMemory Buffer2.IpAddressList, ByVal pAddrStr, Len(Buffer2.IpAddressList)End IfLoopMe.Print "Default Gateway: " & Buffer2.GatewayList.IpAddresspAddrStr = Buffer2.GatewayList.NextDo While pAddrStr <> 0CopyMemory Buffer, Buffer2.GatewayList, Len(Buffer)Me.Print "IP Address: " & Buffer.IpAddresspAddrStr = Buffer.NextIf pAddrStr <> 0 ThenCopyMemory Buffer2.GatewayList, ByVal pAddrStr, Len(Buffer2.GatewayList)End IfLoop

Me.Print "DHCP Server: " & Buffer2.DhcpServer.IpAddressMe.Print "Primary WINS Server: " & Buffer2.PrimaryWinsServer.IpAddressMe.Print "Secondary WINS Server: " & Buffer2.SecondaryWinsServer.IpAddress

NewTime = CDate(Adapt.LeaseObtained)Me.Print "Lease Obtained: " & CStr(NewTime)

NewTime = CDate(Adapt.LeaseExpires)Me.Print "Lease Expires : " & CStr(NewTime)pAdapt = Buffer2.NextIf pAdapt <> 0 ThenCopyMemory AdapterInfo, ByVal pAdapt, Len(AdapterInfo)End If

LoopEnd SubPrivate Sub Form_Load()Me.Font = "VNI-Palatin"Me.AutoRedraw = TrueTen_Card_ManHinhTen_Cac_May_InBan_PhimLay_CPULay_PortsLay_AdepterEnd Sub

Đôc chiêu 17 : Chương trình khởi động cùng với Windowns home Xuất xứ : www.pscode.comBinh khí sử dụng : Một ModuleĐoạn mã :Module :

Option ExplicitPublic Const HKEY_CLASSES_ROOT = &H80000000Public Const HKEY_LOCAL_MACHINE = &H80000002Public Const ERROR_SUCCESS = 0&Public Const HKEY_CURRENT_USER = &H80000001

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As LongDeclare 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 Public Const REG_SZ = 1 ' Unicode nul terminated String

Public Function ReplaceChars(ByVal Text As String, ByVal Char As String, ReplaceChar As String) As String Dim counter As Integer counter = 1 Do counter = InStr(counter, Text, Char) If counter <> 0 Then Mid(Text, counter, Len(ReplaceChar)) = ReplaceChar Else ReplaceChars = Text Exit Do End If Loop

ReplaceChars = TextEnd Function

Public Function GetString(hKey As Long, strPath As String, strValue As String, DefaultStr As Long) As String 'EXAMPLE: ' 'text1.text = getstring(HKEY_CURRENT_USE ' R, "Software\VBW\Registry", "String") ' Dim keyhand As Long Dim lResult As Long

Dim strBuf As String Dim lDataBufSize As Long Dim intZeroPos As Integer Dim lValueType As Long RegOpenKey hKey, strPath, keyhand lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)

If lValueType = REG_SZ Then strBuf = String(lDataBufSize, " ") lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)

If lResult = ERROR_SUCCESS Then intZeroPos = InStr(strBuf, Chr$(0))

If intZeroPos > 0 Then GetString = Left$(strBuf, intZeroPos - 1) Else GetString = strBuf End If End If End If If strBuf = "" Then GetString = DefaultStrEnd FunctionPublic Sub SaveString(hKey As Long, strPath As String, strValue As String, strdata As String)

Dim keyhand As Long keyhand = 0 RegOpenKey hKey, strPath, keyhand If keyhand = 0 Then RegCreateKey hKey, strPath, keyhand RegSetValueEx keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata) RegCloseKey keyhandEnd SubForm :

Function Khoidong()If GetSetting("dungcoi", "dung", "Path") <> App.Path & "\" & App.EXEName & ".exe" ThenSaveString HKEY_CLASSES_ROOT, "Folder\shell\Khoi dong Virus\command", "", App.Path & "\" & App.EXEName & ".exe" & " /ADDDRV %1"SaveString HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", "dungcoi", App.Path & "\" & App.EXEName & ".exe" & " /STARTUP"SaveSetting "dungcoi", "dung", "Path", App.Path & "\" & App.EXEName & ".exe"End IfEnd Function

Private Sub Form_Load()Khoidong

End SubĐôc chiêu 18 : Play một file nhạc Midi home Xuất xứ : Lê Nguyên Dũng (dungcoi2005) sửa lại từ www.allapi.netBinh khí sử dụng : Một Module, 2 nút ấn (CommandButton)Đoạn mã :Module :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 LongForm :

Private Sub Form_Load()Command1.Caption = "Play"Command2.Caption = "Stop"End SubPrivate Sub Command1_Click() result = mciSendString("open d:\Nhac.mid type sequencer alias canyon", 0&, 0, 0) result = mciSendString("play canyon", 0&, 0, 0)End Sub

Private Sub Command2_Click() result = mciSendString("close all", 0&, 0, 0)End SubĐôc chiêu 19 : Khoá một file ảnh định dạng .bmp home Xuất xứ : Lê Nguyên Dũng (dungcoi2005) sửa lại từ www.pscode.comBinh khí sử dụng : 2 nút ấn (CommandButton)Nói qua : Chiêu này rất hay các bạn ạ nó giúp bạn không cho người khác xem những tấm ảnh bạn muốn và quan trọng hơn bạn có thể dễ dành viết một phần mềm bảo mật ảnh. Đoạn mã :Function MoKhoa(File) A = FreeFile Open File For Binary As #A B$ = Chr(0) Put #A, 17, B$ Close #AEnd FunctionFunction KhoaAnh(File) A = FreeFile Open File For Binary As #A B$ = "X" Put #A, 17, B$ Close #AEnd FunctionPrivate Sub Command1_Click()KhoaAnh ("d:\hinh anh.bmp")End SubPrivate Sub Command2_Click()MoKhoa ("d:\hinh anh.bmp")End SubPrivate Sub Form_Load()Command1.Caption = " Khoa file anh"Command2.Caption = " Mo khoa file anh"End SubĐôc chiêu 20 : Để form của bạn ở chế độ “Luôn nổi” home Xuất xứ : Lê Nguyên Dũng (dungcoi2005) sửa lại từ www.allapi.net

Binh khí sử dụng : 1 Timer có giá trị Interval = 50 hoặc gì gì đó nhưng đừng lớn quá chương trình kém “Nhạy” đừng nhỏ quá chương trình “Giật giật”Đoạn mã :Const HWND_TOPMOST = -1Const HWND_NOTOPMOST = -2Const SWP_NOSIZE = &H1Const SWP_NOMOVE = &H2Const SWP_NOACTIVATE = &H10Const SWP_SHOWWINDOW = &H40Private Declare Sub 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)Private Sub Timer1_Timer() SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZEEnd SubĐôc chiêu 21 : TextBox chỉ “Chịu” nhận số home Xuất xứ : www.allapi.netBinh khí sử dụng : 1 TextBox và 1 ModuleĐoạn mã :Module Const Number$ = "0123456789." ' Chỉ nhận các ký tự nàyForm :Private Sub Text1_KeyPress(KeyAscii As Integer) If IsNumeric(Chr(KeyAscii)) <> True Then KeyAscii = 0End SubĐôc chiêu 22 : Để form trở nên trong suốt home Xuất xứ : www.allapi.netBinh khí sử dụng : KhôngĐoạn mã :Const LWA_COLORKEY = &H1Const LWA_ALPHA = &H2Const GWL_EXSTYLE = (-20)Const WS_EX_LAYERED = &H80000Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPrivate Sub Form_Load() Dim Ret As Long Ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE) Ret = Ret Or WS_EX_LAYERED SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret SetLayeredWindowAttributes Me.hWnd, 0, 128, LWA_ALPHAEnd Sub‘ Chú ý số 128 : Chính là số chỉ định độ trong suốt (Số này từ 0->255)Đôc chiêu 23 : Lấy tên người sử dung của Windowns home Xuất xứ : www.allapi.netBinh khí sử dụng : 1 ModuleĐoạn mã :Module :

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As LongForm :Sub Get_User_Name() Dim lpBuff As String * 25 Dim ret As Long, UserName As String ret = GetUserName(lpBuff, 25) UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1) MsgBox UserNameEnd SubPrivate Sub Form_Load()Get_User_NameEnd SubĐôc chiêu 24 : Chép cả màn hình làm việc vào một Picture home Xuất xứ : www.ttvnol.comBinh khí sử dụng : 1 Picture và một nút ấnĐoạn mã :Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate 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 LongDim hScreen As LongDim w As LongDim h As LongPicture1.Cls wScreen = Screen.Width \ Screen.TwipsPerPixelXhScreen = Screen.Height \ Screen.TwipsPerPixelY Picture1.ScaleMode = vbPixelsw = Picture1.ScaleWidthh = Picture1.ScaleHeight

hdcScreen = GetDC(0) r = StretchBlt(Picture1.hdc, 0, 0, w, h, hdcScreen, 0, 0, wScreen, hScreen, vbSrcCopy) End Sub Đôc chiêu 25 : Dấu dữ liệu dạng text vào 1 file bất kỳ home Xuất xứ : www.ttvnol.comBinh khí sử dụng : Hai textbox đặt tên lần lượt là txtPath và txtContains. Hai command button đặt tên lần lượt là CmdEncrypt và CmdDecryptĐoạn mã : (Khi Runtime nhớ nhập đường dẫn và nội dung)Public Function Dat_Thong_Diep(DuongDan As String, ThongDiep As String) As StringOpen DuongDan For Binary As #1Dim BoDem As StringBoDem = Space(LOF(1))Get #1, , BoDemClose #1Dim Message As StringOpen DuongDan For Binary As #2Message = BoDem & ThongDiep & Chr(Len(ThongDiep))Put #2, , MessageEnd Function

Public Function Lay_Thong_Diep(DuongDan As String) As StringOpen DuongDan For Binary As #1Dim BoDem As StringBoDem = Space(LOF(1))Get #1, , BoDemClose #1Dim Message As StringDim LuuC As StringLuuC = Right(BoDem, 1)Message = Right(BoDem, Asc(LuuC) + 1)Message = Left(Message, Len(Message) - 1)Lay_Thong_Diep = MessageEnd Function

Private Sub CmdEncrypt_Click()If txtPath <> "" And txtContains <> "" ThenDat_Thong_Diep Trim$(txtPath), Trim$(txtContains)End IfEnd Sub

Private Sub CmdDecrypt_Click()txtContains = ""If txtPath <> "" ThentxtContains = Lay_Thong_Diep(Trim$(txtPath))End IfEnd SubĐôc chiêu 26 : Mở từng hộp thoại trong Control Panel home Xuất xứ : www.pscode.comBinh khí sử dụng : KhôngĐoạn mã : ( Do có nhiều phần nên tôi chỉ đưa ra Code cơ bản)'Hộp thoại System PropertiesDim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", 5)‘Hộp thoại Add/Remove ProgramsDim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1", 5)' Hộp thoại Date/Time PropertiesDim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", 5)' Hộp thoại Display PropertiesDim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5)' Hộp thoại Game ControllersDim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL joy.cpl", 5)' Hộp thoại Internet PropertiesDim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5)' Hộp thoại Keyboard Properties Dim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5)

' Hộp thoại Modem Properties Dim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", 5)' Hộp thoại Mouse Properties Dim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5)' Hộp thoại Multimedia Properties Dim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0", 5)' Hộp thoại Network Dim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl", 5)' Hộp thoại Regional Settings Dim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0", 5)' Hộp thoại Sounds Properties Dim dblReturn As DoubledblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1", 5)Đôc chiêu 27 : Mã hoá dữ liệu dạng text home Nói qua : Phần này rất hay các bạn nên chú ý trong thực tế ứng dụng nên sử dụng một file trung gian để chứa dữ liệu được mã hoáXuất xứ : www.vbcode.comĐây là Demo của tôi nè, rất ấn tượng phải không ai muốn có Source cứ mail cho tôi

Binh khí sử dụng : 2 Nút ấn với tên lần lượt là cmdEncode và cmdDecode, 3 TextBox với tên lần lượt là txtDulieu , txtKetQua và txtGiaiMa (Đ ể test thì vậy là đủ còn tôi tất nhiên phải “Màu mè” hơn rồi)Đoạn mã :Public Function Encode(Data As String, Optional Depth As Integer) As String

Dim TempChar As StringDim TempAsc As IntegerDim NewData As StringDim vChar As Integer

For vChar = 1 To Len(Data) TempChar = Mid$(Data, vChar, 1) TempAsc = Asc(TempChar) If Depth = 0 Then Depth = 40 If Depth > 254 Then Depth = 254

TempAsc = TempAsc + Depth If TempAsc > 255 Then TempAsc = TempAsc - 255 TempChar = Chr(TempAsc) NewData = NewData & TempCharNext vCharEncode = NewData

End FunctionPublic Function Decode(Data As String, Optional Depth As Integer) As StringDim TempChar As StringDim TempAsc As IntegerDim NewData As StringDim vChar As Integer

For vChar = 1 To Len(Data) TempChar = Mid$(Data, vChar, 1) TempAsc = Asc(TempChar) If Depth = 0 Then Depth = 40 If Depth > 254 Then Depth = 254 TempAsc = TempAsc - Depth If TempAsc < 0 Then TempAsc = TempAsc + 255 TempChar = Chr(TempAsc) NewData = NewData & TempCharNext vCharDecode = NewData

End FunctionPrivate Sub CmdEncode_Click()TxtKetqua.Text = Encode(txtDulieu.Text, 9)End SubPrivate Sub cmdDecode_Click()txtGiaiMa.Text = Decode(TxtKetqua.Text, 9)End Sub‘ Chú ý : Ở chỗ số 9 chính là số ta cần để lựa chọn kiểu Mã hoá hay Giải mã

Lời kết : Chao ôi mệt quá qua 1 buổi lối ngày 10 tháng 11 và cả một ngày 11 tháng 11 đã hoàn thành 14 Chiêu thức, hình như hơi chậm thì phải các bạn, do phải “Lục tung” hết cái máy lên

mới tìm thấy những chiêu “Tâm đắt” để viết sách, nhất là chiêu Mã hoá dữ liệu dạng text đã làm mình mất hơn 1 buổi tối mới tìm ra, kiểu này thì phải nhờ các bạn nếu có Chiêu thức nào hay thì

gửi Email cho mình để tổng hợp và nâng cấp cho cuốn sách lần sau (An tâm đi mình sẽ ghi nhận các bạn trong cuốn sách từ trang bìa đến xuất xứ của chiêu thức đó), một mình làm chán

quá các bạn ạ. Mà mình cũng hết Chiêu thức để viết tiếp rồi. Chiêu thức lập trình phiên bản 2 tới đây là hết mong các bạn đóng góp ý kiến để phiên bản sau hoàn thiện hơn

Lê Nguyên Dũng lớp 11C1 trường THPT Đăk Nông ( Thị xã Gia Nghĩa tỉnh Đăk Nông)Ngày “Xuất bản” : 10h sáng ngày 12 tháng 11 năm 2005