اذهب الي المحتوي
أوفيسنا

وضع صورة للموظف حسب رقمه أو اسمه


إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

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

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

رمضان مبارك - تقبل الله منكم صالح اعمالكم

 

بجهود الاخ (خالد الرشيدي ) المبين على الرابط ادناه

تم تصميم برنامج حسب متطلبات العمل التي عندي

وحبيت ان اطرح سؤالي الجديد عن طريق موضوع جديد

وسؤالي الجديد هو

وضع صورة للموظف حسب رقم الموظف أو اسمه ، وصورة الموظف محفوظة لديه على

بارتيشن D:\   فولدر (صور)

 

اسم المستخدم      زيد

الرقم السري       123

 

http://www.officena.net/ib/index.php?showtopic=62628&hl=

برنامج بطاقة الموظف الشهري والسنوي.rar

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

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

اليك هذا الكود وجدته في احد المنتديات الاجنبية ذات وقت وكان عندي

هذا الكود تضعه في الموديل

وبعدها

تذهب الى bar formula    في تبويت  fx  في مكان تاوجد المعادلات  تجد personalesé

 

تجد معادلة تظهر لك بأسم AfficheImage   حدد اي خلية التي تريد ان تكون صورة  وجرب لعلها تعيطك النتيجة او يقوم الاساتدة الكرام بتعديل حسب طلبك 

Function AfficheImage(NomImage, Optional rep)
  Application.Volatile
   If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
   Set f = Sheets(Application.Caller.Parent.Name)
   Set adr = Application.Caller
   temp = NomImage & "_" & adr.Address
   Existe = False
   For Each s In adr.Worksheet.Shapes
      If s.Name = temp Then Existe = True
   Next s
   If Not Existe Then
     For Each k In adr.Worksheet.Shapes
       p = InStr(k.Name, "_")
       If Mid(k.Name, p + 1) = adr.Address Then k.Delete
   Next k
   If Dir(rep & NomImage) = "" Then
     AfficheImage = "Inconnu"
   Else
     Set myShell = CreateObject("Shell.Application")
     If TypeName(rep) = "Range" Then
       Set myFolder = myShell.Namespace(rep.Value)
     Else
       Set myFolder = myShell.Namespace(rep)
     End If
     Set myFile = myFolder.Items.Item(NomImage)
     Taille = myFolder.GetDetailsOf(myFile, 26)
     H = Val(Split(Taille, "x")(1))
     L = Val(Split(Taille, "x")(0))
     Ech = adr.Height / H
     H = H * Ech
     L = L * Ech
     f.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, L, H).Name = NomImage & "_" & adr.Address
     AfficheImage = "ok"
   End If
  End If
End Function

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

الأخ الفاضل أبو زيد يرجى وضع ملف الصور مع الملف المرفق .. للعمل عليه .. وحدد المطلوب بشكل أدق بارك الله فيك (في أي ورقة عمل تريد تطبيق المطلوب .. هل العمل سيكون بناءً على اسم الموظف أم رقمه ؟ ..)

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

السلام عليكم

 

الصور موجودة في البارتيشن D:|صور

 

ونرفق ملف بالصور - (مثال)

 

ويكون البحث على اساس رقم الموظف - واذا به مجال على الرقم والاسم

واما بخصوص درج الصورة في الورقتين شيت (الشهرية و السنوية)

 

السلام عليكم

برنامج بطاقة الموظف الشهري والسنوي.rar

صور.rar

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

فيديو بسيط بخصوص البحث عن الصور من خلال اليوزرفورم

الكود سهل وبسيط جدا

السلام عليكم أستاذ إسلام رجب المحترم...مرحباً بك معنا تثري منتدانا بعلمك المعهود عنك

كنية رائعة واسم أروع وأجمل ما أحلى كتابتهما باللغة العربية التي لغة القرآن الكريم

(( إسلام رجب))

لعلك نسيت ملف الفيديو بسبب الصوم .أم أنك حملته وانتهت مدة تحميله كما رأينا.. تقبل تحياتي والسلام عليكم.

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

