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

[ابو مارفن]

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

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

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