Icono de aplicación

Existe una solucion de Iva F Moala que entre otras cosas, crea un icono en
el formulario y en la barra de tareas. Yo extraje la parte del codigo para
crear el icono y miniminzar el formulario.

1. Creas un control Image1 en el formulario con la Propiedad Visible =False
al que le asignas un icono.

2. En un modulo independiente insteras este codigo:

Option Explicit
'//=='// Routine to do the SubClassing and Notification
'// by Ivan F Moala
'// 28th July 2004
'//==
'// The NotifyIconData structure is a simple type that is used to package
all of
'// the necessary information up in order to send that information to the
Shell32.dll
'// via the Shell_NotifyIconA Function
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Public Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long

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 SetWindowLong _
Lib "user32" _
Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) _
As Long

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 Shell_NotifyIcon _
Lib "shell32.dll" _
Alias "Shell_NotifyIconA" ( _
ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) _
As Long

Public Declare Function ShowWindow _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nCmdShow As Long) _
As Long

Declare Function ShellAbout _
Lib "shell32.dll" _
Alias "ShellAboutA" ( _
ByVal hwnd As Long, _
ByVal szApp As String, _
ByVal szOtherStuff As String, _
ByVal hIcon As Long) _
As Long

Public Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long

'// Left-click constants - NOT all used.
Public Const WM_LBUTTONDBLCLK = &H203 'Left Double-click
Public Const WM_LBUTTONDOWN = &H201 'Left Button down
Public Const WM_LBUTTONUP = &H202 'Left Button up

'// Right-click constants(Not used yet).
Public Const WM_RBUTTONDBLCLK = &H206 'Right Double-click
Public Const WM_RBUTTONDOWN = &H204 'Right Button down
Public Const WM_RBUTTONUP = &H205 'Right Button up

'// The WM_USER constant is used by applications to help define
'// private messages for use by private window classes,
'// usually of the form WM_USER+X, where X is an integer value.0x8000
Public Const WM_USER = &H400
Public Const WM_CALLBACKMSG = WM_USER + 15

'// Windows process
Public Const GWL_WNDPROC = (-4)
'
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
'// Data.Flags = IconFlag Or TipFlag Or MessageFlag
Public Const NIF_DOALL = NIF_MESSAGE Or NIF_ICON Or NIF_TIP

Public Const SW_HIDE = 0
Public Const SW_NORMAL = 1

'// Icon constants
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

'// Keys!
Public lngWndID As Long '// Our identifier.
Public lngPrevWndProc As Long '// Original WNDPROC address.

Public Tic As NOTIFYICONDATA
Public g_Icon As Long
Public g_blnFromCreated As Boolean
Public g_hwnd As Long
Public g_blnMin As Boolean
Public g_objForm As Object
''
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_DISABLED = &H2&
Const MF_GRAYED = &H1&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&

Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&

Dim lRet As Long

Public Function WndProcHook(ByVal hwnd As Long, ByVal message As Long, ByVal
wParam As Long, _
ByVal lParam As Long) As Long
'// SubClass routine
If lngWndID = wParam Then
Select Case lParam
Case WM_LBUTTONDBLCLK
'// The WM_LBUTTONDBLCLK message is posted when the user
double-clicks the
'// left mouse button while the cursor is in the client area of a
window.
'// If the mouse is not captured, the message is posted to the
window beneath
'// the cursor. Otherwise, the message is posted to the window that
has captured the mouse.
'// A window receives this message through its WindowProc function.
'// If the user double clicks the SystemTray icon then release the
hook on the window.
'// I.e unSubClass it by returning it's original WNDPROC address
'// that we captured in the original call to SetWindowLong (Windows
Form Minimized)
SetWindowLong g_hwnd, GWL_WNDPROC, lngPrevWndProc

'// Delete the icon from the SystemTray as we DON'T NEED IT NOW.
Shell_NotifyIcon NIM_DELETE, Tic
DoEvents
'// Show our Userform
ShowWindow g_hwnd, SW_NORMAL
Case WM_RBUTTONDOWN
'// Show a PopupMenu in the SystemTray.
GetCursorPos PT
lngMNUItem = TrackPopupMenuEx(lMnu, TPM_LEFTALIGN Or
TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
PT.X, PT.y, g_hwnd, ByVal 0&)
'// Check RightClick
Select Case lngMNUItem
Case 1: '
Case 2: '
Case 3: '
Case 5: '
Case 7: '
Case 8: '
Case 10: '
'//
ShellExecute 0, "Open",
"http://www.xcelfiles.com/Index.html", 0&, 0&, 1
Case 12:
'// MUST UnSubclass 1st
SetWindowLong g_hwnd, GWL_WNDPROC, lngPrevWndProc
'// Delete the icon from the SystemTray as we DON'T NEED
IT NOW.
Shell_NotifyIcon NIM_DELETE, Tic
DoEvents
'// Show our Userform
ShowWindow g_hwnd, SW_NORMAL
Case 14: '
Case 15
Dim X As Long
X = ShellAbout(0, ThisWorkbook.Name, Chr(10) + Chr(13) +
Chr(169) + "[Left]" & _
" Ivan F Moala, 28th July, 2004" + Chr(10) +
Chr(13), 0)
End Select

