Poner una imagen en un comentario de una celda

[Antoni]

Hola a todos.

Ahí va una macro para poner una imagen dentro de un comentario de una celda.

El tamaño de la imagen, se adapta al tamaño del comentario.

Sub ImagenComentario()

With ActiveCell

  .AddComment

  .Comment.Text Text:=""

  .Comment.Visible = False

  .Comment.Shape.Height = 50 'Alto

  .Comment.Shape.Width = 75  'Ancho

  .Comment.Shape.Select

End With

Selection.ShapeRange.Fill.UserPicture "C:\MiImagen.jpg"

End Sub

[/CODE]

Salu2 y hasta mañana. ¡¡ Suerte "Catachos" !!

[ST_]

Re: Como poner una imagen en un comentario de una celda

hola: la version "ST" quedaria con algunas lineas de codigo menos:

Sub ImagenComentario_ST()
With ActiveCell
  .AddComment
  .Comment.Shape.Height = 75 'Alto
  .Comment.Shape.Width = 65  'Ancho
  .Comment.Shape.Fill.UserPicture "C:\anette michelle.jpg"
End With
End Sub

[Antoni]

Re: Como poner una imagen en un comentario de una celda

Gracias por la corrección ST, tomo buena nota para sucesivas aplicaciones.

Salu2. Antoni.

[ST_]

Re: Como poner una imagen en un comentario de una celda

...... tomo buena nota para sucesivas aplicaciones........

un placer contribuir con algo

aquí una versión con igual numero de lineas en 2 bloques with..end with

Sub ImagenComentario_ST_II()
    With ActiveCell
        .AddComment
            With .Comment.Shape
                .Height = 75: .Width = 65: .Fill.UserPicture "C:\anette michelle.jpg"
            End With
    End With
End Sub

[FILATUC]

Re: Como poner una imagen en un comentario de una celda

como haria para hacerlo andar????

[ST_]

Re: Como poner una imagen en un comentario de una celda

1.-si te refieres a mover el comentario segun te desplaces por las celdas con las flechas de navegacion o el raton,puedes probar adicionando el evento "SelectionChange" de la hoja donde deseas mostrarla,tal que:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next ' rutina por si no exitiera comentarios y evitar el error
        Comments(1).Delete 'elimina el cometario existente
    ImagenComentario_ST_II 'Macro ya sugerida
End Sub

por suspuesto que la macro que se llama desde el evento,debera estar en un modulo estandar,digamos "modulo1" para nuestro ejemplo

Sub ImagenComentario_ST_II()
    With ActiveCell
        .AddComment
            With .Comment.Shape
                .Visible = True: .Height = 75: .Width = 65: .Fill.UserPicture "C:\anette michelle.jpg"
            End With
    End With
End Sub

aquí se podrá apreciar que se manipula la propiedad "visible" del comentario para propiciar que 'luzca' el efecto visual

[Fleming]

Re: Como poner una imagen en un comentario de una celda

Sin macros puede hacerse como se indica en el archivo anexo.

Saludos

IMAGEN EN CELDA.zip

[Antoni]

Re: Como poner una imagen en un comentario de una celda

Hola Fleming:

Pues no me había fijado nunca en la pestañita Imagen.

Salu2. Antoni.

[Fleming]

Hola Antoni:

Pues celebro tu feliz encuentro con la pestañita.

Un saludo

[verzulsan]

Buenas Antoni, ST & Fleming,

Antoni, hoy me vi en la necesidad de incluir una foto en un comentario y me acordé de este post. Muy util para uno de mis proyectos en los que las celdas las uso como botones con doble click en donde no hay espacio para texto, y con imagen de comentario se hace mas sencillo hacerte un mapa mental mientras trabajas.

Ahí va una mejora usando la version mejorada de ST:

Sub InsertarFoto()
    Dim objPicture As New GetPictureSizeClass
    Dim MiFoto As String: MiFoto = "D:\Documentos S\Mis imágenes\94258640_IHIJPTMOTCXLQWS.jpg"
    objPicture.ReadImageInfo (MiFoto)
    With ActiveCell
        If .Comment Is Nothing Then .AddComment
        With .Comment.Shape
            .Height = objPicture.Height
            .Width = objPicture.Width
            .Visible = msoCTrue
            .Fill.UserPicture MiFoto
        End With
    End With
End Sub[/PHP]

Mejoras:

1 - Carga la imagen a un objeto de tipo analizador de imagenes el cual nos da la altura y anchura de la foto y que este se ajuste al tamaño real en lugar de ser siempre fijo.

2 - Condicional en la creacion del shape por si ya existiera que no de error

3 - Mostrar comentario para que sea visible en el momento de asignacion, esté donde esté el raton.

Nada mas, les dejo en el adjunto la clase necesaria para que el objeto funcione.

Saludos.

[PHP]
'Codigo extraido de:
'http://www.freevbcode.com/ShowCode.asp?ID=112


Option Explicit

' Only the first X bytes of the file are read into a byte array.
' BUFFERSIZE is X. A larger number will use more memory and
' be slower. A smaller number may not be able to decode all
' JPEG files. Feel free to play with this number.
Private Const BUFFERSIZE As Long = 65535

