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

Chia sẻ: Mai Trần Thúy Hạnh | Ngày: | Loại File: PDF | Số trang:15

Thêm vào BST

Báo xấu

357
lượt xem 198
download

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

Tôi hay nói cho lễ phép thì có thể là “Em” đã trải qua một khoảng thời gian dài, tìm hiểu và học tập thì nhận thấy sự khó khăn khi ìm kiếm tài liệu để học lập trình, nhất là với những kỹ nâng lập trình nâng cao vì trên thị trường hiện nay chỉ toàn là các sách dạy “Qua cho có” và rất sơ cấp. Qua cuốn sách này tôi muốn chia sẽ kiến thức mình học được để chia sẽ với những người mới học mong rằng bản than các ban sẽ viết được những phần...

Chủ đề:

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

Lưu

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

Chiêu thức lập trình VB Tác giả : Lê Nguyên Dũng Lớp 11C1 Trường THPT Đắk Nông Địa chỉ nhà : Thôn 1, thị trấn Đăk Mâm Huyện Krông Nô Tỉnh Đắk Nông (Thị xã Gia Nghĩa Tỉnh Đăk Nông ngày 9/9/2005) 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ứ Lời nói đầu Tôi hay nói cho lễ phép thì có thể là “Em” đã trải qua một khoảng thời gian dài, tìm hiểu và học tập thì nhận thấy sự khó khăn khi ìm kiếm tài liệu để học lập trình, nhất là với những kỹ nâng lập trình nâng cao vì trên thị trường hiện nay chỉ toàn là các sách dạy “Qua cho có” và rất sơ cấp. Qua cuốn sách này tôi muốn chia sẽ kiến thức mình học được để chia sẽ với những người mới học mong rằng bản than các ban sẽ viết được những phần mềm hay và hữu ích giúp ích cho cộng đồng. Các bạn có thể tự hỏi tại sao tôi lại ngu ngô viết ra cuốn “Sổ tay” này rồi lại tung miễn phí lên mạng ? Có thể là do quá tuyệt vọng vì ở “Cái xứ sở” của tôi một thằng con nít như tôi (Dù lớp 11 nhưng tôi quá bé con để có thể gọi là người lớn nói rõ hơn là tôi mới chỉ cao 1m40 và nặng vỏn vẹn 35kg), tôi thật sự rất buồn khi các phần mềm mình viết ra rồi lại “Tự mình sài” khi đem “Khoe” với thầy cô thì họ chỉ nhìn thấy và Nhe răng cười đúng một cái “ rồi đi (Cho dù đó là một phần mềm tôi rất kỳ vọng đã bỏ ra 5 tháng trời để viết cuối cùng sau một lần sơ ý làm hư máy của mẹ rồi hoảng quá Ghost lại máy của mẹ lại mà quên “Cất” mã nguồn vậy là xong), tôi muốn đem mấy cái phần mềm mình đi thi nhưng lại chẳng có cuộc thi nào để thi (Trí tuệ việt nam thì quá cao còn ở cái tỉnh mới thành lập này thì tôi tìm hiểu mãi mà chưa cò), tôi lại nghĩ nên đi thi ở Đăk Lăk nhưng ta lại là “Con nhà lính” nên chẳng có điều kiện, nhưng chuyện đã hết đâu lên tỉnh này học trong cái lớp “ Có thể gọi là chuyện Toán” thì lại toàn là “Con quan” người nhỏ con lại ứng xử kém bị chúng nó chèn ép (Thậm chí nhiều khi là chúng còn tìm cách hạ nhục vì vốn học đã không giỏi lại thiếu “Phe cánh” nên điểm chẳng được cao chẳng bù mấy tụi nó, vậy là bọn chúng cứ tìm cách mà “Khui” ra). Ngay bây giờ tôi đang “Chịu” một khoản nợ không đâu (Tới 30 ngàn mà trong người bây giờ không có tới 10 ngàn bố mẹ lại ở xa cách mình tận 120 cây số , mà đó làm bọn kia “Ép phe” chứ tôi đâu có làm gì tự nhiên thua lý oan 30 nghìn). À mà thôi hình như do quá buồn nên tôi “Khai hết” mong các bạn thông cảm, thôi bây giờ ta vào việc : Đôc chiêu 1 : “Thả một câu từ trên cao xuống” (Có thể nói như vậy) Xuất xứ : www.pscode.com Binh khí sử dụng : Một Picture và một CommandButton Đoạn mã : Option Explicit Private Sub command1_Click() Randomize Timer 'Init Rnd 'Declarations Dim StartTime(100) 'Starttime of a up/down movement Dim DownMovement(100) As Boolean 'are we doing a up or down movement ??? Dim MoveDistance As Double 'distance target has moved since the start of the movement Dim YPos(100) As Double 'Holds the y position of a letter
Dim MovementDone(100) As Boolean 'Is set to true when a up / down movement is completed Dim StartHeight(100) As Double 'From which hight will the letter fall down ? Dim UpMovementTime(100) As Double 'How long will it the letter take to move up Dim PowerLoss(100) As Double 'losing xx% of power when touching the ground Dim Message As String 'Message you want to display Dim Looop As Integer 'Loop var Dim TextColor(100) As ColorConstants 'Color of one letter 'Settings picture1.ScaleMode = 4 picture1.FontName = "Courier New" Message = "Ohh my god ! It's raining letters today !!! Contact me: overkillpage@gmx.net" 'Message you want to display For Looop = 1 To Len(Message) PowerLoss(Looop) = 0.2 + ((Rnd * 25) / 100) 'losing xx% of power when touching the ground StartHeight(Looop) = 0 TextColor(Looop) = RGB(80 + Looop * 2, 80 + Looop * 2, 255) Next Looop For Looop = 1 To Len(Message) StartTime(Looop) = Timer 'Setting up startime for a following movement, needed for calculation of position Next Looop Do picture1.Cls 'Clear picturebox 'Looping throung the textmessage For Looop = 1 To Len(Message) If DownMovement(Looop) = True Then MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 * ((Timer - StartTime(Looop)) ^ 2))) 'Calculating falling distance If YPos(Looop) >= picture1.ScaleHeight - 1 Then MovementDone(Looop) = True 'The letter reached the bottom border. The Downmovement is complete Else MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 * (UpMovementTime(Looop) - (Timer - StartTime(Looop))) ^ 2)) 'Calculating falling distance
If YPos(Looop)
End End Sub Đôc chiêu 2 : Hiện một câu bằng cách lần lượt hiện từng chữ Xuất xứ : www.pscode.com Binh khí sử dụng : Một Module , ba CommandButton lần lượt có các tên cmdStart, cmdClear, cmdExit, thêm hai cái đồng hồ tên là Timer1 (Interval =50) và Timer2(Interval =5) cuối cùng là một label tên là lblText Đoạn mã : Private Sub cmdClear_Click() lblText.Caption = "" End Sub Private Sub cmdExit_Click() End End Sub Private Sub cmdStart_Click() TXT = InputBox("Enter Text") ReDim Preserve Letters(0) ReDim Preserve Letters(Len(TXT)) lblText = "" CurLetter = 0 For l = 1 To Len(TXT) Letters(l) = Mid(TXT, l, 1) Next Timer2.Enabled = True End Sub Private Sub Form_Load() End Sub Private Sub Timer1_Timer() r=r+1 lblText.Caption = TEXTT lblText.Caption = lblText.Caption & "_" If r = 6 Then r=0 If 65 < Asc(Letters(CurLetter)) < 90 Then lblText.Caption = TEXTT lblText.Caption = lblText.Caption & Letters(CurLetter) TEXTT = lblText Timer2.Enabled = True Timer1.Enabled = False Else lblText.Caption = TEXTT lblText.Caption = lblText.Caption & Chr$(Asc(Letters(CurLetter)) - 32) TEXTT = lblText Timer2.Enabled = True Timer1.Enabled = False End If End If
End Sub Private Sub Timer2_Timer() CurLetter = CurLetter + 1 If CurLetter > Len(TXT) Then GoTo HERE: End If TEXTT = lblText Timer1.Enabled = True Timer2.Enabled = False HERE: Timer2.Enabled = False End Sub Đôc chiêu 3 : Hiện con trỏ động tại một đối tượng nào đó Xuất xứ : www.ttvnol.com Binh khí sử dụng : Chỉ cần một cái Form Đoạn mã : 'Hằng được sử dụng private Const ConTro=(-12) 'Các hàm API được sử dụng Private Declare Function SetClasslong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long Dim NewCur as long Dim OldCur as long Private Sub Form_Load 'Giả sử rằng bạn đã có sẵn file Clock.ani ở ổ C:\ NewCur=LoadCursorFromFile("C:\Clock.ani") OldCur=SetClassLong(Me.hwnd, ConTro,NewCur) End sub Private Sub Form_UnLoad(Cancel as Integer) SetClassLong me.hwnd, Contro,OldCur End Sub - Ta rút ra được một “Công thức” : Thay vì đặt con trỏ động trong Form ta có thể thay Me.hwnd trong dòng lệnh : OldCur=SetClassLong(Me.hwnd, ConTro,NewCur) bằng đối tựợng.hwnd (Nếu đối tượng đó hổ trợ )
Đôc chiêu 4 : Form có hình dạng theo một hình ảnh bất k ỳ (Tất nhiên có màu tượng trưng cho form trong suốt) Xuất xứ : www.ttvnol.com Binh khí sử dụng : Chỉ cần một cái Form và một cái module Yêu cầu hệ thống Mọi Version Windows. Tuy nhiên, bạn nên dùng Win2k/XP để có thể làm 1 số hiệu ứng đặc biệt cho Form như trong suốt chẳng hạn... Đoạn mã : ‘ Trong Module Option Explicit Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Public Const RGN_OR = 2 Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Public Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Public Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Public Const BITMAP_SIZE = 24 ''=Len(BITMAP) Dim bmByte() As Byte Public Declare Function ReleaseCapture Lib "user32" () As Long Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Const HTCAPTION = 2 Public Const WM_NCLBUTTONDOWN = &HA1 Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal
dwNewLong As Long) As Long Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Public Const WS_EX_LAYERED = &H80000 Public Const GWL_EXSTYLE = (-20) Public Const LWA_ALPHA = &H2 Public Const LWA_COLORKEY = &H1 Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull) Dim X As Long, Y As Long Dim Rgn1 As Long, Rgn2 As Long Dim SPos As Long, EPos As Long Dim bm As BITMAP Dim hbm As Long Dim Wid As Long, Hgt As Long Dim xoff As Long, yoff As Long ''Lấy thông tin về hình nền hbm = hForm.Picture ''Lấy Handle của hình trong Form GetObjectAPI hbm, Len(bm), bm ''Lấy thông tin về hình nền trong Form và lưu trong biến bm Wid = bm.bmWidth ''Chiều rộng bức hình được lưu vào bộ đệm Buffer Hgt = bm.bmHeight ''Chiều cao bức hình được lưu vào bộ đệm Buffer ''Xử lí cho Form With hForm .ScaleMode = vbPixels ''Chuyển sang chế độ pixels cho Form xoff = (.ScaleX(.Width, vbTwips, vbPixels) - .ScaleWidth) / 2 yoff = .ScaleY(.Height, vbTwips, vbPixels) - .ScaleHeight - xoff .Width = (Wid + xoff * 2) * Screen.TwipsPerPixelX ''Định lại chiều rộng của Form cho vừa với hình nền .Height = (Hgt + xoff + yoff) * Screen.TwipsPerPixelY ''Định lại chiều cao của Form cho vừa với hình nền End With ''Khởi tạo mảng động bmByte() trong phạm vi diện tích của hình ReDim bmByte(1 To Wid, 1 To Hgt) ''Chép toàn bộ bức hình vào bộ đệm Buffer của bộ nhớ GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1) If transColor = vbNull Then transColor = bmByte(1, 1) ''Khởi tạo miền chữ nhật đầu tiên Rgn1 = CreateRectRgn(0, 0, 0, 0) ''Duyệt từng pixels của hình For Y = 1 To Hgt X = 0 ''Khởi tạo giá trị X ban đầu Do '' Bắt đầu dịch chuyển vị trí pixels của hình theo chiều ngang X=X+1 While (bmByte(X, Y) = transColor) And (X < Wid) X=X+1 Wend
SPos = X ''Nếu có dấu hiệu màu khác thì đánh dấu vị trí bắt đầu While (bmByte(X, Y) transColor) And (X < Wid) X=X+1 Wend EPos = X - 1 ''Nếu có dấu hiệu màu giống thì đánh dấu vị trí kết thúc If SPos = Wid Next Y ''Định lại hình dáng của Form theo Rgn1 SetWindowRgn hForm.hwnd, Rgn1, True DeleteObject Rgn1 End Sub ‘ Trong Form Option Explicit Private Sub Form_DblClick() Unload Me End Sub Private Sub Form_Load() Me.P.Picture = LoadPicture("C:\skin.jpg") ‘Đường dẫn file ảnh cần thiết If Me.Picture 0 Then Call SetAutoRgn(Me) End If End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbLeftButton Then ReleaseCapture SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End If End Sub Đôc chiêu 5 : “Chụp ảnh màn hình vào một Picture” Xuất xứ : www.ttvnol.com Binh khí sử dụng : Một Picture và một CommandButton Đoạn mã : Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long Private Sub Command1_Click() Dim wScreen As Long Dim hScreen As Long Dim w As Long Dim h As Long Picture1.Cls wScreen = Screen.Width \ Screen.TwipsPerPixelX hScreen = Screen.Height \ Screen.TwipsPerPixelY Picture1.ScaleMode = vbPixels w = Picture1.ScaleWidth h = Picture1.ScaleHeight hdcScreen = GetDC(0) r = StretchBlt(Picture1.hdc, 0, 0, w, h, hdcScreen, 0, 0, wScreen, hScreen, vbSrcCopy) End Sub Đôc chiêu 6 : “Vô hiệu hoá button close và menu của form (cả Alt-F4 luôn)” Xuất xứ : www.ttvnol.com Binh khí sử dụng : Chẳng cần gì ta chỉ cần tay không bắt hổ Đoạn mã : Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Private Const MF_BYPOSITION = &H400& Private ReadyToClose As Boolean Private Sub RemoveMenus(frm As Form, _ remove_restore As Boolean, _ remove_move As Boolean, _ remove_size As Boolean, _ remove_minimize As Boolean, _ remove_maximize As Boolean, _ remove_seperator As Boolean, _ remove_close As Boolean) Dim hMenu As Long hMenu = GetSystemMenu(hwnd, False)
If remove_close Then DeleteMenu hMenu, 6, MF_BYPOSITION If remove_seperator Then DeleteMenu hMenu, 5, MF_BYPOSITION If remove_maximize Then DeleteMenu hMenu, 4, MF_BYPOSITION If remove_minimize Then DeleteMenu hMenu, 3, MF_BYPOSITION If remove_size Then DeleteMenu hMenu, 2, MF_BYPOSITION If remove_move Then DeleteMenu hMenu, 1, MF_BYPOSITION If remove_restore Then DeleteMenu hMenu, 0, MF_BYPOSITION End Sub Private Sub cmdClose_Click() ReadyToClose = True Unload Me End Sub Private Sub Form_Load() RemoveMenus Me, False, False, _ False, False, False, True, True End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Cancel = Not ReadyToClose End Sub Đôc chiêu 7 : “Kéo form di chuyển từ một điểm bất kỳ” Xuất xứ : www.allapi.com Binh khí sử dụng : Lại cũng tay không tập bắt hổ Đoạn mã : Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Sub ReleaseCapture Lib "User32" () Const WM_NCLBUTTONDOWN = &HA1 Const HTCAPTION = 2 Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lngReturnValue As Long If Button = 1 Then Call ReleaseCapture lngReturnValue = SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&) End If End Sub Private Sub Form_Paint() Me.Print "Hay keo tui di" End Sub Đôc chiêu 8 : “Ghi lại tất cả những phím gõ tên bàn phím” Xuất xứ : www.allapi.com Binh khí sử dụng : Cần một cái Module Đoạn mã : Trong Module : Public Const DT_CENTER = &H1 Public Const DT_WORDBREAK = &H10 Type RECT
Left As Long Top As Long Right As Long Bottom As Long End Type Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Global Cnt As Long, sSave As String, sOld As String, Ret As String Dim Tel As Long Function GetPressedKey() As String For Cnt = 32 To 128 If GetAsyncKeyState(Cnt) 0 Then GetPressedKey = Chr$(Cnt) Exit For End If Next Cnt End Function Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) Ret = GetPressedKey If Ret sOld Then sOld = Ret sSave = sSave + sOld End If End Sub Trong Form : Private Sub Form_Load() Me.Caption = "Key Spy" SetTimer Me.hwnd, 0, 1, AddressOf TimerProc End Sub Private Sub Form_Paint() Dim R As RECT Const mStr = "Nao bat dau go di khi ban an dau X de thoat ban se thay bat ngo thu vi day." Me.Cls Me.ScaleMode = vbPixels SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0& End Sub Private Sub Form_Resize() Form_Paint End Sub Private Sub Form_Unload(Cancel As Integer) KillTimer Me.hwnd, 0 MsgBox sSave
End Sub Đôc chiêu 10 : Đóng một ứng dụng bất kỳ Xuất xứ : www.echip.com.vn (Báo eChip) Binh khí sử dụng : Cần một cái đồng hồ(Timer) chú ý thuộc tính Interval (Riêng tôi cho là 1) Gíơi thiệu : Đoạn mã đóng một cửa sổ b ất ỳ nào đó dựa vào tên của nó Đoạn mã : Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Sub tmrkiemtra_Timer() Do While FindWindow(vbNullString, "Windows Task Manager") 0 ‘Gia su toi muon “Thu tieu “ hop thoai “Windows Task Manager” PostMessage FindWindow(vbNullString, "Windows Task Manager"), &H10, 0&, 0& Loop End Sub - Đây là một chiêu thức rất quan trọng của một phần mềm bảo mật nên có thể đang rất cần cho nhiều bạn. Riêng tôi do quá “Bất mãn” với cái bọn bạn quỷ quái nên đây s ẽ là một trong những tuyệt chiêu tôi sử dụng để viết Virus (Theo dự tính tiết thực hành thứ 2 tuần tới sẽ có vài cái máy tính của trường phải “Nhập viện” he he nhưng tôi không tàn n ẫ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 11 : Tạo phím nóng cho chương trình : Xuất xứ : www.allapi.com Binh khí sử dụng : Cần một cái Module (Form thì luôn luôn cần rồi) Đoạn mã : (Bẫy phím Alt+Z) Trong Module : Declare Function SendMessage Lib "user32" Alias _ "SendMessageA" (ByVal hwnd As Long, _ ByVal wMsg As Long, ByVal wParam As Long, _ lParam As Long) As Long Declare Function DefWindowProc Lib "user32" _ Alias "DefWindowProcA" (ByVal hwnd As Long, _ ByVal wMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long Public Const WM_SETHOTKEY = &H32 Public Const WM_SHOWWINDOW = &H18 Public Const HK_SHIFTA = &H141 'Shift + A Public Const HK_SHIFTB = &H142 'Shift * B Public Const HK_CONTROLA = &H241 'Control + A Public Const HK_ALTZ = &H45A 'The value of the key-combination has to 'declared in lowbyte/highbyte-format 'That means as a hex-number: the last two 'characters specify the lowbyte (e.g.: 41 = a), 'the first the highbyte (e.g.: 01 = 1 = Shift) Trong Form : Private Sub Form_Load() Me.WindowState = vbMinimized 'Let windows know what hotkey you want for 'your app, setting of lParam has no effect erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0)
'Check if succesfull If erg& 1 Then MsgBox "You need another hotkey", vbOKOnly, "Error" End If 'Tell windows what it should do, when the hotkey 'is pressed -> show the window! 'The setting of wParam and lParam has no effect erg& = DefWindowProc(Me.hwnd, WM_SHOWWINDOW, 0, 0) End Sub Đôc chiêu 12 : Thay đổi hình nền cho Desktop Xuất xứ : www.caulacbovb.com Binh khí sử dụng : Một CommandButton Đoạn mã : Option Explicit ‘ Các hằng số và hàm phục vụ cho việc thay đổi WallPaper Private Const SPIF_UPDATEINIFILE = &H1 Private Const SPI_SETDESKWALLPAPER = 20 Private Const SPIF_SENDWININICHANGE = &H2 Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long ‘Phục vụ cho việc ghi giá trị vào Registry Public Enum REG_TOPLEVEL_KEYS HKEY_CLASSES_ROOT = &H80000000 HKEY_CURRENT_CONFIG = &H80000005 HKEY_CURRENT_USER = &H80000001 HKEY_DYN_DATA = &H80000006 HKEY_LOCAL_MACHINE = &H80000002 HKEY_PERFORMANCE_DATA = &H80000004 HKEY_USERS = &H80000003 End Enum Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long Private Const REG_SZ = 1 Public Function ChangeWallPaper(ImageFile As String, Optional Tile As Boolean = True, Optional Center As Boolean = True) As Boolean Dim lRet As Long On Error Resume Next If Tile Then 'Kieu Tile WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper", "1" Else 'Center or Stretch WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper", "0" 'Center If Center Then WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "WallpaperStyle", "0" _ Else: WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper", "2" ' Stretch
End If lRet = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ImageFile, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) ChangeWallPaper = lRet 0 End Function Private Function WriteStringToRegistry(Hkey As REG_TOPLEVEL_KEYS, strPath As String, strValue As String, strdata As String) As Boolean Dim bAns As Boolean On Error GoTo ErrorHandler Dim keyhand As Long Dim r As Long r = RegCreateKey(Hkey, strPath, keyhand) If (r = 0) Then r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata)) r = RegCloseKey(keyhand) End If WriteStringToRegistry = (r = 0) Exit Function ErrorHandler: WriteStringToRegistry = False MsgBox "Thay doi gia tri Registry khong thanh cong", , "Loi :" End Function Private Sub Command1_Click() ‘ Load file ảnh cần thiết ChangeWallPaper "C:\Ben Tre.bmp" ‘Kiểu Tile ‘ChangeWallPaper "C:\Ben Tre.bmp", False ‘Kiểu Center ‘ChangeWallPaper "C:\Ben Tre.bmp", False, False ‘Kiểu Stretch End Sub Đôc chiêu 13 : Đóng mở khay CD-ROM Xuất xứ : www.caulacbovb.com Lưu ý: Chương trình này chỉ tác dụng tới ổ CD đầu tiên trên hệ thống của bạn (ổ có tên gần với tên Partition cuối cùng của máy). Binh khí sử dụng : 2 CommandButton Đoạn mã : Option Explicit Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hWndCallback As Long) As Long Function vbmciSendString(ByVal Command As String, ByVal hWnd As Long) As String Dim Buffer As String Dim dwRet As Long Buffer = Space$(100) dwRet = mciSendString(Command, ByVal Buffer, Len(Buffer), hWnd) vbmciSendString = Buffer End Function Private Sub Command1_Click() Dim Dummy As String Dummy = vbmciSendString("set cdaudio door open", 0) End Sub Private Sub Command2_Click() Dim Dummy As String Dummy = vbmciSendString("set cdaudio door closed ", 0) End Sub
- Sau khi họp phụ huynh về “Được” thầy chủ nhiệm “Tuyên bố” hiện nay mình đang nằm trong tốp “Báo động đỏ” hay như thầy nói nguyên văn là “Tốp dưới” cậu mình đã áp dụng biện pháp mạnh cho thằng cháu thân yêu, với phương châm “Chơi là chửi” mình đã phải “Cai máy tính máy ngày rồi”,vì vậy hiện nay cuốn sách phải “Tạm ngừng” để tui còn phải “Leo lên” thứ hạng khác trong lớp. -------------Hẹn gặp lại ở phiên bãn nâng cấp tiếp theo của cuốn sách---------------- À quên kèm theo cuốn sách tui có gửi thêm 1 bộ mã nguồn làm đẹp cho các chắc hẳn điều này sẽ làm các bạn hài lòng, và cũng xin nhắc Ai ở đ ịa b àn tỉnh Đắk Nông thì có thể liên hệ trực tiếp để trao đổi thêm đặc biệt là tại Gia Nghĩa và Huyện Krông Nô) -----------------------------Bye ( Lần này là thiệt)