كود تحميل صورة من الجهاز إلى اليوزرفورم ثم ترحيلها إلى الخلية v5

[محمد علي سالم]

مساء الخير لكل الاساتذه

ارجوا مساعدتي في كود يقوم بتحميل الصورة من الجهاز إلى Image موجود في اليوزرفورم ثم يقوم بترحيل الصورة إلى الخليه v5 (صورة الطالب)

وهكذا باقي الطلاب

يعني كل طالب يتم تحميل له صورة مقابل اسمه

وهذا المرفق

ولكم كل الشكر والتقدير

المصنف1.rar

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

أخي الكريم محمد علي

إذا أردت المساعدة عليك تسهيل الأمر على إخوانك

المرفق غير معبر عن الطلب .. قم بإرفاق ملف يخص طلبك فقط واحذف أية أكواد أخرى كما قم بحذف الفورم الغير مستخدم وركز على الفورم المطلوب فقط ، لتيسير الإطلاع على الملف من قبل إخوانك ..

كما أنني لم ألاحظ وجود Image على الفورم .. ما هو الفورم المطلوب العمل عليه ؟؟

أفضل إرفاق الملف مرة أخرى بعد إجراء عملية تنقيح بحيث يكون الملف يخص الطلب في الموضوع المخصص له فقط

تقبل تحياتي

 

[محمد علي سالم]

انا اسف لتأخري على الرد

اشكلك استاذ ياسر على اهتمام وانا دائما اتعلم منك كل جديد

شكرا لنصائحك

ويارب يكون مفهوم

اي استفسار انا موجود

هذا المرفق تم التعديل عليه

المصنف1.rar

[محمد علي سالم]

هذه الصورة فيها الشرح ويارب يكون واضح

[عبد العزيز البسكري]

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

أخي الكريم .. هذا حل بطريقة أخرى .. ليس الحل الأمثل .. لكن أفضل من البطالة ..  شغّل نفسك به قليلاً ريثما يتدخّل أحد الإخوة الأفاضل ..

تقوم بجلب رابط الصورة ثم يتم ترحيل هذا الرابط .. و من خلال الرابط على الشيت يمكنك معاينه الصّورة

 

إدراج الصورة.rar

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

أخي الكريم محمد علي

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

Sub ShowForm()
    UserForm1.Show
End Sub

Function LastRowPic(ColumnNumber As Long) As Long
    Dim Arr, Pic As Shape, I As Long
    ReDim Arr(1 To Columns.Count)
    
    For Each Pic In ActiveSheet.Shapes
        With Pic
            For I = .TopLeftCell.Column To .BottomRightCell.Column
                Arr(I) = Application.Max(.BottomRightCell.Row, IIf(Arr(I) = "", 0, Arr(I)))
            Next I
        End With
    Next Pic
    
    LastRowPic = Arr(ColumnNumber)
End Function

ثم قم بوضع الكود التالي في حدث الفورم

#If VBA7 Then
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

Private Const SW_HIDE As Long = 0
Private Const SW_SHOW As Long = 5

Private LastSelectedFilePath As String