' image type enum
Public Enum eImageType
itUNKNOWN = 0
itGIF = 1
itJPEG = 2
itPNG = 3
itBMP = 4
End Enum

' private member variables
Private m_Width As Long
Private m_Height As Long
Private m_Depth As Byte
Private m_ImageType As eImageType

'
' CImageInfo
'
' Author: David Crowell
' davidc@qtm.net
' http://www.qtm.net/~davidc
'
' Released to the public domain
' use however you wish
'
' CImageInfo will get the image type ,dimensions, and
' color depth from JPG, PNG, BMP, and GIF files.
'
' version date: June 16, 1999
'
' http://www.wotsit.org is a good source of
' file format information. This code would not have been
' possible without the files I found there.
'

' read-only properties

Public Property Get Width() As Long
Width = m_Width
End Property

Public Property Get Height() As Long
Height = m_Height
End Property

Public Property Get Depth() As Byte
Depth = m_Depth
End Property

Public Property Get ImageType() As eImageType
ImageType = m_ImageType
End Property

Public Sub ReadImageInfo(sFileName As String)
' This is the sub to call to retrieve information on a file.

' Byte array buffer to store part of the file
Dim bBuf(BUFFERSIZE) As Byte
' Open file number
Dim iFN As Integer

' Set all properties to default values
m_Width = 0
m_Height = 0
m_Depth = 0
m_ImageType = itUNKNOWN

' here we will load the first part of a file into a byte
'array the amount of the file stored here depends on
'the BUFFERSIZE constant
iFN = FreeFile
Open sFileName For Binary As iFN
Get #iFN, 1, bBuf()
Close iFN

If bBuf(0) = 137 And bBuf(1) = 80 And bBuf(2) = 78 Then
' this is a PNG file

m_ImageType = itPNG

' get bit depth
Select Case bBuf(25)
Case 0
' greyscale
m_Depth = bBuf(24)

Case 2
' RGB encoded
m_Depth = bBuf(24) * 3

Case 3
' Palette based, 8 bpp
m_Depth = 8

Case 4
' greyscale with alpha
m_Depth = bBuf(24) * 2

Case 6
' RGB encoded with alpha
m_Depth = bBuf(24) * 4

Case Else
' This value is outside of it's normal range, so
'we'll assume
' that this is not a valid file
m_ImageType = itUNKNOWN

End Select

If m_ImageType Then
' if the image is valid then

' get the width
m_Width = Mult(bBuf(19), bBuf(18))

' get the height
m_Height = Mult(bBuf(23), bBuf(22))
End If

End If

If bBuf(0) = 71 And bBuf(1) = 73 And bBuf(2) = 70 Then
' this is a GIF file

m_ImageType = itGIF

' get the width
m_Width = Mult(bBuf(6), bBuf(7))

' get the height
m_Height = Mult(bBuf(8), bBuf(9))

' get bit depth
m_Depth = (bBuf(10) And 7) + 1
End If

If bBuf(0) = 66 And bBuf(1) = 77 Then
' this is a BMP file

m_ImageType = itBMP

' get the width
m_Width = Mult(bBuf(18), bBuf(19))

' get the height
m_Height = Mult(bBuf(22), bBuf(23))

' get bit depth
m_Depth = bBuf(28)
End If

If m_ImageType = itUNKNOWN Then
' if the file is not one of the above type then
' check to see if it is a JPEG file
Dim lPos As Long

Do
' loop through looking for the byte sequence FF,D8,FF
' which marks the begining of a JPEG file
' lPos will be left at the postion of the start
If (bBuf(lPos) = &HFF And bBuf(lPos + 1) = &HD8 _
And bBuf(lPos + 2) = &HFF) _
Or (lPos >= BUFFERSIZE - 10) Then Exit Do

' move our pointer up
lPos = lPos + 1

' and continue
Loop

lPos = lPos + 2
If lPos >= BUFFERSIZE - 10 Then Exit Sub


Do
' loop through the markers until we find the one
'starting with FF,C0 which is the block containing the
'image information

Do
' loop until we find the beginning of the next marker
If bBuf(lPos) = &HFF And bBuf(lPos + 1) _
<> &HFF Then Exit Do
lPos = lPos + 1
If lPos >= BUFFERSIZE - 10 Then Exit Sub
Loop

' move pointer up
lPos = lPos + 1

Select Case bBuf(lPos)
Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, _
&HCD To &HCF
' we found the right block
Exit Do
End Select

' otherwise keep looking
lPos = lPos + Mult(bBuf(lPos + 2), bBuf(lPos + 1))

' check for end of buffer
If lPos >= BUFFERSIZE - 10 Then Exit Sub

Loop

' If we've gotten this far it is a JPEG and we are ready
' to grab the information.

m_ImageType = itJPEG

' get the height
m_Height = Mult(bBuf(lPos + 5), bBuf(lPos + 4))

' get the width
m_Width = Mult(bBuf(lPos + 7), bBuf(lPos + 6))

' get the color depth
m_Depth = bBuf(lPos + 8) * 8

End If

End Sub
Private Function Mult(lsb As Byte, msb As Byte) As Long
Mult = lsb + (msb * CLng(256))
End Function



[/PHP]

GetPictureSizeClass.rar