Chiêu thức lập trình VB 6.0
Tác giả : Lê Nguyên Dũng
Lớp 12C
1
trường THPT Đăk Nông (Thị xã Gia Nghĩa - Đ ăk Nông)
Email : [email protected]
Nick : dungcoi_vb
Địa chỉ nhà : Thôn 1, thị trấn Đăk Mâm Huyện Krông Nô Tỉnh Đắk Nông
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 1
Chiêu thức lập trình VB 6.0
Lời nói đầu
Dù tài liệu này không có mấy người đọc nhưng dù sao với trách nhiệm và sự “Rãnh rỗi” của mình mình sẽ
tiếp tục bổ xung thêm cuốn tài liệu này đến khi nào có thể
Trong sách tôi xin chỉ rõ xuất xứ, mong rằng các ban cũng sẽ tôn trọng 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ợ.
Cuốn tài liệu được chia sẽ hoàn toàn miễn phí. Nếu có thắc mác bạn hãy liên hệ với tác giả.
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 2
Chiêu thức lập trình VB 6.0
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 37 : Hiệu ứng khi Click vào
Đôc chiêu 38 : Hàm dùng để đoc số ra chữ
Đôc chiêu 39 : Để chương trình bạn có giao diện “Nữa trong suốt”
Đôc chiêu 40 : Gửi thông điệp tới một máy tinh bất kỳ
Đôc chiêu 41 : Quét tất cả các máy trong mạng LAN
Đôc chiêu 42 : Liệt kê tất cả các tài nguyên mạng đang trong trạng thái “Mở”
Đôc chiêu 43 : Kiểm tra máy tính của bạn có kết nối Internet hay không
Đôc chiêu 44 : Liệt kê tất cả các Process đang hoạt động trong máy
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 3
Chiêu thức lập trình VB 6.0
Đôc chiêu 1 : “Thả một câu từ trên cao xuống” (Có thể nói như vậy) home
Xuất xứ : www.pscode.com
Binh khí sử dụng : Một Picture và một CommandButton
Đoạn mã :
Option Explicit
Private Sub command1_Click()
Randomize Timer 'Khởi tạo
‘Khai báo
Dim StartTime(100) 'Thời gian bắt đầu di chuyển lên
xuống
Dim DownMovement(100) As Boolean ' Chúng ta phải lên xuông bao nhiêu
??????
Dim MoveDistance As Double ' Khoảng cách đích đến
Dim YPos(100) As Double ' Tọa độ Y của chữ
Dim MovementDone(100) As Boolean ' Là đúng khi lên / xuống hoàn
thành
Dim StartHeight(100) As Double ' Chiều cào phải đi xuống ???
Dim UpMovementTime(100) As Double ' Chiều dài mà ký tự sẽ lấy để

picture1.Cls ' Xóa Picture

‘ Vòng lặp để tiến hành đếm từng ký tự
For Looop = 1 To Len(Message) If DownMovement(Looop) = True Then

MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 * ((Timer -
StartTime(Looop)) ^ 2))) ' Tính khoảng cách rơi

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 4
Chiêu thức lập trình VB 6.0
If YPos(Looop) >= picture1.ScaleHeight - 1 Then
MovementDone(Looop) = True ' Ký tự chạm phần đáy dưới Downmovement (Di
chuyển xuống) hoàn thành

Else
MoveDistance = (StartHeight(Looop) + (0.5 * 9.81 *
(UpMovementTime(Looop) - (Timer - StartTime(Looop))) ^ 2)) ' Yónh khoảng cách
rơi

If YPos(Looop) <= StartHeight(Looop) + 0.1 Then
MovementDone(Looop) = True ' Ký tự chạm đến điểm cao nhất upmovement (Di
chuyển lên trên) hòan thành

End If


Startheight mới, bởi vì tốc độ bị sai ?!?!
UpMovementTime(Looop) = Sqr((picture1.ScaleHeight -
StartHeight(Looop)) / (0.5 * 9.81)) ' D9ộ dài bao nhiêu sẽ upmovement
(Di chuyển lên trên) sau đó???
Else
DownMovement(Looop) = True
End If

StartTime(Looop) = Timer ' Đặt thời gian bắt đầu
di chuyển
MovementDone(Looop) = False
End If

Next Looop

