Macro imagenes

[maylex]

Hola amigo, tengo una macro que me inserta una cantidad de imágenes en mi archivo excel, pero quiero hacer dos pequeñas modificaciones:

1) que la cantidad de fotos (CantFotos) que inserto este vinculado en una celda de mi excel, y no que la tenga que modificar desde la macro

2)que me comprima cada imagen que inserto a 150pp

esta es la macro:

Sub InsertarImagenes()

Dim PosX, PosY, X, J As Integer

Dim CantFotos As Integer

Dim Ruta As String

'le asigno valores a las variables, mismas que dependerán

'de cada proyecto:

'ruta de acceso a las imágenes

Ruta = "\"

'cantidad de imágenes a cargar:

CantFotos = 42

'margen izquierdo y superior que separará a cada imagen:

PosX = 10

PosY = 6310

J = 1

'si existe alguna autoforma la elimino:

If ActiveSheet.DrawingObjects.Count > 0 Then

ActiveSheet.DrawingObjects.Select

Selection.Delete

End If

'y cargo las 40 que se encuentran en el directorio:

For X = 1 To CantFotos

'este If es para asignar nuevos valores a las

'variables y hacer que aparezcan 5 imágenes x fila:

If J = 4 Then

PosX = 10

PosY = PosY + 245

J = 1

End If

'inserto una autoforma y como margen izq. y superior le paso las

ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosX, PosY, 150, 200). _

Select

'aquí le indico que cargue la imagen, usando la variable Ruta y

'concatenando el número (x) con la extensión (.jpg)

On Error Resume Next

Selection.ShapeRange.Fill.UserPicture _

Ruta & X & ".jpg"

If Err.Number <> 0 Then

MsgBox "No se encontró una de las imágenes, por favor " _

& " revise el directorio", vbCritical, "Error"

Err.Clear

Exit Sub

End If

'incremento el margen izquierdo y a J

PosX = PosX + 160

J = J + 1

Next X

Range("c250").Select

End Sub

saludos amigos. y muy agradecido desde ya por su ayuda

[Antoni]

.

Respuesta a la pregunta 1.

CantFotos = Range("A1")

.

[maylex]

Gracias Macro Antonio!!

y sobre la segunda consulta de comprimir imágenes sabes algo ?

[maylex]

MacroAntonio, soy yo denuevo, consulta corta como puedo hacer para cuando me borra las fotos en vez de que me borre todas las imagenes de la hoja me borre en las columnas de la A a la W.

En esta parte:

If ActiveSheet.DrawingObjects.Count > 0 Then

ActiveSheet.DrawingObjects.Select

Selection.Delete

End If

gracias desde ya saludos

[Antoni]

Esta macro borra las imágenes en el rango A:W

Sub BorrarImágenesRangoA_W()

Dim Imagen As Shape

For Each Imagen In ActiveSheet.Shapes

  If Imagen.Type = msoPicture Then

      If Not Application.Intersect(Imagen.TopLeftCell, Range("A:W")) Is Nothing Then

        Imagen.Delete

      End If

  End If

Next

End Sub

[/CODE]

[maylex]

Gracias Macro Antonio por la respuesta, pero no me funciona para las imágenes de la formulación que tengo arriba y nose porque, quizás debe ser porque están en otro formato de imagen,

gracias