ابو تميم قام بنشر ديسمبر 12, 2012 قام بنشر ديسمبر 12, 2012 تحية طيبة في المرفقات ملف اكسل يحتوي على كود يعمل على استدعاء السكانر ( الماسح الضوئي ) داخل الاكسل لمسح صورة معينة وحفظها على الجهاز هل يمكن التعديل على الكود بحيث يمكننا من تحديد مكان الحفظ على الجهاز وتحديد الاسم الذي ستحفظ فيه الصورة على الجهاز حيث ان الكود يعمل فقط على استدعاء السكانر وباقي الأمور تتم يدويا جزاكم الله خيرا scan2Excel1111.rar 1
الـعيدروس قام بنشر ديسمبر 12, 2012 قام بنشر ديسمبر 12, 2012 السلام عليكم أولا اذاهب الى محرر الأكواد قائمة Tools ثم Referenecs ثم انزله بالسكرول الى اسفل وحفز على الجمملة التالية Microsoft Windows Image Acquisition Library v2.0 واذا لم تجدها انقر على زر Browse في مربع النص File name : الصق السطر التالي ثم موافق C:\Windows\system32\wiaaut.dll بعد ادراج المكتبة بنجاح جرب الكود التالي Sub Imp_Scan() Dim W_A As New WIA.ImageFile Dim WD_A As New WIA.CommonDialog Dim WS_A As WIA.Device Set WS_A = WD_A.ShowSelectDevice With WS_A.Items(1) .Properties("6146").Value = 4 .Properties("6147").Value = 100 .Properties("6148").Value = 100 .Properties("6149").Value = 0 .Properties("6150").Value = 0 .Properties("6151").Value = 830 .Properties("6152").Value = 1167 Set W_A = .Transfer(wiaFormatJPEG) End With '************************************************************* If Dir(ThisWorkbook.Path & "\My_Img.jpg") <> "" Then Kill ThisWorkbook.Path & "\My_Img.jpg" End If '************************************************************** W_A.SaveFile (ThisWorkbook.Path & "\My_Img.jpg") Set W_A = Nothing Set WS_A = Nothing End Sub حفظ الصورة سيكون بنفس الفولدر بأسم My_Img ارجو تجربة الكود الكود من "msdn"
ابو تميم قام بنشر ديسمبر 13, 2012 الكاتب قام بنشر ديسمبر 13, 2012 (معدل) درر أستاذ ابو نصار سلمت يداك فعلا كود مميز قمت بتطبيقه وهو يعمل أسرع من الكود القديم بألف مرة حتى أني لا انتبه إلى أنه تم تحميل الصورة على الجهاز بهذه السرعة ولكن لدي سؤال على هذا الكود هل يمكننا التعديل على المود بحيث يكون حفظ الصور في المسار المحدد بحسب تسلسل أرقام أي أنه يبحث في المسار على أكبر رقم موجود ويتم الرقم التسلسلي الذي يليه ثانيا : في حال نقل الملف من جهاز إلى جهاز آخر هل يجب إدراج وتفعيل المكتبة جزاكم الله خيرا تم تعديل ديسمبر 13, 2012 بواسطه ابو تميم
الـعيدروس قام بنشر ديسمبر 13, 2012 قام بنشر ديسمبر 13, 2012 السلام عليكم اخي ابو تميم فرضا المسار هو C: في المجلد المسمى A حيكون التعديل في الكود هكذا If Dir("C:\A" & "\" & "My_Img.jpg") <> "" Then Kill "C:\A" & "\" & "My_Img.jpg" End If ************************************************************** W_A.SaveFile ("C:\A" & "\" & "My_Img.jpg") نعم في حال نقل الى جهاز اخر واذا المكتبة غير موجودة في Referenecs لابد من إضافتها مثل الشرح السابق وماذا تقصد بأكبر رقم هل تقصد بمسمى المجلدات مثلا في الـ C: يبحث عن مسميات المجلدات الاكبر اذا المجلدت مسمى رقمي ؟؟؟
ابو تميم قام بنشر ديسمبر 13, 2012 الكاتب قام بنشر ديسمبر 13, 2012 (معدل) شكرا أستاذ ابو نصار على سرعة الرد أقصد بأكبر رقم أني أريد ترتيب الصور بأرقام وليس بالاسم My_Img بحيث تكون هذه الصور أي أنه كلما تم إضافة صورة جديدة يتم البحث في المجلد عن أرقام الصور وتسمية الصورة الجديدة حسب تسلسل هذه الأرقام ويبحث عن أكبر رقم موجود ويعطي الصورة الجديدة الرقم الاكبر +1 وهكذا دمت في حفظ الله تم تعديل ديسمبر 13, 2012 بواسطه ابو تميم
أستيكا قام بنشر ديسمبر 13, 2012 قام بنشر ديسمبر 13, 2012 عفوا جربت الكود و لم يعمل معى بطريقة صحيحة برجاء تنفيذة على شيت الاكسيل و رفعة للاستفادة و جزاكم الله خيرا
الـعيدروس قام بنشر ديسمبر 13, 2012 قام بنشر ديسمبر 13, 2012 السلام عليكم اخي أبو تميم جرب هذا التعديل Public Sub Ali_Imag() With Application .ScreenUpdating = False .EnableEvents = False Imp_Scan .EnableEvents = True .ScreenUpdating = True End With End Sub Private Sub Imp_Scan() Dim W_A As New WIA.ImageFile Dim WD_A As New WIA.CommonDialog Dim WS_A As WIA.Device Set WS_A = WD_A.ShowSelectDevice Dim Path_F$ Dim Ar As Variant Dim i, n, A_M Dim x(100) As Integer Dim Ar_Max& Dim Start%, Last%, Num% Path_F = "C:\" & "Ali" M_v = Ali_List(Path_F) If TypeName(M_v) <> "Boolean" Then For i = LBound(M_v) To UBound(M_v) M_v(i) = Ali_Re(M_v(i)) Next Start = LBound(M_v): Last = UBound(M_v) Num = Last - Start + 1 For i = Start To Last x(i) = M_v(i) Next i Ar_Max = x(Start) For n = Start + 1 To Last If x(n) > Ar_Max Then Ar_Max = x(n) Next n Else MsgBox "لاتوجد ملفات في المسار :" & Path_F End If With WS_A.Items(1) .Properties("6146").Value = 4 .Properties("6147").Value = 100 .Properties("6148").Value = 100 .Properties("6149").Value = 0 .Properties("6150").Value = 0 .Properties("6151").Value = 830 .Properties("6152").Value = 1167 Set W_A = .Transfer(wiaFormatJPEG) End With '************************************************************* If Ar_Max = 0 Then Ar_Max = 1 Else A_M = Ar_Max + 1 End If If Dir(ThisWorkbook.Path & "\A_M.jpg") <> "" Then Kill ThisWorkbook.Path & "\A_M.jpg" End If '************************************************************** W_A.SaveFile (ThisWorkbook.Path & "\A_M.jpg") Erase x Set W_A = Nothing Set WS_A = Nothing End Sub Private Function Ali_Re(R_N) As String R_N = Replace(R_N, ".jpg", "") R_N = Mid$(R_N, 1, 31) Ali_Re = R_N End Function Private Function Ali_List(F_A As String, Optional Fltr_A As String = "*.jpg") As Variant Dim Te_A As String, A_H As String If Right$(F_A, 1) <> "\" Then F_A = F_A & "\" Te_A = Dir(F_A & Fltr_A) If Te_A = "" Then Ali_List = False Exit Function End If Do A_H = Dir If A_H = "" Then Exit Do Te_A = Te_A & "|" & A_H Loop Ali_List = Split(Te_A, "|") End Function الاخ الفاضل astika اتبع شرح مشاركة رقم 3#
ابو تميم قام بنشر ديسمبر 13, 2012 الكاتب قام بنشر ديسمبر 13, 2012 شكرا جزيلا أستاذ ابو نصار جربت الكود بداية الأمر أعطاني خطأ على السطر التالي في بداية التشغيل وقمت بإزالته من الكود وبعدها اشتغل الكود بشكل طبيعي : .Properties("6152").Value = 1167 ولكنه لا يبدأ في العمل حتى يتم وضع صورة في المجلد المسار C:\Ali ثم يبدأ في العمل ويقوم بمسح صورة واحدة فقط ويسميها M_A وبعد ذلك لا يمسح أية صورة أخرى ويعطي خطأ على النقطة x(i) = M_v(i) أرجو التكرم بالتعديل إذا توفر لديكم الوقت جزاكم الله خيرا علما أني أريد تسمية الصور بأرقام تسلسلية تبدأ من الرقم 1 جزاكم الله خيرا
الـعيدروس قام بنشر ديسمبر 13, 2012 قام بنشر ديسمبر 13, 2012 عذرا على هذا الخطاء ارجو تجربة الكود بعد التعديل اما خطاء الكود في التقاط الصور من الاسكنار لم تتضح المشكلة من وين عله يكون مشكلة المسار جرب الكود بعد التعديل Public Sub Ali_Imag() With Application .ScreenUpdating = False .EnableEvents = False Imp_Scan .EnableEvents = True .ScreenUpdating = True End With End Sub Private Sub Imp_Scan() Dim W_A As New WIA.ImageFile Dim WD_A As New WIA.CommonDialog Dim WS_A As WIA.Device Set WS_A = WD_A.ShowSelectDevice Dim Path_F$ Dim Ar As Variant Dim i, n, A_M Dim x(100) As Integer Dim Ar_Max& Dim Start%, Last%, Num% '************************** Path_F = "C:\" & "Ali" ' تعديل المسار من هذا السطر '************************** M_v = Ali_List(Path_F) If TypeName(M_v) <> "Boolean" Then For i = LBound(M_v) To UBound(M_v) M_v(i) = Ali_Re(M_v(i)) Next Start = LBound(M_v): Last = UBound(M_v) Num = Last - Start + 1 For i = Start To Last x(i) = M_v(i) Next i Ar_Max = x(Start) For n = Start + 1 To Last If x(n) > Ar_Max Then Ar_Max = x(n) Next n Else MsgBox "لاتوجد ملفات في المسار :" & Path_F End If With WS_A.Items(1) .Properties("6146").Value = 4 .Properties("6147").Value = 100 .Properties("6148").Value = 100 .Properties("6149").Value = 0 .Properties("6150").Value = 0 .Properties("6151").Value = 830 .Properties("6152").Value = 1167 Set W_A = .Transfer(wiaFormatJPEG) End With '************************************************************* If Ar_Max = 0 Then Ar_Max = 1 Else A_M = Ar_Max + 1 End If '************************** If Dir(Path_F & A_M & ".jpg") <> "" Then Kill Path_F & A_M & ".jpg" End If '************************** W_A.SaveFile (Path_F & A_M & ".jpg") '************************** Erase x Set W_A = Nothing Set WS_A = Nothing End Sub Private Function Ali_Re(R_N) As String R_N = Replace(R_N, ".jpg", "") R_N = Mid$(R_N, 1, 31) Ali_Re = R_N End Function Private Function Ali_List(F_A As String, Optional Fltr_A As String = "*.jpg") As Variant Dim Te_A As String, A_H As String If Right$(F_A, 1) <> "\" Then F_A = F_A & "\" Te_A = Dir(F_A & Fltr_A) If Te_A = "" Then Ali_List = False Exit Function End If Do A_H = Dir If A_H = "" Then Exit Do Te_A = Te_A & "|" & A_H Loop Ali_List = Split(Te_A, "|") End Function ومعك إن شاء الله إلى أن يعمل بشكل سليم تحياتي
ابو تميم قام بنشر ديسمبر 13, 2012 الكاتب قام بنشر ديسمبر 13, 2012 (معدل) دمت في حفظ الله أستاذي ابو نصار في بداية الأمر أعطاني نفس الخطأ السابق ولكن قمت بإضافة السطر التالي لتجاوز الاخطاء في بداية الكود On Error Resume Next وفعلا بعد إضافة هذا السطر لم يعطيني خطأ وتم مسح الصور بشكل ممتاز ولكن هنا يعطيني مشكلة بسيطة أعتقد حلها سهل بالنسبة إليكم أستاذنا وهذه المشكلة هي انه عند مسح أول صورة يعطيني الرسالة ( لاتوجد ملفات في المسار ) وبعد الضغط على Ok يتم مسح الصورة بشكل سليم ولكنه لا يقوم بتسميتها ويبقى اسم الصورة فارغا ( " " ) وفي هذه الحالة عندما أقوم بمسح صورة أخرى يتم مسحها بدون مشاكل ولكنه هنا يقوم بمسح الصورة الجديدة واستبدال الصورة السابقة التي بدون اسم ولا يبدأ بالترقيم إلا إذا قمنا بإعطاء الصورة الاولى رقما معيناوبعدها يبدأ البرنامج بالترقيم بناء على هذا الرقم فإذا وضعنا الصورة الأولى بالرقم 1 يكون رقم الصورة الثانية هو 2 وإذا كانت الصورة الاولى 50 تكون الصورة الثانية 51 وهكذا الخلاصة : الترقيم يكون صحيح مئة بالمئة ولكن مشكلتنا بقيت في الصورة الاولى فقط وهي التي يكون اسمها فراغ وتتبعها باقي الصور بدون أسماء ويتم استبدال الصورة الموجودة دائما بالصورة الجديدة وهنا دائما يكون لدينا في المجلد صورة واحدة فقط عذرا على الإطالة جزاكم الله خيرا تم تعديل ديسمبر 13, 2012 بواسطه ابو تميم
الـعيدروس قام بنشر ديسمبر 14, 2012 قام بنشر ديسمبر 14, 2012 السلام عليكم هذه الأسطر إحذفها من الكود وإن شاء الله يزبط معك If Dir(Path_F & A_M & ".jpg") <> "" Then Kill Path_F & A_M & ".jpg" End If تقبل تحياتي وشكري
ابو تميم قام بنشر ديسمبر 14, 2012 الكاتب قام بنشر ديسمبر 14, 2012 (معدل) شكرا جزيلا أستاذي القدير ابو نصار التعديل لم يفلح في إصلاح المشكلة ولكني قمت بتعديل الأسطر التالية من الكود وهي التي كانت سبب مشكلة الترقيم عند اول صورة وهو الآن يعمل بشكل ممتاز جدا وابتداء من أول صورة الأسطر بعد التعديل تصبح كما يلي : If Ar_Max = 0 Then A_M = Ar_Max + 1 Else Ar_Max = 1 A_M = Ar_Max + 1 End If وساتابع تجربة الكود وتفقده بأكثر من حالة وفي حال كان هناك مشكلة أخرى سنتابع جزاكم الله خيرا أستاذنا القدير ابو نصار وكفاكم شر أبناء السوء ورزقكم ما تتمنون بالحلال والخير غفر الله لنا ولكم .... جمعة مباركة إن شاء الله نراكم قريبا إن شاء الله تقبل احترامي وشكري تم تعديل ديسمبر 14, 2012 بواسطه ابو تميم
الـعيدروس قام بنشر ديسمبر 14, 2012 قام بنشر ديسمبر 14, 2012 الحمد لله السموحه منك انا ليس لدي اسكنر ولا كنت جربت الكود وعرفت اين تكمن المشكله تحياتي
ابو تميم قام بنشر ديسمبر 14, 2012 الكاتب قام بنشر ديسمبر 14, 2012 شكرا جزيلا أستاذي الكبير ابو نصار أنا تيقنت مسبقا بأنك لم تجرب الكود لأنه ليس لديك سكنر ولكن يكفي بان يكون الكود بهذا الاتقان وليس لديك سكنر فكيف لو كان عندك سكنر .... ولهذا السبب كنت عندما أفحص الكود وأجربه لا أكثر من الأسئلة التي تحتاج إلى وجود سكنر بشكل إجباري حتى يعمل عليها الكود جزاكم الله خيرا وأكثر من أمثالكم أرجو المعذرة على الإزعاج ولكن بالتأكيد سيكون لدي الكثير من الأسئلة التي تجعلني أختلط بالعمالقة والعلماء أمثالكم أستاذي ابو نصار ولي الشرف بالتعرف إليكم لأتعلم منكم وأكتسب مهارة جديدة ولو كانت نقطة في بحركم فهذا شرف عظيم لي بأن تكون هذه النقطة منكم جزاكم الله خيرا وأسأل الله العظيم في هذا اليوم المبارك بأن يحشرنا الله معا في الجنة لان المرء يوم القيامة يحشر مع من يحب وأنا والله إني أحببتكم في الله واتمنى ان احشر يوم القيامة معكم في الجنة ...
أبو أنس حاجب قام بنشر ديسمبر 14, 2012 قام بنشر ديسمبر 14, 2012 السلام عليكم ورحمة الله وبركاته آمييييييييييييييييييييييييييييييييييييييييييييييييييييييييين يارب العالمين. أسف لم أستطع أكتب أكثر من ذلك. أبو أنس
عبدالله المجرب قام بنشر ديسمبر 14, 2012 قام بنشر ديسمبر 14, 2012 بارك الله فيك استاذ ابو نصار على هذا التميز
الـعيدروس قام بنشر ديسمبر 14, 2012 قام بنشر ديسمبر 14, 2012 الاستاذ الحبيب عبدالله المجرب اشكرك على مرورك الكريم وكلماتك الطيبه
احمدزمان قام بنشر أبريل 11, 2013 قام بنشر أبريل 11, 2013 السلام عليكم و رحمة الله وبركاته جزاكم الله كل خير لي فترة وانا بأدور طريقة لإستدعاء الإسكنر من الإكسل وخاصة ان 2007 لاتوجد به هذه الخاصية التي كانت موجودة في 2003 ادراج صورة من الماسح الضوئي ابو تميم الله يجزاك الف خير على الفكرة و الأستاذ الكبير ابو نصار الله يجزاك الف خير على التنفيذ بارك الله فيكم
احمدزمان قام بنشر أبريل 19, 2013 قام بنشر أبريل 19, 2013 السلام عليكم و رحمة الله وبركاته اخواني الكرام لي طلب على الرابط http://www.officena.net/ib/index.php?showtopic=46533 بحيث يتم ادراج الصورة في نفس ورقة اكسل
ابو تميم قام بنشر فبراير 3, 2014 الكاتب قام بنشر فبراير 3, 2014 تحية طيبة هل عمل معكم الكود على ويندوز XP حيث أنه يعمل معي بشكل أكثر من ممتاز على ويندوز 7 ولكنه لا يعمل على XP
احمدزمان قام بنشر فبراير 7, 2014 قام بنشر فبراير 7, 2014 تحية طيبة هل عمل معكم الكود على ويندوز XP حيث أنه يعمل معي بشكل أكثر من ممتاز على ويندوز 7 ولكنه لا يعمل على XP السلام عليكم و رحمة الله وبركاته اخي ابو تميم الكود شغال معي على كل الأوفيس آسف على التأخير ولكن كنت مسافر في الخارج و اليوم عدة من السفر
ابو تميم قام بنشر فبراير 7, 2014 الكاتب قام بنشر فبراير 7, 2014 تحية طيبة هل عمل معكم الكود على ويندوز XP حيث أنه يعمل معي بشكل أكثر من ممتاز على ويندوز 7 ولكنه لا يعمل على XP السلام عليكم و رحمة الله وبركاته اخي ابو تميم الكود شغال معي على كل الأوفيس آسف على التأخير ولكن كنت مسافر في الخارج و اليوم عدة من السفر شكرا جزيلا أخي العزيز احمد زمان أنا لا أقصد الأوفيس ولكني أقصد الويندوز XP فإنا أجرب العمل على الملف على ويندوز7 مع أوفيس 2010 أو أوفيس 2007 ويعمل معي الكود بشكل ممتاز ولكني عندما أنقل الملف إلى ويندوز XP مع أوفيس 2010 أو أوفيس 2007 فإنه لا يعمل معي ويعطيني رسالة خطا على wia
احمدزمان قام بنشر فبراير 8, 2014 قام بنشر فبراير 8, 2014 اخي العزيز انا الكود الآن يشتغل معي على جهازين استخدمهما باستمرار عمل معي على جهاز XP و جهاز ويندوز7
محمود_الشريف قام بنشر فبراير 8, 2014 قام بنشر فبراير 8, 2014 أخى فى الله أستاذى القدير / أحمد زمان بارك الله فيكم وحمد لله على سلامتكم ============= فعلا الكود يعمل على جميع أنواع الويندوز ============= أخى ابو تميم راجع تسطيب الإسكانر الخاص بك على الجهاز او قم بتسطيبها من جديد كانت عندى نفس المشكله وقمت بتسطيب الإسكانر من جديد واشتغل الكود جيدا ============ وتقبلوا منى وافر الإحترام والتقدير
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.