Private Sub CommandButton1_Click()
    Dim strFileName As String
    
    strFileName = Application.GetOpenFilename(FileFilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select A File", MultiSelect:=False)
    
    If strFileName = "False" Then
        MsgBox "File Not Selected!"
    Else
        Me.Image1.Picture = LoadPicture(strFileName)
        LastSelectedFilePath = strFileName
        Me.Repaint
    End If
End Sub

Private Sub CommandButton2_Click()
    Dim R As Range, LR As Long
    
    ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_HIDE
    If LastRowPic(22) = 0 Then LR = Cells(Rows.Count, "V").End(xlUp).Row + 1 Else LR = LastRowPic(22)
    Set R = Range("V" & LR)
    ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_SHOW
    
    With ActiveSheet.Pictures.Insert(LastSelectedFilePath)
        .ShapeRange.LockAspectRatio = msoFalse
        .Top = R.Top
        .Left = R.Left
        .Width = R.Width
        .Height = R.Height
    End With
End Sub

وإليك الملف المرفق فيه تطبيق للأكواد

أرجو ان يكون المطلوب إن شاء الله

Load Picture On UserForm Using Dialog & Insert Image To Worksheet YasserKhalil.rar

[عبد العزيز البسكري]

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

تسلم أخي الغالي و أستاذي القدير ياسر خليل أبو البراء على الملف أكثر من الرّائع و الذي أظنه هو المطلوب من الأخ بالتّمام و الكمال

فقط ملاحظة صغيرة أخي الحبيب ..

عندما جربت الملف الصور على الشيت لا تظهر متسلسلة تحت بعضها إلا بالمرة الثانية .. لا أدري ما السبب ؟؟

شاهد الصورة لو تكرمت

 

 

 

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

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

أخي الحبيب عبد العزيز افتقدناك لفترة ..عسى أن يكون غيابك عن إخوانك خير إن شاء الله

 

الحمد لله أن نال الملف إعجابك ..

بالنسبة لسؤالك فيما يخص تسلسل الصور .. يتم حفظ الصور في العمود V حسب الكود الخاص بحفظ الصورة في ورقة العمل ... وهناك دالة معرفة في الموديول من خلالها يمكن معرفة أول صف فارغ ليس به صور فيقوم الكود في المرة الثانية بإدراج الصورة تحت آخر صورة تم إدراجها من قبل في العمود V فقط ..

تقبل وافر تقديري واحترامي

[عبد العزيز البسكري]

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

بارك الله فيك أستاذي القدير ياسر خليل أبو البراء على الشّرح و التّوضيح

تمام التّمام .. بصراحة أهوى الأعمال الراقية و أنت و بدون منازع ملك الأعمال أكثر من الرّائعة و الرّاقية

باسم الله ما شاء الله

فائق إحتراماتي

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

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

الأروع مما قدمته هو كلماتك الطيبة وشعورك الطيب تجاهي

جزيت خيراً أخي الغالي عبد العزيز على كلماتك الرقيقة والتي تفوق ما أقدمه

جمعني الله وإياك في مستقر رحمته يوم القيامة

تقبل تحياتي

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

السلام عليكم ورحمة الله وبركاته بارك الله بكم إخوتي الكرام على هذا التناغم والانسجام بين أحبابي ..وهذا الملف والكود الذي لم أستخدمه بعد والذي أظنه فتحا عظيما في مجال إرفاق الصور كما هو موجود في الأكسز Access 

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

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

 

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

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

أبي الحبيب الغالي أبو يوسف

جزيت خيراً على كلماتك الطيبة الرائعة ..

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

أنتم قرة أعيننا أبا يوسف ..جمعنا الله وإياكم في الفردوس الأعلى من الجنان

تقبل تحياتي

[محمد علي سالم]

ابدعت استاذي الغالي ياسر ابو البراء هذا هو المطلوب بعينه

ربي يجزيك الجنة ووالديك امين يارب

دائماً اتعلم منك كل جديد ابدعتي استاذي الغالي

وفي الليلة الظلماء يفتقد البدر وانت البدر استاذ ياسر ابو البراء

شكرا جزيلاً لك

وايضاً الاستاذ عبد العزيز البسكري لمرورك وكلماتك الطيبة

تقديري وشكري لكم كلكم

الله يجعله في ميزان حسناتكم يارب

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

أخي الكريم محمد علي

جزيت خيراً على كلماتك الرقيقة والحمد لله أن تم المطلوب على خير ..

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

جزيت خيراً بمثل ما دعوت لي ولك بمثل إن شاء الله

تقبل تحياتي

[محمد علي سالم]

الله يجزيك الخير يارب

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

ولك كل الشكر والتقدير

تقبل تحياتي

[أبوبسمله]

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

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

[ع_ حسام]

كود جميل بارك الله فيك وجزيت خيرا 

فيه ملاحظة : عند إستدعاء صورة يضعها في الشيت فوق بعضها البعض في الخلية واحد الأولى فقط وليس مترتبة في آخر خلية فارغة

اما هذه مشكلة في النسخة الأوفيس 2007

 

تم تعديل فبراير 18, 2016 بواسطه ع_ حسام
خطأ

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

أخي الحبيب أحمد الفلاحجي أبو بسملة

جزيت خيراً على تسجيعك المستمر لأعضاء المنتدى وعلى كلماتك الرقيقة ودعائك الطيب المبارك

ولك بمثل إن شاء الله

 

أخي ع_ حسام

يتم استدعاء الصورة حسب أول خلية فارغة .. سواء أكانت الخلية به قيمة بداخلها (نصية أو رقمية أو أياً كان) أو كانت الخلية بها صورة ..

إذا لم يعمل معك الكود يرجى إرفاق صورة أو ملف فيديو لتوضيح المشكلة التي تظهر لديك ..

تقبل تحياتي

[ع_ حسام]

السلام عليكم أخي ياسر 

عند تحويل الشيت من اليسار إلى اليمين 

الكود يعمل الصور فوق بعضها جرب 

 

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

أخي الكريم حسام

الملف يعمل بشكل طبيعي عندي حتى بعد تحويل الورقة من اليسار إلى اليمين أو من اليمين لليسار

شاهد الفيديو التالي لتتأكد بنفسك من صحة كلامي

ويا ريت الأخوة الأعضاء يجربوا الملف عشان نتأكد من صحة عمل الملف .. قد تكون المشكلة مع بعض نسخ الأوفيس

 

Watch.rar

[ع_ حسام]

بارك الله فيك متشكر جدا

انا إستعمل 2007  ربما يكون من نسخة الأفيس.

لكي نطور الفورم ، أن يكون فورم إظافة  أجمل بحيث يكون الإسم والتاريخ الميلاد  معلومات عن شخص مثلا مع صورته وعند ترحيل ترحل المعلومات مع صورته إلى شيت 

يكون فورم ممتاز  وغير موجود من قبل بهذه الطريقة 

تقبل تحياتي الأستاذ ياسر 

 

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

أخي الكريم

أنا لست بارعاً في تصميم الفورم بشكل كبير .. سأترك الأمر لمحترفي الفورم ليقوموا على طلبك ..

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

تقبل تحياتي

[ابو راكان العودة]

الاخ الفاضل 

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

كرما ماهي الطريقة المثالية لادخال الصورة في الخلية  كما في مثالك زائدا ادخال الاسم في الخلية المجاورة

زادك الله علما وفضلا وجزاك الله خير

•  

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

أخي الكريم أبو راكان

بالنسبة لطلبك لنفترض أن الفورم يحتوي على تكست بوكس للاسم المطلوب إدراجه ، والمطلوب إدراجه في العمود G في نفس صف الخلية التي سيتم إدراج صورة بها

بما أن العمود الذي يتم إدراج صورة فيه كما في المثال العمو V والعمود المطلوب إدراج الاسم فيه هو العمود G أي يسبق العمود V بـ 17 عمود .. فيستلزم الأمر إضافة سطر واحد في نهاية الكود التالي

Private Sub CommandButton2_Click()
    Dim R As Range, LR As Long
    
    ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_HIDE
    If LastRowPic(22) = 0 Then LR = Cells(Rows.Count, "V").End(xlUp).Row + 1 Else LR = LastRowPic(22)
    Set R = Range("V" & LR)
    ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_SHOW
    
    With ActiveSheet.Pictures.Insert(LastSelectedFilePath)
        .ShapeRange.LockAspectRatio = msoFalse
        .Top = R.Top
        .Left = R.Left
        .Width = R.Width
        .Height = R.Height
    End With
    
    R.Offset(0, -19).Value = textbox1.Value
End Sub

 

[ابو راكان العودة]

في ٣٠‏/١٢‏/٢٠١٥ at 01:35, مختار حسين محمود said:

السلام عليكم أبا راكان  اضغط الرابط التالى

تحياتى

 

الاخ 

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

•  

جزاك الله خير ووفقك ربي