Loop ' Đến khi StartHeight = picture1.ScaleHeight

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 5
Chiêu thức lập trình VB 6.0
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
End
End Sub
Đôc chiêu 2 : Hiện một câu bằng cách lần lượt hiện từng chữ home
Xuất xứ : www.pscode.com
Binh khí sử dụng : Một Module , ba CommandButton lần lượt có các tên cmdStart, cmdClear, cmdExit, thêm
hai cái đồng hồ tên là Timer1 (Interval =50) và Timer2(Interval =5) cả hai cái đồng hồ đều phải Enabled=
False cuối cùng là một label tên là lblText

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

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 6
Chiêu thức lập trình VB 6.0
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

Xuất xứ : www.pscode.com
Binh khí sử dụng :
- 1 picture mang tên : picMainSkin trong đó có chứa sẵn một hình ảnh bất kỳ mà bạn muốn làm giao
diện chương trình màu tượng trưng cho trong suốt là màu ở câu lệnh TransparentColor =
GetPixel(hDC, 0, 0) có nghĩa là sẽ chính là màu của điểm có tọa độ (0,0) trên Picture này đây chính
là một trong những điểm thú vị của đọan Code này.
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 7
Chiêu thức lập trình VB 6.0
- 1 Module
Đoạn mã :
‘Trong Module :
Option Explicit
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As
Long, ByVal y 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 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 Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Public Const RGN_OR = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
DeleteObject LineRegion
End If
End If
Else
If Not InLine Then
InLine = True
StartLineX = x
End If
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 8
Chiêu thức lập trình VB 6.0
End If
Next
Next

MakeRegion = FullRegion
End Function
‘Trong Form:
Option Explicit
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
ByVal cy As Long, ByVal wFlags As Long) As Long
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Sub Form_Load()
Dim WindowRegion As Long
picMainSkin.ScaleMode = vbPixels

wScreen = Screen.Width \ Screen.TwipsPerPixelX
hScreen = Screen.Height \ Screen.TwipsPerPixelY
Picture1.ScaleMode = vbPixels
w = Picture1.ScaleWidth
h = Picture1.ScaleHeight
hdcScreen = GetDC(0)
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 9
Chiêu thức lập trình VB 6.0
r = StretchBlt(Picture1.hdc, 0, 0, w, h, hdcScreen, 0, 0, wScreen, hScreen,
vbSrcCopy)
End Sub
Đôc chiêu 6 : “Vô hiệu hoá button close và menu của form (cả Alt-F4 luôn)” home
Xuất xứ : www.ttvnol.com
Binh khí sử dụng : Chẳng cần gì ta chỉ cần tay không bắt hổ
Đoạn mã :
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal
nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal
bRevert As Long) As Long
Private Const MF_BYPOSITION = &H400&
Private ReadyToClose As Boolean
Private Sub RemoveMenus(frm As Form, _
remove_restore As Boolean, _
remove_move As Boolean, _
remove_size As Boolean, _
remove_minimize As Boolean, _
remove_maximize As Boolean, _
remove_seperator As Boolean, _

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal
hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y
As Single)
Dim lngReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
lngReturnValue = SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub Form_Paint()
Me.Print "Hay keo tui di"
End Sub
Đôc chiêu 8 : “Ghi lại tất cả những phím gõ tên bàn phím” home
Xuất xứ : www.allapi.net
Binh khí sử dụng : Cần một cái Module
Đoạn mã :
Trong Module :
Public Const DT_CENTER = &H1
Public Const DT_WORDBREAK = &H10
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As

Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 11
Chiêu thức lập trình VB 6.0
SetTimer Me.hwnd, 0, 1, AddressOf TimerProc
End Sub
Private Sub Form_Paint()
Dim R As RECT
Const mStr = "Nao bat dau go di khi ban an dau X de thoat ban se thay bat
ngo thu vi day."
Me.Cls
Me.ScaleMode = vbPixels
SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight
DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0&
End Sub
Private Sub Form_Resize()
Form_Paint
End Sub
Private Sub Form_Unload(Cancel As Integer)
KillTimer Me.hwnd, 0
MsgBox sSave
End Sub
Đôc chiêu 9 : Đóng một ứng dụng bất kỳ home
Xuất xứ : www.echip.com.vn (Báo eChip)
Binh khí sử dụng : Cần một cái đồng hồ(Timer) chú ý thuộc tính Interval (Riêng tôi cho là 1)
Gíơi thiệu : Đoạn mã đóng một cửa sổ bất ỳ nào đó dựa vào tên của nó
Đoạn mã :
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal

