Você não está pegando a *borda certa da imagem, para arrastar, vc precisa mover e não dimensionar....

Pegue no meio do portão e mova-o...

A propriedade que provavelmente mudará é a Top...

FF

Não sei se entendi, mas para dimensionar uma imagem, em uma única "direção" experimente setar a propriedade := LockAspectRatio como falso, essa é a propriedade que procura manter a proporcionalidade na imagem

Sheets("Plan1").Shapes.Range(Array("Picture 35")).Select 'Seleciona a sheet e a imagem em questão'
Selection.ShapeRange.ZOrder msoBringToFront 'Envia a imagem para frente(faz com que ela apareça)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.ScaleHeight 1.5483870968, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.6041666667, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.2857156492, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.181817989, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.2307690237, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.1388895167, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.0853657444, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.887640582, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.8227850456, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.7461542562, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.701031575, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.6176466955, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.8095242857, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ZOrder msoSendToBack 'Envia a imagem para trás de volta

Fernando

Desculpa, amigo. Não é isso.

Mover seria trivial. Eu quero dimensionar mesmo. De forma que não altere os limites(tamanhos) laterais da figura e sim só altere o tamanho vertical.

Reinaldo, vou testar aqui. Já te digo se funcionou. Obrigado!

[]´s

Reinaldo,

Funcionou! Esverdeado!

O próximo problema que eu estou tendo agora é:

1- A imagem não desce pausadamente. Queria que fosse mais real, como um portão de garagem descendo pausadamente. A macro roda, o portão desce de uma vez só.
Você conhece algo que fazer com o que o portão desça sincronizado com um FOR no programa?

Tentei algo desse tipo aqui e não funfou!

Sub Fecha()

    Sheets("Capa").Shapes.Range(Array("Picture 35")).Select
    Selection.ShapeRange.ZOrder msoBringToFront
    Selection.ShapeRange.LockAspectRatio = msoFalse
    
    For i = 0 To 100
    j = 1
    Selection.ShapeRange.ScaleHeight j + 0.05, msoFalse, msoScaleFromTopLeft
    Next i 

Abs!

Talvez algo +/- assim:
Sub Fecha()
Dim Start, Delay

Sheets("Capa").Shapes.Range(Array("Picture 35")).Select
Selection.ShapeRange.ZOrder msoBringToFront
Selection.ShapeRange.LockAspectRatio = msoFalse

Start = Timer
Delay = Start + 0.15
Do While Timer < Delay
Selection.ShapeRange.ScaleHeight 1 + 0.05, msoFalse, msoScaleFromTopLeft
DoEvents
Loop
End Sub

Talvez algo +/- assim:

Start = Timer
Delay = Start + 0.15
Do While Timer < Delay
DoEvents
Loop
End Sub

Reinaldo, está quase perfeito! O portão com esse código ele desce em uma velocidade que parece real.

O problema que notei foi o seguinte. A cada vez que eu rodo o programa, ele para(finaliza) com um tamanho diferente.
Deve ser a diferença de tempo para processar a macro. Isso faz com que ele fique com tamanhos distintos.
E eu queria que ele parasse sempre no mesmo lugar. Sabe o que eu posso fazer para acabar com esse problema?

O último programa que fiz está assim:

Sub Fecha7()
Dim Start, Delay

Sheets("Capa").Shapes.Range(Array("Picture 35")).Select
Selection.ShapeRange.ZOrder msoBringToFront
Selection.ShapeRange.LockAspectRatio = msoFalse

For i = 0 To 76
    j = 1
 Start = Timer
 Delay = Start + 0.15
  Do While Timer < Delay
    Selection.ShapeRange.ScaleHeight j + 0.005, msoFalse, msoScaleFromTopLeft
  DoEvents
  Loop
  Next i
    
    For i = 79 To 90
    j = 1
    Start = Timer
  Delay = Start + 0.15
  Do While Timer < Delay
    Selection.ShapeRange.ScaleHeight j + 0.001, msoFalse, msoScaleFromTopLeft
        DoEvents
Loop
    Next i
     
    Selection.ShapeRange.ZOrder msoSendToBack

End Sub

Creio que deva definir um tamanho máximo, incluir um if logo após o While timer, questionando o tamanho da imagem.
Application.CentimetersToPoints(4) --> 4 = 4 centimetros

Sub Fecha7()
Dim Start, Delay, i As Integer, j As Integer, iAc As Double

Sheets("Capa").Shapes.Range(Array("Picture 3")).Select
Selection.ShapeRange.ZOrder msoBringToFront
Selection.ShapeRange.LockAspectRatio = msoFalse

For i = 0 To 90
    j = 1
    If i <= 76 Then
        i = 0.005
    Else
        i = 0.001
    End If
    Start = Timer
    Delay = Start + 0.15
        Do While Timer < Delay
            If Selection.ShapeRange.Height <= Application.CentimetersToPoints(4) Then
              Selection.ShapeRange.ScaleHeight j + 0.005, msoFalse, msoScaleFromTopLeft
            Else
              Selection.ShapeRange.Height = Application.CentimetersToPoints(4)
                GoTo Aqui
            End If
        DoEvents
        Loop
Next i
       
Aqui:
        Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
End Sub

Perfeito, Reinaldo! VOCÊ É O CARA!

Muito obrigado, meu camarada! Feliz Natal!