End Select
End If
'// Make sure we Call the original WNDPROC as this function processes
messages
'// sent to the window, and we need to handle all other messages.
WndProcHook = CallWindowProc(lngPrevWndProc, hwnd, message, wParam, lParam)

End Function

Sub CreateIcon()
'// Set Tray Icon info.
With Tic
.cbSize = Len(Tic)
.hwnd = g_hwnd
.uID = lngWndID
.uFlags = NIF_DOALL
.hIcon = g_Icon
.szTip = UserForm1.Caption & " - rightclick for more options" &
Chr(0)
.uCallbackMessage = WM_CALLBACKMSG
End With
lRet = Shell_NotifyIcon(NIM_ADD, Tic)
End Sub
'
Sub DeleteIcon()
lRet = Shell_NotifyIcon(NIM_DELETE, Tic)
End Sub

Function CreateFrmIcon(frm As Object, frmhdl As Long, hIcon As Long)
'// Creates the Icon for the Userform
Call SendMessage(frmhdl, WM_SETICON, ICON_SMALL, ByVal hIcon)
Call SendMessage(frmhdl, WM_SETICON, ICON_BIG, ByVal hIcon)

End Function

3. Al comienzo del codigo del formulario colocas las siguientes
declaraciones:

Private Const WS_EX_CONTROLPARENT As Long = &H10000
Private Const WS_EX_APPWINDOW = &H40000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_SIZEBOX = WS_THICKFRAME

Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)

Private Declare Function ShowWindow _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nCmdShow As Long) _
As Long

Private Declare Function GetWindowLong _
Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) _
As Long

Dim hIcon As Long


4. Insertas estas secciones de codigo en los siguientes eventos del
formulario:

Private Sub UserForm_Initialize()
'//
g_blnFromCreated = True
'// get the userform Window handle
g_hwnd = FindWindow(vbNullString, UserForm1.Caption)
If hIcon = 0 Then
hIcon = Me.Image1.Picture.Handle
g_Icon = hIcon
End If
CreateFrmIcon Me, g_hwnd, hIcon
End sub


Private Sub UserForm_Activate()
Dim wLong As Long

If Not g_objForm Is Nothing Then Exit Sub
ShowWindow g_hwnd, SW_HIDE
'// make sure form shows up in TaskBar
wLong = GetWindowLong(g_hwnd, GWL_EXSTYLE)
wLong = wLong Or WS_EX_CONTROLPARENT Or WS_EX_APPWINDOW
SetWindowLong g_hwnd, GWL_EXSTYLE, wLong
'// add Minimize button Only
wLong = GetWindowLong(g_hwnd, GWL_STYLE)
wLong = wLong Or WS_MINIMIZEBOX
SetWindowLong g_hwnd, GWL_STYLE, wLong
ShowWindow g_hwnd, SW_NORMAL
Set g_objForm = Me
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'// UnsubClass !!
SetWindowLong g_hwnd, GWL_WNDPROC, lngPrevWndProc
DeleteIcon
'// We're closing down now so set global reference to false
g_blnFromCreated = False
'// destroy our Menu
'DestroyMenu lMnu
'//
Application.Visible = True
Set g_objForm = Nothing
End Sub


Nota: debes usar siempre el procedimiento Unload para el formulario no el
evento Hide para que funcione adecuadamente.



Luis Medina
Menufazt - Utilidades y juegos en Excel
http://www11.brinkster.com/LUISM0/


"Mccd" escribió en el mensaje
news:

