اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

مساعدة في استراد الصورة الى الخلية


الردود الموصى بها

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

رمضان كريم على الامة الاسلامية

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

2002-01-01_020714.jpg

حفظ الصورة.rar

رابط هذا التعليق
شارك

  • 2 weeks later...

بارك الله فيك أخي khalf على هذه الأكواد القيمة ان شاء الله ينتفع بها بقية الأعضاء

أرجو من الأخوة الأفاضل تطبيق هذه الأكواد على ملفي المرفق في المشاركة لأنني مبتدء ولم استطع تطبيق ذلك

في انتظار ردكم تقبلوا مني فائق عبارات الشكر والتقدير


   'كود إضافة قائمة منسدلة إلى العمود الذي سيتم تغيير الصور بناء على قيمته 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error Resume Next 

If Target.Column = 1 Then

    With Range("a" & Target.Row).Validation
        .Delete

        'w_r=OFFSET($E$1;0;0;COUNTIF($E$1:$E$1000;"<>"))
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=w_r"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With

End If
End Sub

'إدراج الصور في الخلايا 

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
    Dim PicM As Picture
    Dim pictloc As String
'Created by H-E Khalf
    Dim x As String
 

    If Target.Column = 1 And Range("a" & Target.Row) = "" Then
    
        x = Range("c" & Target.Row).Address & "c"


    ActiveSheet.Shapes(x).Delete
    End If

    If Target.Column = 1 And Range("a" & Target.Row) <> "" Then




        x = Range("c" & Target.Row).Address & "c"


    ActiveSheet.Shapes(x).Delete



    pictloc = Application.ActiveWorkbook.Path & "\" & Range("a" & Target.Row).Value '& ".jpg"



Set PicM = ActiveSheet.Pictures.Insert(pictloc)



PicM.Select

    PicM.ShapeRange.LockAspectRatio = msoFalse
    PicM.ShapeRange.Height = Range("c" & Target.Row).Height
    PicM.ShapeRange.Width = Range("c" & Target.Row).Height



    PicM.Top = Range("c" & Target.Row).Top
    PicM.Left = Range("c" & Target.Row).Left

    PicM.Placement = xlMoveAndSize

   

    PicM.Name = Range("c" & Target.Row).Address & "c"
    Range("a" & Target.Row).Select

End If
Application.ScreenUpdating = True
End Sub

'تصفير البيانات
Private Sub CommandButton1_Click()
Call Del
End Sub

Sub Del()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Excel.Shape
For Each Sh In ActiveSheet.Shapes
If Right(Sh.Name, 1) = "c" Then
Sh.Delete
End If
Next

 Dim Cel As Range
 Dim C As Integer

 For Each Cel In Range("a1:a1000")
With Cel.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
End With
Next

Range("a:a").ClearContents
Range("a:a").ClearHyperlinks
Selection.ClearContents
Selection.ClearHyperlinks
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

' جلب أسماء الصور من المجلد الذي  سيوضع به الملف و هي من لاحقة 
 ' jpg
Private Sub Workbook_Open()
Call Get_Files_Names
End Sub

Sub Get_Files_Names()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim fldpath
Dim fso As Object, fld As Object, fil As Object, j As Long


On Error Resume Next

fldpath = Application.ActiveWorkbook.Path
    If fldpath = False Then
        MsgBox "Folder Not Selected"
        Exit Sub
    End If


Columns("D:D").Clear


Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.getfolder(fldpath)


j = 1
For Each fil In fld.Files
    Range("D" & j).Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fil.Path, _
        TextToDisplay:=fil.Name
        ActiveSheet.Hyperlinks.Delete
        
j = j + 1
Next
Dim Cel As Range
For Each Cel In Range("D1:D1000")
If Right(Cel, 4) <> ".jpg" Then
        Cel.Delete Shift:=xlUp
        End If
        Next
Dim Cel1 As Range
For Each Cel1 In Range("D1:D1000")
If Left(Cel1, 1) = "~" Then
        Cel1.Delete Shift:=xlUp
        End If
        Next
Set fso = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

حفظ الصورة.rar

رابط هذا التعليق
شارك

تمام يا رايس بالضبط هذا ما كنت ابحث عنه بارك الله فيك وفي اهلك واولادك وفي مالك واسعدك الله في الدارين

شكرا شكرا أخي

احمد بدره

تم تعديل بواسطه حراثي تواتي
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information