VB How To's
-replace system icons in Windows 2000
-simple malware detection tips
-how to email an attachment via MAPI
-why your Wizard made Application remains visible in the Task List after Exit
-how to place an icon to a System Tray, and switch it
-system tray popup issues
-read last typed URLs from IE link bar
-RLE (run-length encoding compression) example
-how to change MS Outlook security settings programmatically
-how to open Add Network Drive dialog
-how to create shortcut on Windows Desktop
-how to Reboot or Shutdown Windows 2000
-how to get Visual Studio for almost nothing
- replace system icons in Windows 2000
The icons you see every day in your Windows Explorer are not very nice. You can find some really neat on the Internet. Or you can even create your very own special icons using a handy tool such as Icon Easel.
To me there was a bigger problem not to paint them in eyecatching colors but actually install the icons so Windows starts using them. To display mine instead of those crazy ones.
The secret is buried in the Windows 2000 Registry. But not very deep.
Can you see the registry path in the piece of code below? That's it. But before you start copying the code I want to explain you something else.
All icons in the Windows Explorer have numbers. Here are some:
3- folder icon, 4- open folder icon, 30- trash can, etc.
If you have a simple program such as ResExplorer (from Borland) you can see what are the numbers of the icons in the Shell32.DLL file that resides in the System32 folder. Subtract 1 from the icon number you see in the DLL and you will have the number you can use in the Registry.
Now we are back to the Registry. If you've drawn your own Folder icon and want it to replace the Folder icon displayed by Windows you have to do the following.
- place your icon's .ICO file to a separate folder (needless to say, your icon file should contain at least 2 images- one 32x32 and one 16x16 pixels).
- start Notepad.EXE.
- copy and paste the following three lines into the Notepad. Replace "myfolder" and "myicon" with real names of the directory and file.
Windows Registry Editor Version 5.00
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Icons]
"3"="c:\\myfolder\\myicon.ico,0"
and this icon will replace the one having #3 ,the Folder Icon
some notes: you have to replace a single backslash character with two of them when you work with Registry just like it is displayed in the line above, and you probably have to restart Windows (or restart the Explorer)
- simple malware detection tips
Since the DOS time the best way to infect a machine by a virus was by infecting system files or auto start files of the operating system. I would not argue if you tell me about billions of viruses that distribute themselves via E-mail, or IIS- "Internet Infection Server", or VPN- "Vir-u-tal Private Networks", but some crazy hackers still use the good old method.
Any OS has a set of files that are not supposed to change over time. But they are vulnerable against a virus.
I think a good method of a timely notification about any virus is to check the control sum of some important system files every time you start your PC or click a special shortcut on a Desktop.
This method may not fix the problem and will not cure the machine, but "if you are informed you are armed". After the checksum does not match the standard pattern, you might want to run your antivirus software. And the viruses will be removed before they make any real harm to your machine.
The general recommendations will be the following:
Only once, on the program installation and activation...
- obtain the list of important and vulnerable files (programs, scripts, executables, web pages)
Then, on the timely basis...
- check whether the list of those files has been changed,
- check whether the dates/times of those files changed,
- check whether the byte checksum of every file in the list matches the standard pattern,
- prompt the user (yourself?) to make any aactions because something changed with the files.
To make this check run automatically you can use the Task Scheduler application provided with Windows. And/or you can put the shortcut to the checking program in your Programs\StartUp folder so Windows will check the file system status every time it boots up.
- how to E-mail file attachments via MAPI
.BAS module (recommended):
Public Declare Function MAPISendDocuments Lib "MAPI32.DLL" _
(ByVal UIParam&, _
ByVal DelimStr$, _
ByVal FilePaths$, _
ByVal FileNames$, _
ByVal Reserved&) As Long
Calling function:
Private Sub mnuFileSend_Click()
Dim res As Long ' result
' The only MAPI function we need for sending files is MapiSendDocuments.
' It opens new Mail Message window so you can enter recipients' addresses.
res = MAPISendDocuments(0&, ";", FULLPATHTOFILE, FILENAMEONLY, 0&)
MsgBox res, vbInformation, "Result"
End Sub
I am sure you understand that FULLPATHTOFILE is a string variable or a constant containing full actual path to the file, and FILENAMEONLY is a string variable or constant that is for display purpose only, it has to be visible next to the attachment icon in the mail client window.
Examples of contents of FULLPATHTOFILE and FILENAMEONLY respectively:
"C:\Autoexec.bat; c:\temp\file.doc" "autoexec.bat; file.doc"
"\\MYSERVER\SHARE\Folder\file.txt" "file.txt"
As you see, you can send a series of files, just separate the entries by a delimiting character. Make sure you send the delimiter to the MAPISendDocuments function also.
For a delimiter I would suggest you using a character that cannot be used in a file name. Such as "|" (vertical line) or something else. In the example above I use semicolon, but only for the sake of nice example.
- why your Wizard made Application remains visible in the Task List after Exit
Because it's the Microsoft's bug :)
Well, let's look at the source module created by one of Form Wizards.
It has a function run on Unload event.
It looks like this:
Private Sub Form_Unload(Cancel As Integer)
Dim i As Integer
'close all sub forms
For i = Forms.Count - 1 To 1 Step -1
Unload Forms(i)
Next
'more code goes here...
End Sub
The error is in the For command. There should be 0 instead of 1.
If it is 1, one of child forms will reside active, and the app will be visible in the Task List.
If it is 0, all forms will be properly unloaded, and the application will shut down properly.
So, change it to:
on error resume next
For i = Forms.Count - 1 To 0 Step -1
...
- how to place an icon into the System Tray (and switch the icon)
.BAS module:
Option Explicit Declare Function Shell_NotifyIcon Lib "shell32.dll" _
Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) As Long
Public Const WM_MOUSEMOVE = &H200
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const NIM_MODIFY = &H1
Public Const MAX_TOOLTIP As Integer = 64
Type NOTIFYICONDATA cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * MAX_TOOLTIP
End Type
Public nfIconData As NOTIFYICONDATA
'( you do not have to declare all constants, they are here only for convenience)
Form .FRM module:
Private Sub Form_Load()
lightIsOn = False 'my variable indicating what mode the ison is in
Me.Icon = LoadResPicture(101, 1) 'my custom icon
With nfIconData .hwnd = Me.hwnd
.uID = MAINID
' I use my own MAINID custom constant of Long type, you should declare yours.
' This constant is very important, if you do not use it you will not be able
' to get to this Icon again...
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP 'flags
.uCallbackMessage = WM_MOUSEMOVE 'event to react to
.hIcon = Me.Icon.Handle
.szTip = "System Tray Example" & Chr$(0)
'sometimes zero termination is not needed...
.cbSize = Len(nfIconData)
End With
Call Shell_NotifyIcon(NIM_ADD, nfIconData)
Timer1.Interval = 1000
Timer1.Enabled = True
End Sub
'(in my example I use Timer to switch the icon image every second)
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Select Case X
Case 7680 'MouseMove
Case 7695 'LeftMouseDown
Case 7710 'LeftMouseUp
Case 7725 'LeftDblClick
Case 7740 'RightMouseDown
PopupMenu mnuPopup, 0, , , mnuClose
Case 7755 'RightMouseUp
Case 7770 'RightDblClick
End Select
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call Shell_NotifyIcon(NIM_DELETE, nfIconData)
End
End Sub
Private Sub Timer1_Timer()
If lightIsOn Then Me.Icon = LoadResPicture(101, 1)
lightIsOn = False
Else
Me.Icon = LoadResPicture(103, 1)
lightIsOn = True
End If
nfIconData.hIcon = Me.Icon.Handle
Call Shell_NotifyIcon(NIM_MODIFY, nfIconData)
End Sub
- how to fix System Tray popup issues
Problem: when a popup appears after clicking the system tray icon, it never hides until it is clicked.
Moreover, if you click any other icon in the tray, or the system tray itself, this popup hides behind the tray, and there is no way to bring it atop again.
The solution is simple.
Right before producing the popup on the screen, call the SetForeGroundWindow API function against the main form of the program.
Example:
'SetForegroundWindow is described like:
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Select Case X
Case 7680 'MouseMove
Case 7695 'LeftMouseDown
Case 7710 'LeftMouseUp
Case 7725 'LeftDblClick
Call mnuShow_Click
Case 7740 'RightMouseDown
Call SetForegroundWindow(Me.hwnd)
PopupMenu mnuPopup, 0, , , mnuShow
Case 7755 'RightMouseUp
Case 7770 'RightDblClick
End Select
End Sub
- read last typed URLs from Internet Explorer link bar
Put this into a .BAS module:
Public Function GetTypedURLs(Optional BrowserName As String = "IE") As Collection 'HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\TypedURLs
Dim index As Long
Dim SubKey As String
Dim nType As Long
Dim nRet As Long
Dim hKey As Long
Dim nBytes As Long
Dim tmpstr As String
Dim tmpcol As New Collection
Set tmpcol = Nothing
If BrowserName = "IE" Then
If RegOpenKeyEx(HKEY_CURRENT_USER, _
"Software\Microsoft\Internet Explorer\TypedURLs",_
0&, KEY_READ, hKey) = ERROR_SUCCESS Then
index = 0
nRet = ERROR_SUCCESS
Do While nRet = ERROR_SUCCESS
index = index + 1
SubKey = "url" & CStr(index)
nRet = RegQueryValueEx(hKey, SubKey, 0&, nType, ByVal tmpstr, nBytes)
If nBytes > 0 Then tmpstr = Space(nBytes)
nRet = RegQueryValueEx(hKey, SubKey, 0&, nType, ByVal tmpstr, Len(tmpstr))
If nRet = ERROR_SUCCESS Then
tmpcol.Add Left(tmpstr, nBytes - 1), SubKey
End If
End If
Loop
Call RegCloseKey(hKey)
End If
else
MsgBox "Hope you send me a clue about Netscape ;)"
End If
Set GetTypedURLs = tmpcol
End Function
The RegOpenValueEx and RegQueryValueEx functions are described in Advapi32.dll:
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private 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
'if you declare the lpData parameter as String, you must pass it By Value.
- simple example of RLE (run-length encoding) compression algorithm
There are some cases when you have to write your own data compression function. And it should look and feel like the one written by a real professional ;)
For example, you are writing your very own .BMP to .PCX file converter.
Or you are writing a Visual Basic program that places an image into a PDF (Adobe Acrobat) file.
You will need a function that makes the image ten times smaller. Otherwise you'll have to buy a whole rack of 200Gbyte hard drives and order a Gigabit Ethernet for your new portable Pentium 8 server ;)
Ok, here is one.
This function receives an array of bytes and returns another array of bytes.
Private Function RLE(a As Variant) As Variant
Dim b() As Byte, tmp(128) As Byte
Dim k As Long, i As Long, bcount As Long
Dim alen As Long
alen = UBound(a) - 2
ReDim b(alen)
i = 0
bcount = 1
For k = 0 To alen
If bcount < 128 Then
If a(k + 1) = a(k) Then
bcount = bcount + 1
Else
If bcount = 1 Then
b(i) = 0
i = i + 1
b(i) = a(k)
i = i + 1
Else
b(i) = 257 - bcount
i = i + 1
b(i) = a(k)
i = i + 1
bcount = 1
End If
End If
Else
b(i) = 129
i = i + 1
b(i) = a(k)
i = i + 1
bcount = 1
End If
Next
b(i) = 128 'EOD
ReDim Preserve b(i)
RLE = b
End Function
'-----------------------------------
' PROJECT NOTES
'-----------------------------------
'Details of Filtered Streams (Adobe PDF Manual):
'3.3.4 RunLengthDecode Filter
'The RunLengthDecode filter decodes data that has been encoded in a simple
'byte-oriented format based on run length. The encoded data is a sequence of
'runs, where each run consists of a length byte followed by 1 to 128 bytes of data. If
'the length byte is in the range 0 to 127, the following length +1 (1 to 128) bytes
'are copied literally during decompression. If length is in the range 129 to 255, the
'following single byte is to be copied 257 -length (2 to 128) times during decompression.
'A length value of 128 denotes EndOfData.
'The compression achieved by run-length encoding depends on the input data. In
'the best case (all zeros), a compression of approximately 64: 1 is achieved for long
'files. The worst case (the hexadecimal sequence 00 alternating with FF) results in
'an expansion of 127: 128.
- TaskList application (under construction)
- start and wait (under construction)
- determine OS family and version (under construction)
- how to change MS Outlook 2000 security settings programmatically outside of Outlook :)
' Change Outlook security to 1 ("low")
' This function looks verbose, but only because I like the user knowing about
' everything that happens to his or her machine.
' VBScript code follows...
Dim WSHShell
On Error resume next
Set WSHShell = CreateObject("WScript.Shell")
If not WSHShell Is Nothing Then
WSHShell.RegWrite _
"HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Outlook\Security\Level", _
1, "REG_DWORD"
if err.number <> 0 then
msgbox err.description
else
msgbox "Update complete. Thank you"
end if
else
msgbox "Can't create WScript.Shell object"
end if
- opening Add a Network Drive dialog:
'Visual Basic code follows...
Option Explicit
Private Const RESOURCETYPE_DISK = &H1
Private Declare Function WNetConnectionDialog Lib "mpr.dll" _
(ByVal hwnd As Long, ByVal dwType As Long) As Long
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" _
(ByVal hwnd As Long, ByVal dwType As Long) As Long
Private Sub cmdStart_Click()
Dim result As Integer
result = WNetConnectionDialog(0, 1)
End Sub
- how to create a Shortcut on the Desktop
' VBScript code follows...
' - Run Notepad.EXE
' - Copy-paste the code from below.
' - Save the file as Shortcut.VBS
Dim WSHShell
Dim MyShortcut
Dim DesktopPath
On Error resume next
Set WSHShell = CreateObject("WScript.Shell")
If not WSHShell Is Nothing Then
DesktopPath = WSHShell.SpecialFolders("Desktop")
Set MyShortcut = WSHShell.CreateShortCut(DesktopPath & "\CBDDoc" & ".lnk")
MyShortcut.TargetPath = "c:\myfolder"
MyShortcut.WorkingDirectory = "c:\myfolder"
MyShortcut.WindowStyle = 1
MyShortcut.Arguments = ""
MyShortcut.IconLocation = "c:\myfolder\myprogram.exe,0"
MyShortcut.Save
Set MyShortcut = Nothing
if err.number <> 0 then
msgbox err.description
else
msgbox "Update complete. Thank you"
end if
else
msgbox "Can't create WScript.Shell object"
end if
- Restart or Shutdown PC with Windows 2000
'This is descriptive part (cut and paste it into .bas module).
' You'll need the Visual Basic environment to compile and run the code...
Option Explicit
Option Private Module
Public Const ANYSIZE_ARRAY = 1
Public Type LUID
lowpart As Long
highpart As Long
End Type
Public Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Public Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Public Declare Function OpenProcessToken Lib "advapi32.dll" ( _
ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) _
As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias _
"LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, _
lpLuid As LUID) As Long
Public Declare Function AdjustTokenPrivileges Lib "advapi32.dll" ( _
ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _
NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _
PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Public Declare Function GetLastError Lib "kernel32" () As Long
Public Const DELETE = &H10000
Public Const READ_CONTROL = &H20000
Public Const WRITE_DAC = &H40000
Public Const WRITE_OWNER = &H80000
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const STANDARD_RIGHTS_READ = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Public Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const SPECIFIC_RIGHTS_ALL = &HFFFF&
Public Const TOKEN_ASSIGN_PRIMARY = &H1&
Public Const TOKEN_DUPLICATE = &H2&
Public Const TOKEN_IMPERSONATE = &H4&
Public Const TOKEN_QUERY = &H8&
Public Const TOKEN_QUERY_SOURCE = &H10&
Public Const TOKEN_ADJUST_PRIVILEGES = &H20&
Public Const TOKEN_ADJUST_GROUPS = &H40&
Public Const TOKEN_ADJUST_DEFAULT = &H80&
Public Const TOKEN_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED Or _
TOKEN_ASSIGN_PRIMARY Or _
TOKEN_DUPLICATE Or _
TOKEN_IMPERSONATE Or _
TOKEN_QUERY Or _
TOKEN_QUERY_SOURCE Or _
TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_ADJUST_GROUPS Or _
TOKEN_ADJUST_DEFAULT
Public Const TOKEN_READ = STANDARD_RIGHTS_READ Or TOKEN_QUERY
Public Const TOKEN_WRITE = STANDARD_RIGHTS_WRITE Or _
TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_ADJUST_GROUPS Or _
TOKEN_ADJUST_DEFAULT
Public Const TOKEN_EXECUTE = STANDARD_RIGHTS_EXECUTE
Public Const SE_CREATE_TOKEN_NAME = "SeCreateTokenPrivilege"
Public Const SE_ASSIGNPRIMARYTOKEN_NAME = "SeAssignPrimaryTokenPrivilege"
Public Const SE_LOCK_MEMORY_NAME = "SeLockMemoryPrivilege"
Public Const SE_INCREASE_QUOTA_NAME = "SeIncreaseQuotaPrivilege"
Public Const SE_UNSOLICITED_INPUT_NAME = "SeUnsolicitedInputPrivilege"
Public Const SE_MACHINE_ACCOUNT_NAME = "SeMachineAccountPrivilege"
Public Const SE_TCB_NAME = "SeTcbPrivilege"
Public Const SE_SECURITY_NAME = "SeSecurityPrivilege"
Public Const SE_TAKE_OWNERSHIP_NAME = "SeTakeOwnershipPrivilege"
Public Const SE_LOAD_DRIVER_NAME = "SeLoadDriverPrivilege"
Public Const SE_SYSTEM_PROFILE_NAME = "SeSystemProfilePrivilege"
Public Const SE_SYSTEMTIME_NAME = "SeSystemtimePrivilege"
Public Const SE_PROF_SINGLE_PROCESS_NAME = "SeProfileSingleProcessPrivilege"
Public Const SE_INC_BASE_PRIORITY_NAME = "SeIncreaseBasePriorityPrivilege"
Public Const SE_CREATE_PAGEFILE_NAME = "SeCreatePagefilePrivilege"
Public Const SE_CREATE_PERMANENT_NAME = "SeCreatePermanentPrivilege"
Public Const SE_BACKUP_NAME = "SeBackupPrivilege"
Public Const SE_RESTORE_NAME = "SeRestorePrivilege"
Public Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Public Const SE_DEBUG_NAME = "SeDebugPrivilege"
Public Const SE_AUDIT_NAME = "SeAuditPrivilege"
Public Const SE_SYSTEM_ENVIRONMENT_NAME = "SeSystemEnvironmentPrivilege"
Public Const SE_CHANGE_NOTIFY_NAME = "SeChangeNotifyPrivilege"
Public Const SE_REMOTE_SHUTDOWN_NAME = "SeRemoteShutdownPrivilege"
Public Const SE_PRIVILEGE_ENABLED_BY_DEFAULT = &H1&
Public Const SE_PRIVILEGE_ENABLED = &H2&
Public Const SE_PRIVILEGE_USED_FOR_ACCESS = &H80000000
Public Const ERROR_SUCCESS = 0&
Public Declare Function InitiateSystemShutdown Lib "advapi32.dll" _
Alias "InitiateSystemShutdownA" ( _
ByVal lpMachineName As String, ByVal lpMessage As String, _
ByVal dwTimeout As Long, ByVal bForceAppsClosed As Long, _
ByVal bRebootAfterShutdown As Long) As Boolean
Public Declare Function AbortSystemShutdown Lib "advapi32.dll" _
Alias "AbortSystemShutdownA" (ByVal lpMachineName As String) As Long
Public tkpSaved As TOKEN_PRIVILEGES
Public hToken As Long
'And this is the implementation.(call from a form, or class, or module)
Public Function SetPrivilege(ByVal cPrivilegeName As String) As Boolean
Dim tkp As TOKEN_PRIVILEGES
Dim lDummy As Long
Dim lRequired As Long
Dim bRetVal As Boolean
' Get the current process token handle so we can get shutdown privilege.
If OpenProcessToken(GetCurrentProcess(), _
TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken) Then
' Get the LUID for shutdown privilege.
If LookupPrivilegeValue(vbNullString, cPrivilegeName, tkp.Privileges(0).pLuid) > 0 Then
tkp.PrivilegeCount = 1 ' one privilege to set
tkp.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
' Get shutdown privilege for this process.
lDummy = AdjustTokenPrivileges(hToken, False, tkp, Len(tkpSaved), tkpSaved, lRequired)
' Cannot test the return value of AdjustTokenPrivileges.
lDummy = GetLastError
If lDummy = ERROR_SUCCESS Then
bRetVal = True
Else
Debug.Print lDummy
End If
End If
End If
SetPrivilege = bRetVal
End Function
Public Sub ShutDown(ByVal cComputerName As String, ByVal cMessage As String, _
ByVal lTimeout As Long, ByVal bForceAppsClosed As Boolean, _
ByVal bRebootAfterShutdown As Boolean)
Dim bDummy As Boolean
If Len(cComputerName) = 0 Then
bDummy = SetPrivilege(SE_SHUTDOWN_NAME)
Else
bDummy = SetPrivilege(SE_REMOTE_SHUTDOWN_NAME)
End If
If bDummy Then
' Display the shutdown dialog box and start the countdown.
If InitiateSystemShutdown(cComputerName, cMessage, lTimeout, _
bForceAppsClosed, bRebootAfterShutdown) Then
'Disable shutdown privilege.
ResetPrivilege
End If
End If
End Sub
C stuff
- check the processor speed
- writing a simple DLL for using with VB
Lotus
to be continued