Create Balloon Tips in SysTray

November 18, 2007

You may wondering how to create balloon tips in Visual Basic put in systray.

Allright then, this is how!

Option Explicit
Private Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 128
dwState As Long
dwStateMask As Long
szInfo As String * 256
uTimeout As Long
szInfoTitle As String * 64
dwInfoFlags As Long
End TypePrivate sysTray As NOTIFYICONDATA

'Constants
Private Const NOTIFYICON_VERSION = 3
Private Const NOTIFYICON_OLDVERSION = 0

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2

Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10

Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2

Private Const NIIF_NONE = &H0
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_INFO = &H1
Private Const NIIF_GUID = &H4

Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206

' API Declaration
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Private Sub Command1_Click()

With sysTray
.cbSize = Len(sysTray)
.hWnd = Me.Picture1.hWnd
.uID = vbNull
.uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Picture1.Picture
.szTip = " Here placing toolTip " & vbNullChar
.dwState = 0
.dwStateMask = 0
End With

Shell_NotifyIcon NIM_ADD, sysTray

End Sub

Private Sub Command2_Click()
With sysTray
.cbSize = Len(sysTray)
.hWnd = Picture1.hWnd
.uID = vbNull
.uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Picture1
.szTip = " Here placing toolTip " & vbNullChar
.dwState = 0
.dwStateMask = 0
.szInfo = Text2 & Chr(0)
.szInfoTitle = Text1 & Chr(0)
.dwInfoFlags = NIIF_INFO
.uTimeout = 100
End With

Shell_NotifyIcon NIM_MODIFY, sysTray
End Sub

Private Sub Command3_Click()
Shell_NotifyIcon NIM_DELETE, sysTray
End Sub

Private Sub Form_Load()
Command1.Caption = " Report on Systray "
Command2.Caption = " Show Balloon dialogue "
Command3.Caption = " Remove from systray "
Text1 = App.EXEName
Text2 = " Welcome to STMIK Banjarbaru zone! "
End Sub


Extract Icon From A File

September 15, 2007

Ever wanted to get the icon that a file uses? This simple Extract_Icon function shows you how…

Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_ICON = &H100
Private Const SHGFI_SYSICONINDEX = &H4000 ' get system icon index
Private Const SHGFI_LARGEICON = &H0 ' get large icon
Private Const SHGFI_SMALLICON = &H1 ' get small icon
Private Const ILD_TRANSPARENT = &H1
Public Const MAX_PATH = 260
Private Type SHFILEINFO 'Structure used by SHGetFileInfo
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private Declare Function ImageList_Draw Lib "comctl32.dll" (ByVal himl&, ByVal i&, ByVal hDCDest&, ByVal x&, ByVal y&, ByVal flags&) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long

Public Function ExtractIcon(picImage As PictureBox, sFile As String)
Dim himl As Long
Dim lpzxExeName As String
Dim lRet As Long
Dim sWinPath As String
Dim shinfo As SHFILEINFO

lpzxExeName = sFile
himl = SHGetFileInfo(lpzxExeName, 0&, shinfo, Len(shinfo), SHGFI_SYSICONINDEX Or SHGFI_SMALLICON)
If himl <> 0 Then
picImage.AutoRedraw = True
lRet = ImageList_Draw(himl, shinfo.iIcon, picImage.hDC, 0, 0, ILD_TRANSPARENT)
picImage.Refresh
ExtractIcon = True
End If
End Function


Change System Date

September 9, 2007

This code will change your system date to certain date you wanted to.

Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Private Declare Function SetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) As Long

Private Sub Form_Load()

Dim lpSystemTime As SYSTEMTIME

lpSystemTime.wYear = 2003
lpSystemTime.wMonth = 10
lpSystemTime.wDayOfWeek = -1
lpSystemTime.wDay = 10
lpSystemTime.wHour = 0
lpSystemTime.wMinute = 0
lpSystemTime.wSecond = 0
lpSystemTime.wMilliseconds = 0

'set the new time
SetSystemTime lpSystemTime
End Sub


Command Button with Gradient Filter (ActiveX Control)

September 9, 2007

'**************************************
' Windows API/Global Declarations for
' Command Button with gradient filter
' (ActiveX Control)
'**************************************
GetDeviceCaps, SetPixel, GetDIBits, CreateCompatibleDC, DeleteDC, SelectObject, DeleteObject, GetObject, SetDIBits, GetSysColor, CreatePen, GetClientRect, GetPixel, GetTickCount, LineTo, LockWindowUpdate, MoveToEx, Polygon

' Structures (types):
BITMAP, BITMAPINFOHEADER, RGBQUAD, BITMAPINFO, PointAPI,

