Şekli büyütüp küçültme

[işsiz123]

Arkadaşlar merhabalar
Sayfaya eklediğim şekillere tıkladığımda Şekil boyutu büyüsün Sıfırla düğmesine tıkladığımda eski halini alsın.
Dosya ekte
http://s6.dosya.tc/server8/vgpvvt/Kitap1.rar.html

 

[PLİNT]

Merhaba
Örnek dosyanıza göre; makroları aşağıdaki gibi deneyin.
Mavi bölümler dosyanızdaki şekillerin normal büyüklükleridir, asıl dosyanızda bunları ayarlarsınız.

[SIZE="2"]Sub Makro15()
    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
    Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ZOrder msoBringToFront
    Range("F6").Select
End Sub


Sub Makro17()
    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
    Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
     Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
     If Selection.ShapeRange.Width < [COLOR="Blue"]136.0461[/COLOR] Then
     Selection.ShapeRange.Width = [COLOR="Blue"]136.0461[/COLOR]
    Selection.ShapeRange.Height = [COLOR="Blue"]46.87079[/COLOR]
    End If
     Range("N7").Select
End Sub [/SIZE]

 

[işsiz123]

Teşekkürler.

 

[işsiz123]

Merhaba
Örnek dosyanıza göre; makroları aşağıdaki gibi deneyin.
Mavi bölümler dosyanızdaki şekillerin normal büyüklükleridir, asıl dosyanızda bunları ayarlarsınız.

[SIZE="2"]Sub Makro15()
    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
    Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ZOrder msoBringToFront
    Range("F6").Select
End Sub


Sub Makro17()
    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
    Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
     Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
     If Selection.ShapeRange.Width < [COLOR="Blue"]136.0461[/COLOR] Then
     Selection.ShapeRange.Width = [COLOR="Blue"]136.0461[/COLOR]
    Selection.ShapeRange.Height = [COLOR="Blue"]46.87079[/COLOR]
    End If
     Range("N7").Select
End Sub [/SIZE]

Teşekkürler Orijinal boyutunu nasıl bulacağım.
Size zahmet kodların anlamını yazarmısınız

 

[PLİNT]

Kodların içine yazmak içinse;
Width genişlik
Height yükseklik
Makroyu aşağıdaki gibi çalıştırıp, "a1" ve "a2" hücresine yazılanı formül çubuğundan küsuratlarıyla
görebilirsiniz, (yalnız küsuratta virgül yerine nokta kullanın).

Sub Makro17()
 ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
 [A1] = Selection.ShapeRange.Width
   [A2] = Selection.ShapeRange.Height

     Range("N7").Select
End Sub

 

[işsiz123]

Teşekkürler Oldu.