hola grupo:
a ver si me podeis echar una mano: ¿Cómo podría incluir un icono en una
aplicación que he podido desarrollar con excel? Esto mismo es muy fácil
con access pero en excel...la verdad, no encuentro cómo hacerlo. !ni
siquiera en la ayuda¡
Gracia anticipadas.

Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (http://www.grisoft.com).
Version: 6.0.783 / Virus Database: 529 - Release Date: 10/25/2004

Gracias por tu respuesta.
Saludos.


"L. A. M." <luism0(arroba)yahoo.es> escribió en el mensaje
news:

Existe una solucion de Iva F Moala que entre otras cosas, crea un icono en
el formulario y en la barra de tareas. Yo extraje la parte del codigo para
crear el icono y miniminzar el formulario.

1. Creas un control Image1 en el formulario con la Propiedad Visible
=False al que le asignas un icono.

2. En un modulo independiente insteras este codigo:

Option Explicit
'//==> '// Routine to do the SubClassing and Notification
'// by Ivan F Moala
'// 28th July 2004
'//==>
'// The NotifyIconData structure is a simple type that is used to package
all of
'// the necessary information up in order to send that information to the
Shell32.dll
'// via the Shell_NotifyIconA Function
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Public Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long

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 SetWindowLong _
Lib "user32" _
Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) _
As Long

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 Shell_NotifyIcon _
Lib "shell32.dll" _
Alias "Shell_NotifyIconA" ( _
ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) _
As Long

Public Declare Function ShowWindow _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nCmdShow As Long) _
As Long

Declare Function ShellAbout _
Lib "shell32.dll" _
Alias "ShellAboutA" ( _
ByVal hwnd As Long, _
ByVal szApp As String, _
ByVal szOtherStuff As String, _
ByVal hIcon As Long) _
As Long

Public Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long

'// Left-click constants - NOT all used.
Public Const WM_LBUTTONDBLCLK = &H203 'Left Double-click
Public Const WM_LBUTTONDOWN = &H201 'Left Button down
Public Const WM_LBUTTONUP = &H202 'Left Button up

'// Right-click constants(Not used yet).
Public Const WM_RBUTTONDBLCLK = &H206 'Right Double-click
Public Const WM_RBUTTONDOWN = &H204 'Right Button down
Public Const WM_RBUTTONUP = &H205 'Right Button up

'// The WM_USER constant is used by applications to help define
'// private messages for use by private window classes,
'// usually of the form WM_USER+X, where X is an integer value.0x8000
Public Const WM_USER = &H400
Public Const WM_CALLBACKMSG = WM_USER + 15

'// Windows process
Public Const GWL_WNDPROC = (-4)
'
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
'// Data.Flags = IconFlag Or TipFlag Or MessageFlag
Public Const NIF_DOALL = NIF_MESSAGE Or NIF_ICON Or NIF_TIP

Public Const SW_HIDE = 0
Public Const SW_NORMAL = 1

'// Icon constants
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

'// Keys!
Public lngWndID As Long '// Our identifier.
Public lngPrevWndProc As Long '// Original WNDPROC address.

Public Tic As NOTIFYICONDATA
Public g_Icon As Long
Public g_blnFromCreated As Boolean
Public g_hwnd As Long
Public g_blnMin As Boolean
Public g_objForm As Object
''
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_DISABLED = &H2&
Const MF_GRAYED = &H1&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&

Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&

Dim lRet As Long

Public Function WndProcHook(ByVal hwnd As Long, ByVal message As Long,
ByVal wParam As Long, _
ByVal lParam As Long) As Long
'// SubClass routine
If lngWndID = wParam Then
Select Case lParam
Case WM_LBUTTONDBLCLK
'// The WM_LBUTTONDBLCLK message is posted when the user
double-clicks the
'// left mouse button while the cursor is in the client area of a
window.
'// If the mouse is not captured, the message is posted to the
window beneath
'// the cursor. Otherwise, the message is posted to the window that
has captured the mouse.
'// A window receives this message through its WindowProc function.
'// If the user double clicks the SystemTray icon then release the
hook on the window.
'// I.e unSubClass it by returning it's original WNDPROC address
'// that we captured in the original call to SetWindowLong (Windows
Form Minimized)
SetWindowLong g_hwnd, GWL_WNDPROC, lngPrevWndProc

'// Delete the icon from the SystemTray as we DON'T NEED IT
NOW.
Shell_NotifyIcon NIM_DELETE, Tic
DoEvents
'// Show our Userform
ShowWindow g_hwnd, SW_NORMAL
Case WM_RBUTTONDOWN
'// Show a PopupMenu in the SystemTray.
GetCursorPos PT
lngMNUItem = TrackPopupMenuEx(lMnu, TPM_LEFTALIGN Or
TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
PT.X, PT.y, g_hwnd, ByVal 0&)
'// Check RightClick
Select Case lngMNUItem
Case 1: '
Case 2: '
Case 3: '
Case 5: '
Case 7: '
Case 8: '
Case 10: '
'//
ShellExecute 0, "Open",
"http://www.xcelfiles.com/Index.html", 0&, 0&, 1
Case 12:
'// MUST UnSubclass 1st
SetWindowLong g_hwnd, GWL_WNDPROC, lngPrevWndProc
'// Delete the icon from the SystemTray as we DON'T
NEED IT NOW.
Shell_NotifyIcon NIM_DELETE, Tic
DoEvents
'// Show our Userform
ShowWindow g_hwnd, SW_NORMAL
Case 14: '
Case 15
Dim X As Long
X = ShellAbout(0, ThisWorkbook.Name, Chr(10) + Chr(13)
+ Chr(169) + "[Left]" & _
" Ivan F Moala, 28th July, 2004" + Chr(10) +
Chr(13), 0)
End Select

