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

ring 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 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, 4SysTray.SendEvent lParam, wParamCopyMemory SysTray, 0&, 4End SelectSubWndProc = 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 IfSet 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 IfgTrayTip = 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, gTrayIdSetWindowLong gTrayHwnd, GWL_WNDPROC, PrevWndProcgAddedToTray = FalseEnd IfEnd IfgInTray = 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 = hwndIf Not (Icon Is Nothing) ThenTray.hIcon = Icon.HandleTray.uFlags = Tray.uFlags Or NIF_ICONSet gTrayIcon = IconEnd IfIf (Tip "") ThenTray.szTip = Tip & vbNullCharTray.uFlags = Tray.uFlags Or NIF_TIPgTrayTip = TipEnd IfTray.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="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 LongPrivate 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 LongPrivate 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 Sub Private Sub CmdSS_Click() Call So_Sanh(Pic1, Pic2)End Sub Private 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 LongPrivate 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) * 2LPSTRtoSTRING = 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 ByteFixedInfoSize = 0error = 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.NextLoopSelect 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 SelectMe.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 " & errorExit SubEnd IfAdapterInfoSize = 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.com Binh khí sử dụng : Một Module Đoạn mã : Module : Option Explicit Public Const HKEY_CLASSES_ROOT = &H80000000 Public Const HKEY_LOCAL_MACHINE = &H80000002 Public 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 Long 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 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 = Text End 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 = DefaultStr End Function Public 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 keyhand End Sub Form : Function Khoidong() If GetSetting("dungcoi", "dung", "Path") App.Path & "\" & App.EXEName & ".exe" Then SaveString 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 If End 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.net Binh 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 Long Form : Private Sub Form_Load() Command1.Caption = "Play" Command2.Caption = "Stop" End Sub Private 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.com Binh 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 #A End Function Function KhoaAnh(File) A = FreeFile Open File For Binary As #A B$ = "X" Put #A, 17, B$ Close #A End Function Private Sub Command1_Click() KhoaAnh ("d:\hinh anh.bmp") End Sub Private Sub Command2_Click() MoKhoa ("d:\hinh anh.bmp") End Sub Private 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 = -1 Const HWND_NOTOPMOST = -2 Const SWP_NOSIZE = &H1 Const SWP_NOMOVE = &H2 Const SWP_NOACTIVATE = &H10 Const SWP_SHOWWINDOW = &H40 Private 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_NOSIZE End Sub Đôc chiêu 21 : TextBox chỉ “Chịu” nhận số home Xuất xứ : www.allapi.net Binh khí sử dụng : 1 TextBox và 1 Module Đoạn mã : Module Const Number$ = "0123456789." ' Chỉ nhận các ký tự này Form : Private Sub Text1_KeyPress(KeyAscii As Integer) If IsNumeric(Chr(KeyAscii)) True Then KeyAscii = 0 End Sub Đôc chiêu 22 : Để form trở nên trong suốt home Xuất xứ : www.allapi.net Binh khí sử dụng : Không Đoạn mã : Const LWA_COLORKEY = &H1 Const LWA_ALPHA = &H2 Const GWL_EXSTYLE = (-20) Const WS_EX_LAYERED = &H80000 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private 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_ALPHA End 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.net Binh 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 Long Form : 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 UserName End Sub Private Sub Form_Load() Get_User_Name End 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.com Binh 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.com Binh 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 String Open DuongDan For Binary As #1 Dim BoDem As String BoDem = Space(LOF(1)) Get #1, , BoDem Close #1 Dim Message As String Open DuongDan For Binary As #2 Message = BoDem & ThongDiep & Chr(Len(ThongDiep)) Put #2, , Message End Function Public Function Lay_Thong_Diep(DuongDan As String) As String Open DuongDan For Binary As #1 Dim BoDem As String BoDem = Space(LOF(1)) Get #1, , BoDem Close #1 Dim Message As String Dim LuuC As String LuuC = Right(BoDem, 1) Message = Right(BoDem, Asc(LuuC) + 1) Message = Left(Message, Len(Message) - 1) Lay_Thong_Diep = Message End Function Private Sub CmdEncrypt_Click() If txtPath "" And txtContains "" Then Dat_Thong_Diep Trim$(txtPath), Trim$(txtContains) End If End Sub Private Sub CmdDecrypt_Click() txtContains = "" If txtPath "" Then txtContains = Lay_Thong_Diep(Trim$(txtPath)) End If End Sub Đôc chiêu 26 : Mở từng hộp thoại trong Control Panel home Xuất xứ : www.pscode.com Binh 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 Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", 5) ‘Hộp thoại Add/Remove Programs Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1", 5) ' Hộp thoại Date/Time Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", 5) ' Hộp thoại Display Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5) ' Hộp thoại Game Controllers Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL joy.cpl", 5) ' Hộp thoại Internet Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5) ' Hộp thoại Keyboard Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5) ' Hộp thoại Modem Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", 5) ' Hộp thoại Mouse Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5) ' Hộp thoại Multimedia Properties Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0", 5) ' Hộp thoại Network Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl", 5) ' Hộp thoại Regional Settings Dim dblReturn As Double dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0", 5) ' Hộp thoại Sounds Properties Dim dblReturn As Double dblReturn = 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 String Dim TempAsc As Integer Dim NewData As String Dim 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 & TempChar Next vChar Encode = NewData End Function Public Function Decode(Data As String, Optional Depth As Integer) As String Dim TempChar As String Dim TempAsc As Integer Dim NewData As String Dim 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 & TempChar Next vChar Decode = NewData End Function Private Sub CmdEncode_Click() TxtKetqua.Text = Encode(txtDulieu.Text, 9) End Sub Private 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