Macro'yla Şeklin Hareket Ettirilmesi

Sub HareketliSekil()

 n = ActiveSheet.Shapes.Count    'Şekil sayısının buldurulması

 For i = 1 To n   'Birden son şekle kadar
  ActiveSheet.Shapes(i).Delete      'Şekil sil
 Next i

 

 'Aşağıdaki değerler Excel sayfasındaki ilgili hücrelerden alınmaktadır. 
 x0 = Range("B1")    'Şekil başlangıç yatay konumu

 y0 = Range("B2")    'Şekil başlangıç düşey konumu 

 w0 = Range("B3")   'Şekil başlangıç genişliği
 h0 = Range("B4")    'Şekil başlangıç yüksekliği 
 

 'Maksimum değerlerin atanması

 xmax = x0 + 10
 ymax = y0 + 20
 wmax = w0 + 10
 hmax = h0 + 10

'Aktif sayfada başlangıç değerleriyle dikdörtgen şekil oluşturulması

 ActiveSheet.Shapes.AddShape msoShapeRectangle, x0, y0, w0, h0   

 For x = x0 To xmax Step 2

  ActiveSheet.Shapes(1).Left = x     'Şeklin yatay konumunun değiştirilmesi

  Beklet     'Beklet isimli Private prosedürün çağrılması

 Next x

 For x = xmax To x0 Step -2

  ActiveSheet.Shapes(1).Left = x     'Şeklin yatay konumunun değiştirilmesi

  Beklet

 Next x

 For y = y0 To ymax Step 2

  ActiveSheet.Shapes(1).Top = y     'Şeklin düşey konumunun değiştirilmesi

  Beklet

 Next y

 For w = w0 To wmax Step 2

  ActiveSheet.Shapes(1).Width = w     'Şeklin genişliğinin değiştirilmesi

  Beklet

 Next w

 For h = h0 To hmax Step -2

  ActiveSheet.Shapes(1).Height = h     'Şeklin yüksekliğinin değiştirilmesi

  Beklet

 Next h

 For a = 0 To 360 Step 10

  ActiveSheet.Shapes(1).Rotation = a      'Şeklin açısının saat yönünde değiştirilmesi

  Beklet

 Next a

 For a = 360 To 0 Step -10

  ActiveSheet.Shapes(1).Rotation = a      'Şeklin açısının saatin ters yönünde değiştirilmesi

  Beklet

 Next a

End Sub

'------------------------------------------------------------------------------------------------------------------------

Private Sub Beklet()

 t = Timer + 0.05: While Timer < t: DoEvents: Wend

End Sub

'------------------------------------------------------------------------------------------------------------------------

Şekil ile ilgili diğer yayınım: Macro'yla Excel'e İçinde Yazı Bulunan Şekil Eklenmesi 

Prosedürün Alt+F8 Tuşuyla Çağrılması