End Select
End If
'// Make sure we Call the original WNDPROC as this function processes
messages
'// sent to the window, and we need to handle all other messages.
WndProcHook = CallWindowProc(lngPrevWndProc, hwnd, message, wParam,
lParam)

End Function

Sub CreateIcon()
'// Set Tray Icon info.
With Tic
.cbSize = Len(Tic)
.hwnd = g_hwnd
.uID = lngWndID
.uFlags = NIF_DOALL
.hIcon = g_Icon
.szTip = UserForm1.Caption & " - rightclick for more options" &
Chr(0)
.uCallbackMessage = WM_CALLBACKMSG
End With
lRet = Shell_NotifyIcon(NIM_ADD, Tic)
End Sub
'
Sub DeleteIcon()
lRet = Shell_NotifyIcon(NIM_DELETE, Tic)
End Sub

Function CreateFrmIcon(frm As Object, frmhdl As Long, hIcon As Long)
'// Creates the Icon for the Userform
Call SendMessage(frmhdl, WM_SETICON, ICON_SMALL, ByVal hIcon)
Call SendMessage(frmhdl, WM_SETICON, ICON_BIG, ByVal hIcon)

End Function

3. Al comienzo del codigo del formulario colocas las siguientes
declaraciones:

Private Const WS_EX_CONTROLPARENT As Long = &H10000
Private Const WS_EX_APPWINDOW = &H40000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_SIZEBOX = WS_THICKFRAME

Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)

Private Declare Function ShowWindow _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nCmdShow As Long) _
As Long

Private Declare Function GetWindowLong _
Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) _
As Long

Dim hIcon As Long


4. Insertas estas secciones de codigo en los siguientes eventos del
formulario:

Private Sub UserForm_Initialize()
'//
g_blnFromCreated = True
'// get the userform Window handle
g_hwnd = FindWindow(vbNullString, UserForm1.Caption)
If hIcon = 0 Then
hIcon = Me.Image1.Picture.Handle
g_Icon = hIcon
End If
CreateFrmIcon Me, g_hwnd, hIcon
End sub


Private Sub UserForm_Activate()
Dim wLong As Long

If Not g_objForm Is Nothing Then Exit Sub
ShowWindow g_hwnd, SW_HIDE
'// make sure form shows up in TaskBar
wLong = GetWindowLong(g_hwnd, GWL_EXSTYLE)
wLong = wLong Or WS_EX_CONTROLPARENT Or WS_EX_APPWINDOW
SetWindowLong g_hwnd, GWL_EXSTYLE, wLong
'// add Minimize button Only
wLong = GetWindowLong(g_hwnd, GWL_STYLE)
wLong = wLong Or WS_MINIMIZEBOX
SetWindowLong g_hwnd, GWL_STYLE, wLong
ShowWindow g_hwnd, SW_NORMAL
Set g_objForm = Me
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'// UnsubClass !!
SetWindowLong g_hwnd, GWL_WNDPROC, lngPrevWndProc
DeleteIcon
'// We're closing down now so set global reference to false
g_blnFromCreated = False
'// destroy our Menu
'DestroyMenu lMnu
'//
Application.Visible = True
Set g_objForm = Nothing
End Sub


Nota: debes usar siempre el procedimiento Unload para el formulario no el
evento Hide para que funcione adecuadamente.



Luis Medina
Menufazt - Utilidades y juegos en Excel
http://www11.brinkster.com/LUISM0/


"Mccd" escribió en el mensaje
news:

hola grupo:
a ver si me podeis echar una mano: ¿Cómo podría incluir un icono en una
aplicación que he podido desarrollar con excel? Esto mismo es muy fácil
con access pero en excel...la verdad, no encuentro cómo hacerlo. !ni
siquiera en la ayuda¡
Gracia anticipadas.

Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (http://www.grisoft.com).
Version: 6.0.783 / Virus Database: 529 - Release Date: 10/25/2004