عد الأشكال و اختيارها و حذفها

[محمد طاهر عرفه]

احتجت لاعداد هذا الكود ، لانه فى بعض الاحيان تأتيني ملفات أجد حركتها بطيئة جدا بسبب تكرار لوجو لمرات كثيرة أو صورة ، نتيجة أن من أنشأ الملف ليس لديه خبرة كافية

و هذا الكود يقوم بما يلي :

عد الأشكال فى الملف

اختيارها

أو حذفها

و كل منها فى ماكرو منفصل

و أيضا به كودان جانبيان لادراج الوقت و التاريخ ( طبعا لاحاجة لهم لسهولة عمل ذلك بلوحة المفاتيح و لكن أتركهم فربما يحتاجهم أحد )

Sub SELECTallShapes()

    Application.SendKeys "{F5}{TAB}{TAB}{enter}B{enter}"


    

    

End Sub

Sub deleteallShapes()

    Application.SendKeys "{F5}{TAB}{TAB}{enter}b{enter}{del}"

End Sub



Sub inserttime()

 Application.SendKeys "^+;{ENTER}"

End Sub

Sub insertdate()

 Application.SendKeys "^;{ENTER}"

End Sub


Sub CountShapes()

     

    k = 0

    With ActiveWorkbook.ActiveSheet.Shapes

      For i = 1 To .Count

              k = k + 1

      Next

      Range("a1").Activate

      MsgBox k

    End With

    

    

  '  Set myDocument = Worksheets(1)

'myDocument.Shapes.Range(Array(1, 3)).Fill.Patterned _

    msoPatternHorizontalBrick

End Sub

deleteshapes.zip