اضافة خاصية لادراج صورة

[ابو مارفن]

السلام عليكم شلونكم بدون زحمة اريد ان اضيف خاصيه  الى الصوره المدرجة من خلال الكود كما هو موضح بالصورة المرفقة مع جزيل الشكر والتقدير 

Private Sub Comm()

Dim ws As Worksheet
For Each ws In Worksheets
ws.Pictures.Insert ("D:\عنوان.jpg")
Next
End Sub

ادراج صورة.xlsm.xlsx

[Foksh]

وعليكم السلام ورحمة الله وبركاته ..

يظهر الخطأ التالي عند محاولة فتح ملفك المرفق في الاصدار 2019

 

وفي الإصدار 2010

[عبدالله بشير عبدالله]

السلام عليكم ورحمة الله وبركاته

تحياتي لك  ولاستاذنا  Foksh

مشكلة الملف به امتددان   ادراج صورة.xlsm.xlsx

بحذف الامتداد xlsx يعمل الملف

لاظافة الخاصية المطلوبة 

اولا يجب حذف كلمة Private  ليصبح اسم الكود   Sub Comm()

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

ثالتا  امتداد الملف هو jpg وليس png أو jpeg؛ لأن عدم تطابق الامتداد سيتسبب في ظهور خطأ عند تشغيل الكود.

في حال تغير مكان الضورة او امتدداها قم بالتعديل بالكود

اليك الكود بعد اظافة الخاصية  xlMoveAndSize   نقل الخلايا وتغيير حجمها

Sub Comm()
    Dim ws As Worksheet
    Dim pic As Object
    
    For Each ws In Worksheets
        Set pic = ws.Pictures.Insert("D:\عنوان.jpg")
        
        pic.Placement = xlMoveAndSize
    Next ws
End Sub

 

ادراج صورة.xlsm

 

 

 

[ابو مارفن]

شكراً جزيلاً استاذ الله يحفظك ويجعلها بميزان حسناتك ويبارك بيك فضلا وليس امرا احتاج ان ضيف

خاصيه انطباق على الشبكة

وان يكون ابعاد الصوره من A2 الى V2 هل يمكن ذلك كما موضح بالصوره مع جزيل الشكر والتقدير لجهودك

[عبدالله بشير عبدالله]

نعم يمكن ذلك استبدل الكود السابق بهذا 

Sub Comm()
    Dim ws As Worksheet
    Dim pic As Object
    Dim rng As Range
    
    On Error Resume Next
    Application.CommandBars.FindControl(ID:=549).Execute
    On Error GoTo 0
    
    For Each ws In Worksheets
        Set rng = ws.Range("A2:V2")
        
        Set pic = ws.Pictures.Insert("D:\عنوان.jpg")
        
        pic.ShapeRange.LockAspectRatio = msoFalse
        
        With pic
            .Top = rng.Top
            .Left = rng.Left
            .Width = rng.Width
            .Height = rng.Height
            .Placement = xlMoveAndSize
        End With
    Next ws
End Sub

السطر Application.CommandBars.FindControl(Id:=549).Execute هذا السطر يفعل أمر "الانطباق على الشبكة" (Snap to Grid) كما في طلبك 

ادراج صورة (1).xlsm

تم تعديل منذ 5 ساعات بواسطه عبدالله بشير عبدالله

[ابو مارفن]

عاشت ايدك وبارك الله بيك وبجهودك استاذ

احتاج ان يعمل الكود على كل صفحات الملف مثلا 10صفحات ويضيف الصوره فيها مهما كان امتدادها

ما عدا صفحات التي  تكون باسم ورقة3 وورقة6 لا يضيف الصوره فيها

مع جزيل الشكر لمجهودك

[عبدالله بشير عبدالله]

تم التعديل 

الكود حاليا  يقوم بحذف اي صور من النطاق a2:v2  قبل ادراج الصورة الجديدة حتى لا تتراكم الصور فوق بعضها

كذلك تم تعديل اسم الصورة ومكانها على الجهاز بحيث يمكنك احتيار اي صورة وباي اسم وباي امتداد من الجهاز ويمكنك  اضافة اي امتداد اخر غير مدرج بالكود

        .Filters.Add "جميع الصور", "*.jpg; *.jpeg; *.png; *.bmp; *.gif; *.tiff"

تم استتناء ورقة3-ورقة6 من ادراج الصور ويمكنك استتناء المزيد وذلك باظافة اسم الورقة بالكود من الجزء 

For Each ws In Worksheets
        If ws.Name <> "ورقة3" And ws.Name <> "ورقة6" Then

ادراج صورة (2).xlsm

تم تعديل منذ 1 ساعه بواسطه عبدالله بشير عبدالله

[ابو مارفن]

شكراً جزيلاً لك استاذ عبدالله المبدع الله يحفظك ويجعلها في ميزان حسناتك ويسعد ايامك تحياتي لجنابك الكريم