اضافة لكود ادراج صوره في الصفحات

[ابو مارفن]

السلام عليكم ارجو ضافة لكود ادراج صوره للاستاذ عبدالله بشير مشكوره جهوده ليعمل الكود على الملف في حال كانت الصفحات المراد اضافة الصوره فيها مقفله بباسورد 123 وكان الصف الثاني مخفي مع بقاء الملف كما هو عليه الان (الصفحات مقفله والصف الثاني المراد اضافه الصوره به مخفي) وان يكون تنفيذ الكود سريع علما ان عدد الصفحات تقريبا 20 واكثر صفحة مع جزيل الشكر والتقدير

كود لاضافه صور للصفحات_124938.xlsm

تم تعديل منذ 7 ساعات بواسطه ابو مارفن

[ابو مارفن]

باسورد محرر الاكواد 1230

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

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

الكود المرفق يقوم :-

بالغاء حماية الشيتات المستهدفة 123 ثم يتم اظهار الصفوف 1-2 ثم يمسح الصور السابقة  

بعد ادراج الصور يتم اخفاء الصفوف1-2 ثم حماية الصفحات من جديد 123

استبدل الكود السابق بهذا

تم تجربة الكود على 28 صفحة في  حدود 3 الى 4 ثانية

Private Sub CommandButton13_Click()
    Dim ws As Worksheet
    Dim Pic As Shape
    Dim shp As Shape
    Dim rng As Range
    Dim fd As FileDialog
    Dim imgPath As String
    Dim i As Long
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "اختر الصورة المراد إدراجها"
        .Filters.Clear
        .Filters.Add "جميع الصور", "*.jpg; *.jpeg; *.png; *.bmp; *.gif; *.tiff"
        .AllowMultiSelect = False
        
        If .Show = -1 Then
            imgPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Application.CommandBars.FindControl(ID:=549).Execute
    On Error GoTo 0
    
    For Each ws In Worksheets
        If ws.Name <> "قائمة" And ws.Name <> "مخزن" Then
            
            On Error Resume Next
            ws.Unprotect Password:="123"
            On Error GoTo 0
            
            ws.Rows("1:2").Hidden = False
            
            Set rng = ws.Range("A2:V2")
            
            For i = ws.Shapes.Count To 1 Step -1
                Set shp = ws.Shapes(i)
                If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then
                    On Error Resume Next
                    If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then
                        shp.Delete
                    End If
                    On Error GoTo 0
                End If
            Next i
            
            Set Pic = ws.Shapes.AddPicture( _
                Filename:=imgPath, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=rng.Left, _
                Top:=rng.Top, _
                Width:=rng.Width, _
                Height:=rng.Height)
            
            With Pic
                .LockAspectRatio = msoFalse
                .Placement = xlMoveAndSize
            End With
            
            ws.Rows("1:2").Hidden = True
            
            ws.Protect Password:="123"
            
        End If
    Next ws
    
    Application.ScreenUpdating = True
    MsgBox "تم إدراج الصورة  بنجاح!", vbInformation, "تم بنجاح"
End Sub

كما يمكنك  الغاء اكوادالحماية وغيرها من ملفك لانها اصبحث من صمن الكود السابق

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

[ابو مارفن]

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