Public Const HK_CONTROLA = &H241 'Control + A
Public Const HK_ALTZ = &H45A
'The value of the key-combination has to
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 12
Chiêu thức lập trình VB 6.0
'declared in lowbyte/highbyte-format
'That means as a hex-number: the last two
'characters specify the lowbyte (e.g.: 41 = a),
'the first the highbyte (e.g.: 01 = 1 = Shift)
Trong Form :
Private Sub Form_Load()
Me.WindowState = vbMinimized
'Let windows know what hotkey you want for
'your app, setting of lParam has no effect
erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0)
'Check if succesfull
If erg& <> 1 Then
MsgBox "You need another hotkey", vbOKOnly, "Error"
End If
'Tell windows what it should do, when the hotkey
'is pressed -> show the window!
'The setting of wParam and lParam has no effect
erg& = DefWindowProc(Me.hwnd, WM_SHOWWINDOW, 0, 0)
End Sub
Đôc chiêu 11 : Thay đổi hình nền cho Desktop home
Xuất xứ : www.caulacbovb.com
Binh khí sử dụng : Một CommandButton
Đoạn mã :

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",
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 13
Chiêu thức lập trình VB 6.0
"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

End Sub
Private Sub Command2_Click()
Dim Dummy As String
Dummy = vbmciSendString("set cdaudio door closed ", 0)
End Sub
Đôc chiêu 13 : Tạo một SystemTray cho ứng dụng của bạn home
Xuất xứ : www.ttvnol.com
Binh khí sử dụng : Tương đối nhiều
Đoạn mã :
PHẦN I _ Tạo một OCX đặt tên là cSysTray.ocx
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 14
Chiêu thức lập trình VB 6.0
Bạn vào VB tạo một ActiveX Control, sau đó add một Module đặt tên là: mSysTray.bas và có nội dung như
sau :
--------- Module mSysTray.bas ----------
Option Explicit
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As
Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal
nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal
nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As
Long, lpData As NOTIFYICONDATA) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any,
ByVal ByteLen As Long)
Public Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long,
ByVal grfFlags As Long) As Boolean

uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Public Type RECT
Left As Long
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 15
Chiêu thức lập trình VB 6.0
Top As Long
Right As Long
Bottom As Long
End Type
Public PrevWndProc As Long
'------------------------------------------------------------
Public Function SubWndProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal
lParam As Long) As Long
'------------------------------------------------------------
Dim SysTray As cSysTray
Dim ClassAddr As Long
'------------------------------------------------------------
Select Case MSG
Case TRAY_CALLBACK
ClassAddr = GetWindowLong(hwnd, GWL_USERDATA)
CopyMemory SysTray, ClassAddr, 4
SysTray.SendEvent lParam, wParam
CopyMemory SysTray, 0&, 4
End Select
SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam)

gInTray = defInTray
gAddedToTray = False
gTrayId = 0
gTrayHwnd = hwnd
'-------------------------------------------------------
End Sub
'-------------------------------------------------------
'-------------------------------------------------------
Private Sub UserControl_InitProperties()
'-------------------------------------------------------
InTray = defInTray
TrayTip = defTrayTip
Set TrayIcon = Picture
'-------------------------------------------------------
End Sub
'-------------------------------------------------------
'-------------------------------------------------------
Private Sub UserControl_Paint()
'-------------------------------------------------------
Dim edge As RECT
'-------------------------------------------------------
edge.Left = 0
edge.Top = 0
edge.Bottom = ScaleHeight
edge.Right = ScaleWidth
DrawEdge hDC, edge, BDR_RAISEDOUTER, BF_RECT Or BF_SOFT
'-------------------------------------------------------
End Sub
'-------------------------------------------------------
'-------------------------------------------------------

'-------------------------------------------------------
End Sub
'-------------------------------------------------------
'-------------------------------------------------------
Private Sub UserControl_Terminate()
'-------------------------------------------------------
If InTray Then
InTray = False
End If
'-------------------------------------------------------
End Sub
'-------------------------------------------------------
'-------------------------------------------------------
Public Property Set TrayIcon(Icon As StdPicture)
'-------------------------------------------------------
Dim Tray As NOTIFYICONDATA
Dim rc As Long
'-------------------------------------------------------
If Not (Icon Is Nothing) Then
If (Icon.Type = vbPicTypeIcon) Then
If gAddedToTray Then
Tray.uID = gTrayId
Tray.hwnd = gTrayHwnd
Tray.hIcon = Icon.Handle
Tray.uFlags = NIF_ICON
Tray.cbSize = Len(Tray)
rc = Shell_NotifyIcon(NIM_MODIFY, Tray)
End If
Set gTrayIcon = Icon
Set Picture = Icon