تفضل أخي الكريم الملف التالي عله يفي بالغرض

قم بتغيير المسار في الخلية J1

 

برنامج بطاقة الموظف الشهري والسنوي.rar

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

السلام عليكم

جزيت خيرا اخ ياسر - ورمضان مبارك

رجاء اخر :

ان تكون الصورة في خلية J1 ذات قياس واحد (حجم واحد) مهما كانت حفظ الصورة باي حجم

مثلا أن تكون الارتفاع (4 سم) والعرض (4 سم)

مشكورين سلمكم الله

 

برنامج.rar

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

  • أفضل إجابة

أخي الفاضل أبو زيد ... السلام عليكم

إليك الكود التالي وإن شاء الله بإذن المولى يفي بالغرض تماماً ..

Sub InsertPictureVBA()
    Dim pic As Picture, strPhotosFolder As String, strPhoto As String
    strPhotosFolder = ThisWorkbook.Path & "\صور\"
    
    Application.ScreenUpdating = False

    With Sheets("بطاقة الموظف السنوية")
        While .Pictures.Count
            .Pictures(1).Delete
        Wend
        strPhoto = strPhotosFolder & Trim(.Range("B2").Value) & ".*"
        strPhoto = Dir(strPhoto)
        If Len(strPhoto) Then
            strPhoto = strPhotosFolder & strPhoto
            .Pictures.Insert (strPhoto)
            Set pic = .Pictures(.Pictures.Count)
            With pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = .Parent.Range("J1").Left
                .Top = .Parent.Range("J1").Top
                .Width = .Parent.Range("J1").Width
                .Height = .Parent.Range("J1").Height
            End With
        End If
    End With

    Application.ScreenUpdating = True
End Sub

كل ما عليك فعله هو تغيير مسار مجلد الصور من هذا السطر

 strPhotosFolder = ThisWorkbook.Path & "\صور\"

ليصبح بهذا الشكل

strPhotosFolder = "D:\صور\"

كما تمت إضافة سطر في حدث الورقة المسماة "بطاقة الموظف السنوية" ليتم تنفيذ الكود بمجرد التغير في الخلية B2 ... قم بكتابة رقم الموظف لتظهر الصورة الخاصة به في الخلية J1 بنفس الأبعاد للخلية ..

 

الملفات في مجلد الصور تكون بأرقام الموظفين .. كل موظف له صورة مسماة برقمه أو يمكنك التعديل في الكود بما يحلو لك ... ليناسب طلبك أياً كان

 

تقبل الله منا ومنكم صالح الأعمال

ولا تنسى أن تحدد أفضل إجابة كما لا تنسى أن تضغط أعجبني هذا إذا أعجبك بالطبع

:fff: :fff: :fff:

برنامج البطاقة الشهرية والسنوية.rar

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

السلام عليكم

تم اكمال شيت بطاقة الموظف السنوية

محتاجين اكمال شيت البطاقة الشهرية (درج صورة الموظف في شيت بطاقة الموظف) بنفس مواصفات ومعادلات شيت بطاقة الموظف السنوية

وفقكم الله - شكرا على جهودكم

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

أخي الكريم حاول أن تنسخ الكود الموجود في محرر الأكواد .. وعدل فيه بما يناسب طلبك

الموضوع بسيط إن شاء الله .. حاول أن تتعلم وكفاك أسماكاً جاهزة (جرب تصطاد السمكة بنفسك وشوف طعم السمك هتلاقيه مختلف تماماً ..)

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

السطر التالي يحدد مسار مجلد الصور

strPhotosFolder = ThisWorkbook.Path & "\صور\"

*************************************

السطر التالي

With Sheets("بطاقة الموظف السنوية")

يحدد ورقة العمل المطلوب العمل عليها

***************************************

السطر التالي

strPhoto = strPhotosFolder & Trim(.Range("B2").Value) & ".*"

غير اسم الخلية B2 باسم الخلية اللي فيها رقم الموظف (التي يتم كتابة رقم الموظف بها)

