Este fórum está sendo desativado

[Choicekiller]

Bom dia!

Venho novamente recorrer aos Experts do fórum!

Pesquisando uma maneira de aplicar o zoom em Shape, afim de adaptar ao meu projeto. Encontrei um código em um site americano que atende minhas expectativas.
Entretanto, não consegui aumentar a fonte do texto, quando o shape é expandido, devido ao nível avançado no qual o código foi escrito , pois estou engatinhando em VBA ainda.

Por esse motivo, peço a ajuda de vocês, na tentativa de tentar adaptá-lo.

Para o funcionamento do código (do site americano), existem algumas particularidades, que descrevi no corpo da planilha.

Vou anexar a Plan para facilitar a compreensão, dos Experts que possa a vir analisar.

Desde de já, agradeço a atenção de todos.

[osvaldomp]

Para a sua questão 1 experimente acrescentar as linhas em vermelho abaixo (altere os tamanhos da fonte se quiser).

.ScaleHeight dZoomInHeight, msoFalse, msoScaleFromTopLeft
.TextFrame.Characters.Font.Size = 18

.ScaleHeight dOutHeight, msoFalse, msoScaleFromTopLeft
.TextFrame.Characters.Font.Size = 11

Quanto a sua questão 2 não entendi exatamente o que você quer. Experimente gravar uma macro.

[Choicekiller]

Osvaldo, bom dia!

Funcionou perfeitamente a primeira macro. Exatamente o que tinha em mente. Muito obrigado.

Gravei a macro, conforme solicitado. Espero que deixe mais claro meu objetivo com a segunda macro.

Segue anexo atualizado.

Desde já, agradeço.

[osvaldomp]

Quanto à Questão 2 veja se este código ajuda.

Código: Selecionar todos

Sub ColaZoomButton1Posiciona()
 Dim MyShape As Shape, i As Long, k As Long
  Application.ScreenUpdating = False
   For Each MyShape In ActiveSheet.Shapes
    If Left(MyShape.Name, 9) = "Retângulo" Then
     k = Right(MyShape.Name, Len(MyShape.Name) - 10)
     If k >= [B1] And k <= [C1] Then
      ActiveSheet.Shapes("Zoom_Button1").Copy
      ActiveSheet.Paste
       With Selection
        .Top = MyShape.Top
        .Left = MyShape.Left
        .Name = "Zoom_Button" & i + 2
       End With
      i = i + 1
     End If
    End If
   Next MyShape
  Application.ScreenUpdating = True
End Sub

obs. o código irá colar o "ZoomButton1" somente nos Retângulos existentes na planilha e cujos números estejam no intervalo entre os números colocados em 'B1:C1'. Por exemplo, para colar o "ZoomButton1" no Retângulo 6, no Retângulo 7 e no Retângulo 8, coloque o número 6 na célula 'B1' e coloque o número 8 na célula 'C1' e rode o código.