End If
gTrayTip = Tip
PropertyChanged 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) Then
If Show Then
If Ambient.UserMode Then
PrevWndProc = SetWindowLong(gTrayHwnd, GWL_WNDPROC, AddressOf SubWndProc)
SetWindowLong gTrayHwnd, GWL_USERDATA, ObjPtr(Me)
AddIcon gTrayHwnd, gTrayId, TrayTip, TrayIcon
gAddedToTray = True
End If
Else
If gAddedToTray Then
DeleteIcon gTrayHwnd, gTrayId
SetWindowLong gTrayHwnd, GWL_WNDPROC, PrevWndProc

Tray.hIcon = Icon.Handle
Tray.uFlags = Tray.uFlags Or NIF_ICON
Set gTrayIcon = Icon
End If
If (Tip <> "") Then
Tray.szTip = Tip & vbNullChar
Tray.uFlags = Tray.uFlags Or NIF_TIP
gTrayTip = Tip
End If
Tray.uCallbackMessage = TRAY_CALLBACK
Tray.uFlags = Tray.uFlags Or NIF_MESSAGE
Tray.cbSize = Len(Tray)
rc = Shell_NotifyIcon(NIM_ADD, Tray)
'-------------------------------------------------------
End Sub
'-------------------------------------------------------
'-------------------------------------------------------
Private Sub DeleteIcon(hwnd As Long, Id As Long)
'-------------------------------------------------------
Dim Tray As NOTIFYICONDATA
Dim rc As Long
'-------------------------------------------------------
Tray.uID = Id
Tray.hwnd = hwnd
Tray.uFlags = 0&
Tray.cbSize = Len(Tray)
rc = Shell_NotifyIcon(NIM_DELETE, Tray)
'-------------------------------------------------------
End Sub
'-------------------------------------------------------

Bạ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 Button
Case vbRightButton
PopupMenu MainMenu
End Select
End Sub
Private Sub Form_Load()
Me.Visible=False
cSysTray1.InTray=True
cSysTray1.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 Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharset As Byte
lfOutPrecision As Byte

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 = -13
Private Const VNI_FontWeight = 700
Private Const VNI_FontName = "VNI-Palatin"
Private Const VNI_FontLen = 11 `Len(VNI_FontName)
Private FontMetric As NONCLIENTMETRICS
Private OldFontMetric As NONCLIENTMETRICS
'Thủ tục này dùng để thay đổi Font của Menu
Private Sub ChangeFont()
Dim I As Integer
Dim VarGT As Long
Dim VarHeight As Long
Dim VarWeight As Long
Dim VarStr As String
FontMetric.cbSize = REG_StructureSize
VarGT = SystemParametersInfo(SPI_GetNonClientMetrics,REG_StructureSize, FontMetric, 0)
OldFontMetric =FontMetric
FontMetric.lfCaptionFont.lfHeight = VNI_FontHeight
FontMetric.lfCaptionFont.lfWeight = VNI_FontWeight
VarStr = VNI_FontName
For I=1 To LF_FaceSize
If I <= VNI_FontLen Then
FontMetric.lfCaptionFont.lfFaceName(I)= CByte(Asc(Mid(VarStr,I,1)))
FontMetric.lfMenuFont.lfFaceName(I)= CByte(Asc(Mid(VarStr,I,1)))
Else
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 22

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&
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 23
Chiêu thức lập trình VB 6.0
Const ERROR_INVALID_PARAMETER = 7&
Const ERROR_ACCESS_DENIED = 8&
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const MAX_PATH = 260&
Private Const REG_SZ = 1
'Hàm API cần thiết
Private Declare Sub SHChangeNotify Lib "shell32.dll" _

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ện
sKeyName = "Khunglongbeo"
Tác giả : Lê Nguyên Dũng lớp 12C
1
trường THPT Đăk Nông Trang 24
Chiêu thức lập trình VB 6.0
'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 Icon
SHChangeNotify 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_Thong
End 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)