Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: yokesee en Diciembre 28, 2015, 04:28:37 pm
-
hola a todos.
estoy usando este modulo cPopupMenu.cls para crear popup menu seguro que mas de uno lo conoce.
no encuentro donde lo descargue y no se si podre poner aquí el código de las clases para quien no lo conozca.
tengo el siguiente problema me gustaria prescindir del control ImageList y usar otros sistemas que no dependan de controles como por ejemplo usar el tipo StdPicture y cargar las imágenes en un array por mas que e mirado en la clase no se como asignar otra cosa que no sea un control ImageList a cP.ImageList.
otra cosa sabéis de algún control idéntico a ImageList ctl.
aquí os dejo una parte de mi código muy resumido
un saludo
Private cP As cPopupMenu
Sub cargarmenu()
Dim SubMenu(0 To 1000) As Integer
cP.ImageList = formprincipal.ImageList
SubMenu(0) = cP.AddItem("mostrar", , , ,1 , , , "@@mostrarventana@@")
cP.Store "nombremenupopup"
end sub
-
Hola si claro que es posible, se puede remplazar por un modulo clase que trabaje igual que el control ImageList pero sin tenerlo de dependencia, lo que si tenes que subir la clase que mencionas cPopupMenu o pega el código completo aca, haber como lo remplazamos o incorporamos en la misma clase.
Saludos.
-
hola Leandro muchas gracias por contestar
como ocupa mucho son muchas lineas e visto en esta pagina que esta parece igual que el que tengo cuando lo descargue creo que fue de vbacelerator pero parece que la web la dejaron de pagar una pena tenían muchos códigos.
si se pudiese implementar la forma en la clase mejor asi me evito de meterle mas controles al proyecto.
https://github.com/OSEHRA/OpenAHLTA/tree/master/Source/Tools/LibMnu (https://github.com/OSEHRA/OpenAHLTA/tree/master/Source/Tools/LibMnu)
yo uso este código para cargar las imágenes.
Private Type datosimagen
nombre As String
imagen As StdPicture
End Type
Public listaimagenes() As datosimagen
Public Sub cargariconosimagelist(ruta As String, extension As String)
Dim i As Integer
Dim Archivo As String
Erase listaimagenes
Archivo = Dir(ruta & extension)
i = 1
Do While Archivo <> ""
ReDim Preserve listaimagenes(1 To i)
On Error Resume Next
Set listaimagenes(i).imagen = LoadPicture(ruta & Archivo)
listaimagenes(i).nombre = Archivo
Archivo = Dir
i = i + 1
Loop
End Sub
Public Function imagenKey(nombre As String)
Dim i, numero As Integer
numero = 1
For i = LBound(listaimagenes) To UBound(listaimagenes)
On Error Resume Next
If listaimagenes(i).nombre = Key Then
numero = i
End If
Next
imagenKey = numero
End Function
encontre este control imagelist muy simple me vendria muy bien pero si se pudiese lo anterior mejor
https://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=62417&lngWId=1 (https://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=62417&lngWId=1)
un saludo y muchas gracias
-
Hola mira trate de rejuntar las clases que me pasaste pero siempre falta algo, asi que no lo pude poner en marcha, estuve echando un vistazo a la clase y al parecer no hace una dependencia directa a los common controls (osea el objeto imagelist) por lo que da la opción que sea un objeto o un handle de un imagelist así al parecer no hay que reformar el código solo hace falta crear un imagelist con Apis y pasar el hwnd, te paso este modulo clase que puede llegar a servir esta bien básico, si no sabes como hacerlo andar postea un zip con un ejemplo andando de lo que tenes.
modulo clase clsImgList.cls
'Name = cImgList
Option Explicit
Private Const MAX_PATH = 260
Public Enum IMAGE_LIST_COLOR
ILC_MASK = &H1
ILC_COLOR = &H0
ILC_COLORDDB = &HFE
ILC_COLOR4 = &H4
ILC_COLOR8 = &H8
ILC_COLOR16 = &H10
ILC_COLOR24 = &H18
ILC_COLOR32 = &H20
End Enum
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
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32" ()
Private Const SHGFI_ICON = &H100 ' get icon
Private Const SHGFI_SMALLICON = &H1 ' get small icon
Private Const SHGFI_SYSICONINDEX = &H4000 ' get system icon index
Private Type SHFILEINFO
hIcon As Long ' out: icon
iIcon As Long ' out: icon index
dwAttributes As Long ' out: SFGAO_ flags
szDisplayName As String * MAX_PATH ' out: display name (or path)
szTypeName As String * 80 ' out: type name
End Type
Private Declare Function ImageList_Create Lib "comctl32.dll" (ByVal cx As Long, ByVal cy As Long, ByVal Flags As Long, ByVal cInitial As Long, ByVal cGrow As Long) As Long
Private Declare Function ImageList_Destroy Lib "comctl32.dll" (ByVal himl As Long) As Long
Private Declare Function ImageList_ReplaceIcon Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal hIcon As Long) As Long
Private Declare Function ImageList_AddIcon Lib "comctl32.dll" (ByVal hImagelist As Long, ByVal hIcon As Long) As Long
Private Declare Function ImageList_GetImageCount Lib "comctl32.dll" (ByVal himl As Long) As Long
Private Declare Function ImageList_SetImageCount Lib "comctl32.dll" (ByVal himl As Long, ByVal uNewCount As Long) As Long
Private Declare Function ImageList_SetBkColor Lib "comctl32" (ByVal hImagelist As Long, ByVal clrBk As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Function ImageList_Add Lib "comctl32" (ByVal hImagelist As Long, ByVal hBitmap As Long, ByVal hBitmapMask As Long) As Long
Private Declare Function ImageList_AddMasked Lib "comctl32" (ByVal hImagelist As Long, ByVal hbmImage As Long, ByVal crMask As Long) As Long
Private Declare Function ImageList_GetIcon Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal Flags As Long) As Long
Private Const CLR_NONE As Long = &HFFFFFFFF
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LR_LOADMAP3DCOLORS As Long = &H1000
Private Const LR_SHARED As Long = &H8000&
Private Const IMAGE_ICON As Long = 1
Private Const ILD_TRANSPARENT As Long = 1&
Private hwIL As Long
Private m_Width As Long
Private m_Height As Long
Dim NullIcn As Long
Public Property Let BackColor(ByVal NewColor As OLE_COLOR)
Dim lColor As Long
OleTranslateColor NewColor, 0, lColor
ImageList_SetBkColor hwIL, lColor
End Property
Property Get NullIcon(ByVal h As Long)
NullIcn = h
End Property
Property Get hwnd() As Long
hwnd = hwIL
End Property
Property Get ImageCount() As Long
ImageCount = ImageList_GetImageCount(hwIL)
End Property
Public Function Init(Optional ByVal Width As Long = 16, Optional ByVal Height As Long = 16, Optional ByVal Colors As IMAGE_LIST_COLOR = ILC_COLOR32) As Long
m_Width = Width: m_Height = Height
hwIL = ImageList_Create(Width, Height, Colors Or ILC_MASK, 1, 1)
Init = hwIL
End Function
Sub Clear()
ImageList_SetImageCount hwIL, 0
'Call Class_Terminate
'hwIL = 0
End Sub
Private Sub Class_Initialize()
InitCommonControls
'Call CreateMe
End Sub
Private Sub Class_Terminate()
If hwIL Then Call ImageList_Destroy(hwIL)
End Sub
Public Function GetIcon(ByVal Index As Long) As Long
If hwIL Then
GetIcon = ImageList_GetIcon(hwIL, Index, ILD_TRANSPARENT)
End If
End Function
Sub AddIcon(ByVal hIcon As Long)
'If hwIL = 0 Then CreateMe
'Call ImageList_ReplaceIcon(hwIL, -1, hIcon)
ImageList_AddIcon hwIL, hIcon
End Sub
Function AddIconFromFile2(ByVal Path As String) As Long
'If hwIL = 0 Then CreateMe
Dim hIcon As Long
Dim shInfo As SHFILEINFO
If m_Width = 16 And m_Height = 16 Then
SHGetFileInfo Path, 0, shInfo, Len(shInfo), SHGFI_ICON Or SHGFI_SMALLICON
Else
SHGetFileInfo Path, 0, shInfo, Len(shInfo), SHGFI_ICON Or SHGFI_ICON
End If
If shInfo.hIcon = 0 Then shInfo.hIcon = NullIcn
hIcon = shInfo.hIcon
AddIcon hIcon
DestroyIcon hIcon
AddIconFromFile2 = ImageList_GetImageCount(hwIL) - 1
End Function
Public Function AddIconFromFile(ByVal Path As String) As Boolean
Dim hIcon As Long
hIcon = LoadImage(App.hInstance, Path, IMAGE_ICON, m_Width, m_Height, LR_LOADFROMFILE)
If hIcon Then
AddIconFromFile = ImageList_AddIcon(hwIL, hIcon)
DestroyIcon hIcon
End If
End Function
Public Function AddBitmap(ByVal hBitmap As Long, Optional ByVal MaskColor As Long = CLR_NONE) As Boolean
If (hwIL) Then
If (MaskColor <> CLR_NONE) Then
AddBitmap = ImageList_AddMasked(hwIL, hBitmap, MaskColor)
Else
AddBitmap = ImageList_Add(hwIL, hBitmap, 0)
End If
End If
End Function
bien ahora como para utilizarlo haces algo asi
Option Explicit
Dim cImgList As clsImgList
Private Sub Form_Load()
Set cImgList = New clsImgList
'Iconos de 16x16
Call cImgList.Init(16, 16)
'le cargas una imagen al imagelist, puse como mascara el color vbMagenta pero esto es opcional
Call cImgList.AddBitmap(LoadPicture(sPath), vbMagenta)
'le pasas el hwnd del imagelist
cPopupMenu.ImageList = cImgList.hwnd
End Sub
-
hola Leandro muchas gracias funciona bien pero tiene un problema
solo funciona con AddBitmap y formatos jpg bmp no probé,
con los formatos icono no funciona probé las otras AddIconFromFile2,AddIconFromFile,AddBitmap
esto también lo probé en un proyecto aparte.
por ejemplo este cuando lo añado me da que tiene una imagen y cuando lo pongo en el menú si se ve perfectamente
Call cImgList.AddBitmap(LoadPicture(App.Path & "\ico\" & "prueba.jpg"), vbMagenta)
MsgBox cImgList.ImageCount
pero yo la mayoría que tengo son iconos y hago lo mismo cambiando la función y quitando lo del mask y me pone cero siempre no se añaden
Call cImgList.AddIconFromFile2(LoadPicture(App.Path & "\ico\" & "prueba.jpg"))
MsgBox cImgList.ImageCount
funciona perfectamente en el menú la opción primera así no creo que haga falta poner todo el código con solucionar lo de los iconos sobraría.
un saludo y muchisimas gracias
-
esta todo solucionado y funcionando perfectamente
nada mas escribir lo anterior me di cuenta de mi error y es que solo había que pasar la ruta y no el LoadPicture.
un saludo y muchísimas gracias