Tài liệu Chiêu thức lập trình VB ppt

À 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.pscod

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) <= 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)

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 <= EPos Then

''Khởi tạo miền hình chữ nhật thứ hai

Rgn2 = CreateRectRgn(SPos - 1 + xoff, Y - 1 + yoff, EPos + xoff, Y + yoff)

''Chồng 2 miền hình chữ nhật đã tạo với toán tử OR để loại trừ những điểm ảnh giống nhau

'' Và lưu vào giá trị của miền chữ nhật thứ nhất

CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR

DeleteObject Rgn2

End If

Loop Until X >= 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