*************************************

الأسطر التالية

.Left = .Parent.Range("J1").Left
                .Top = .Parent.Range("J1").Top
                .Width = .Parent.Range("J1").Width
                .Height = .Parent.Range("J1").Height

هتغير اسم الخلية التي يوضع بها الصور J1 إلى الخلية التي تريد إدراج الصورة بها

بس خلاص الموضوع بسيط مش معقد أخي الفاضل أبو زيد

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

السلام عليكم

استاذ ياسر خليل المحترم

جزاك الله خير

نسخت الكود وغيرت الخلية كما وجهت ، ولكن اكو شغلة ؟؟؟ بحيث لا تظهر الصورة في الخانة 

وادناه الملف الذي غيرت به حسب الخطوات التي قلت بها في المشاركة اعلاه

للتفضل بالاطلاع 

السلام عليكم

 

برنامج1.rar

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

غير اسم الماكرو الجديد دي أول ملحوظة لاحظتها بعد تنزيل ملفك

مينفعش يكون فيه 2 ماكرو بنفس الاسم .. اجعل اسم الماكرو الجديد باسم InsertPictureVBA2 مثلاً

 

روح اعمل كليك يمين على اسم ورقة العمل "بطاقة الموظف" ثم View Code ثم عدل الكود الموجود ليكون بهذا الشكل ليتم  تنفيذ الكود بمجرد التغير في الخلية B3

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B3")) Is Nothing Then
        Z = Application.CountA(Sheets("الشهر الاول").Range("A2:A300"))
        For I = 2 To Z + 2
            If Target.Value = Sheets("الشهر الاول").Cells(I, 1).Value Then

                Target.Offset(0, 2).Value = Sheets("الشهر الاول").Cells(I, 2).Value
            End If
        Next I
        Call InsertPictureVBA2
    End If
End Sub

جرب أعملني بالنتيجة

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

السلام عليكم
لم احصل على نتيجة فعندما اغير في خلية B3  يذهب الايعاز الى محرر الكواد 
Private Sub Worksheet_Change(ByVal Target As Range)    يصبح باللون الاصفر
    If Not Intersect(Target, Range("B3")) Is Nothing Then
        Z = Application.CountA(Sheets("الشهر الاول").Range("A2:A300"))
        For I = 2 To Z + 2
            If Target.Value = Sheets("الشهر الاول").Cells(I, 1).Value Then
                Target.Offset(0, 2).Value = Sheets("الشهر الاول").Cells(I, 2).Value
            End If
        Next I
        Call InsertPictureVBA2     - يقف المؤشر على هذا السطر
    End If
End Sub
 
ممكن عمل فيديو ليكون اكثر ايضاحاً لي 
السلام عليكم
رابط هذا التعليق
شارك

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

رمضان كريم على الجميع

الاستاذ الفاضل ابوالبراء جزاكم الله خيرا اعمالكم في قمة الابداع

اخي العزيز ابوزيد

غيرت في موضع الصورة بدل J1  جعلتها D1  وازلت دمج الخلية التي فيها الصورة

والحمد لله الكود اكثر من رائع من استاذ مبدع دون مجامله

وفقكم الله وزادكم خيرا

 

 

برنامج 1.rar

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

السلام عليكم

استاذ ياسر ما اشتغل - يمكن الخلل من يمي ما اعرف - بس طبقت كل التوجيهات ؟؟؟

الله يرضى عليك طبق الكود على الملف - وبالتالي اكدر قارن بين توجيهاتك وعملي 

السلام عليكم

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

أنا أعمل على أوفيس 2013 ويعمل بشكل جيد عندي

جرب الملف المرفق الذي قدمه لك الأخ الحبيب الغالي الغائب عن العيون محمد أبو عباس في المشاركة رقم 19

http://www.officena.net/ib/index.php?showtopic=62661#entry406484

 

جربت الملف ويعمل في ورقتي العمل بشكل ممتاز

 

جرب تنصب أوفيس 2013 (خليك مع الجديد .. عشان تستفيد)

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information