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

[ابوزيد]

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

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

 

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

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

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

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

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

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

 

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

الرقم السري       123

 

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

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

تم تعديل يوليو 11, 2015 بواسطه ابوزيد

[زوهير]

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

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

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

وبعدها

تذهب الى 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

[ابوزيد]

السلام عليكم

 

الشرح صعب عليه

 

ارجو تنفيذه على الملف المرفق 

 

سلمكم الله وزادتكم علما

 

السلام عليكم

[محمد حسن المحمد]

السلام عليكم

أعرض لك ملف من إحدى مشاركات الإخوة بموضوع مشابه

راجياً أن تستفيد منه

http://www.officena.net/ib/index.php?app=core&module=attach&section=attach&attach_id=45412

[ياسر خليل أبو البراء]

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

[اسلام رجب]

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

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

تم تعديل يوليو 12, 2015 بواسطه islamragab

[ابوزيد]

السلام عليكم

 

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

 

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

 

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

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

 

السلام عليكم

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

صور.rar

تم تعديل يوليو 13, 2015 بواسطه ابوزيد

[محمد حسن المحمد]

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

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

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

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

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

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

[ياسر خليل أبو البراء]

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

قم بتغيير المسار في الخلية 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 بنفس الأبعاد للخلية ..

 

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

 

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

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

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

[ابوزيد]

السلام عليكم

 

احسنت - جزيت خيرا - تقبل الله منكم

 

الحل ممتاز

[ابوزيد]

السلام عليكم

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

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

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

[ياسر خليل أبو البراء]

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

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

[ياسر خليل أبو البراء]

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

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

[ابوزيد]

السلام عليكم

جزيت خير

رمضان مبارك

[ياسر خليل أبو البراء]

أخي الكريم أبو زيد هل تم عمل المطلوب بشكل جيد الآن أم لا؟

[ابوزيد]

السلام عليكم

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

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

السلام عليكم

تم تعديل يوليو 14, 2015 بواسطه ابوزيد

[ياسر خليل أبو البراء]

ما هي نسخة الأوفيس التي تعمل عليها؟

[ابوزيد]

السلام عليكم

 

2010

 

جزيت خيرا

[ياسر خليل أبو البراء]

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

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

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

 

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

 

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