' Constants:
BLACKNESS, DSTINVERT, MERGECOPY, MERGEPAINT, NOTSRCCOPY, NOTSRCERASE, PATCOPY, PATINVERT, PATPAINT, SRCCOPY, SRCPAINT,
SRCINVERT, SRCERASE, SRCAND, WHITENESS, COLOR_ACTIVEBORDER, COLOR_ACTIVECAPTION, COLOR_ADJ_MAX, COLOR_ADJ_MIN, COLOR_APPWORKSPACE, COLOR_BACKGROUND, COLOR_BTNFACE, COLOR_BTNHIGHLIGHT, COLOR_BTNSHADOW, COLOR_BTNTEXT, COLOR_CAPTIONTEXT, COLOR_GRAYTEXT, COLOR_HIGHLIGHT, COLOR_HIGHLIGHTTEXT, COLOR_INACTIVEBORDER, COLOR_INACTIVECAPTION, COLOR_INACTIVECAPTIONTEXT, COLOR_MENU, COLOR_MENUTEXT, COLOR_SCROLLBAR, COLOR_WINDOW, COLOR_WINDOWFRAME, COLOR_WINDOWTEXT, BITSPIXEL, PS_SOLID


How Can I Find Out If a File Exists On a Disk?

August 25, 2007

To find out if a file exists on a disk you can use the Visual Basic Dir() function. It has the following syntax:

Dir[(pathname[, attributes])]

In this context, pathname would be the name of the file that you are trying to find. The Attributes can be one or more of the following values (separated by the OR operator).

Attribute Description
vbNormal Default Attribute
vbReadOnly Use if file pathname is read-only
vbHidden Use if the file pathname is hidden
vbSystem Use if the file pathname is a system file
vbArchive Use if the file pathname is an Archive file
vbDirectory Use if pathname is a directory

Example:

If Dir(myfilename, vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Call Msgbox ("This file does not exist")
Else
Call msgbox ("This file does exist")
End If


Extract Icons From Files

August 25, 2007

Using this simple sub, you can get icons easily out of files, including DLLs, EXEs and ICOs. It uses the ExtractIconEX API to extract the icon from the file, and create a handle to the icon. It then uses the DrawIcon API to paint the icon on to the destination, and then destroys the handles to the icons to free up resources.

Declarations

Copy the following code into the declarations section of a module.

Private Type PicBmp
Size As Long
tType As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function ExtractIconEx Lib "shell32.dll" _
Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal _
nIconIndex As Long, phiconLarge As Long, phiconSmall As _
Long, ByVal nIcons As Long) As Long

Private Declare Function DestroyIcon Lib "user32" (ByVal _
hicon As Long) As Long

Function

Public Function GetIconFromFile(FileName As String, _
IconIndex As Long, UseLargeIcon As Boolean) As Picture

'Parameters:
'FileName - File (EXE or DLL) containing icons
'IconIndex - Index of icon to extract, starting with 0
'UseLargeIcon-True for a large icon, False for a small icon
'Returns: Picture object, containing icon

Dim hlargeicon As Long
Dim hsmallicon As Long
Dim selhandle As Long

' IPicture requires a reference to "Standard OLE Types."
Dim pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID

If ExtractIconEx(FileName, IconIndex, hlargeicon, _
hsmallicon, 1) > 0 Then

If UseLargeIcon Then
selhandle = hlargeicon
Else
selhandle = hsmallicon
End If

' Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Fill Pic with necessary parts.
With pic
.Size = Len(pic) ' Length of structure.
.tType = vbPicTypeIcon ' Type of Picture (bitmap).
.hBmp = selhandle ' Handle to bitmap.
End With

' Create Picture object.
Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)

' Return the new Picture object.
Set GetIconFromFile = IPic

DestroyIcon hsmallicon
DestroyIcon hlargeicon

End If
End Function

Example

Set Picture1.Picture = GetIconFromFile("c:\windows\moricons.dll", _
0, True)

This will paint the MS-DOS icon onto Picture1 in the normal sized icon(ie. 32×32). You can then use the PaintPicture function to rearrange and resize it.

Note: You must select Standard OLE Types in the Project|References box


Hiding Your Program in the Ctrl-Alt-Del list

August 24, 2007

The easiest method is probably by using the TaskVisible property of the App-object. If you set it to False, the task will be hiden from the CTRL-ALT-DEL-list. If you set it to True, your task will reappear again.

'Hide from list
App.TaskVisible = False
'Show on list
App.TaskVisible = True

Thanks to Fernando Robles for this tip.

There is another, more complicated way to accomplish the same effect.
You can register your program as a service. This is done by passing the process ID of your application to the RegisterService API.

Declarations

Copy the following code into the declarations section of a module:

Public Declare Function GetCurrentProcessId _
Lib "kernel32" () As Long
Public Declare Function GetCurrentProcess _
Lib "kernel32" () As Long
Public Declare Function RegisterServiceProcess _
Lib "kernel32" (ByVal dwProcessID As Long, _
ByVal dwType As Long) As Long

Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0

Procedures

To remove your program from the Ctrl+Alt+Delete list, call the MakeMeService procedure:

Public Sub MakeMeService()
Dim pid As Long
Dim reserv As Long

pid = GetCurrentProcessId()
regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
End Sub

To restore your application to the Ctrl+Alt+Delete list, call the UnMakeMeService procedure:

Public UnMakeMeService()
Dim pid As Long
Dim reserv As Long

pid = GetCurrentProcessId()
regserv = RegisterServiceProcess(pid, _
RSP_UNREGISTER_SERVICE)
'End Code

Don’t forget to unregister your application as a service before it closes to free up system resources by calling UnMakeMeService.