استدعاء الإسكانر من الاكسل

ابو تميم · ديسمبر 12, 2012

تحية طيبة

في المرفقات ملف اكسل يحتوي على كود يعمل على استدعاء السكانر ( الماسح الضوئي ) داخل الاكسل لمسح صورة معينة وحفظها على الجهاز

هل يمكن التعديل على الكود بحيث يمكننا من تحديد مكان الحفظ على الجهاز وتحديد الاسم الذي ستحفظ فيه الصورة على الجهاز

حيث ان الكود يعمل فقط على استدعاء السكانر وباقي الأمور تتم يدويا

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

scan2Excel1111.rar

ابو تميم · ديسمبر 12, 2012

up

**الـعيدروس** · ديسمبر 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

السلام عليكم

اخي ابو تميم

فرضا المسار هو 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

شكرا أستاذ ابو نصار على سرعة الرد

أقصد بأكبر رقم أني أريد ترتيب الصور بأرقام وليس بالاسم My_Img بحيث تكون هذه الصور أي أنه كلما تم إضافة صورة جديدة يتم البحث في المجلد عن أرقام الصور وتسمية الصورة الجديدة حسب تسلسل هذه الأرقام ويبحث عن أكبر رقم موجود ويعطي الصورة الجديدة الرقم الاكبر +1 وهكذا

دمت في حفظ الله

تم تعديل ديسمبر 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

شكرا جزيلا أستاذ ابو نصار

جربت الكود

بداية الأمر أعطاني خطأ على السطر التالي في بداية التشغيل وقمت بإزالته من الكود وبعدها اشتغل الكود بشكل طبيعي :

.Properties("6152").Value = 1167

ولكنه لا يبدأ في العمل حتى يتم وضع صورة في المجلد المسار C:\Ali ثم يبدأ في العمل ويقوم بمسح صورة واحدة فقط ويسميها M_A وبعد ذلك لا يمسح أية صورة أخرى ويعطي خطأ على النقطة

x(i) = M_v(i)

أرجو التكرم بالتعديل إذا توفر لديكم الوقت جزاكم الله خيرا

علما أني أريد تسمية الصور بأرقام تسلسلية تبدأ من الرقم 1

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

**الـعيدروس** · ديسمبر 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

دمت في حفظ الله أستاذي ابو نصار

في بداية الأمر أعطاني نفس الخطأ السابق

ولكن قمت بإضافة السطر التالي لتجاوز الاخطاء في بداية الكود On Error Resume Next

وفعلا بعد إضافة هذا السطر لم يعطيني خطأ وتم مسح الصور بشكل ممتاز

ولكن هنا يعطيني مشكلة بسيطة أعتقد حلها سهل بالنسبة إليكم أستاذنا

وهذه المشكلة هي انه عند مسح أول صورة يعطيني الرسالة ( لاتوجد ملفات في المسار ) وبعد الضغط على Ok يتم مسح الصورة بشكل سليم ولكنه لا يقوم بتسميتها ويبقى اسم الصورة فارغا ( " " )

وفي هذه الحالة عندما أقوم بمسح صورة أخرى يتم مسحها بدون مشاكل ولكنه هنا يقوم بمسح الصورة الجديدة واستبدال الصورة السابقة التي بدون اسم ولا يبدأ بالترقيم إلا إذا قمنا بإعطاء الصورة الاولى رقما معيناوبعدها يبدأ البرنامج بالترقيم بناء على هذا الرقم فإذا وضعنا الصورة الأولى بالرقم 1 يكون رقم الصورة الثانية هو 2 وإذا كانت الصورة الاولى 50 تكون الصورة الثانية 51 وهكذا

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

عذرا على الإطالة

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

تم تعديل ديسمبر 13, 2012 بواسطه ابو تميم

**الـعيدروس** · ديسمبر 14, 2012

السلام عليكم

هذه الأسطر إحذفها من الكود

وإن شاء الله يزبط معك


If Dir(Path_F & A_M & ".jpg") <> "" Then

  Kill Path_F & A_M & ".jpg"

End If

تقبل تحياتي وشكري

ابو تميم · ديسمبر 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

الاستاذ الحبيب عبدالله المجرب

اشكرك على مرورك الكريم

وكلماتك الطيبه

**احمدزمان** · أبريل 11, 2013

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

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

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

وخاصة ان 2007 لاتوجد به هذه الخاصية التي كانت موجودة في 2003

ادراج صورة من الماسح الضوئي

ابو تميم الله يجزاك الف خير على الفكرة

و الأستاذ الكبير ابو نصار الله يجزاك الف خير على التنفيذ

بارك الله فيكم

**احمدزمان** · أبريل 19, 2013

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

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

لي طلب على الرابط

http://www.officena.net/ib/index.php?showtopic=46533

بحيث يتم ادراج الصورة في نفس ورقة اكسل

ابو تميم · فبراير 3, 2014

تحية طيبة

هل عمل معكم الكود على ويندوز XP

حيث أنه يعمل معي بشكل أكثر من ممتاز على ويندوز 7 ولكنه لا يعمل على XP

**احمدزمان** · فبراير 7, 2014

تحية طيبة

هل عمل معكم الكود على ويندوز XP

حيث أنه يعمل معي بشكل أكثر من ممتاز على ويندوز 7 ولكنه لا يعمل على XP

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

اخي ابو تميم

الكود شغال معي على كل الأوفيس

آسف على التأخير

ولكن كنت مسافر في الخارج و اليوم عدة من السفر

ابو تميم · فبراير 7, 2014

تحية طيبة

هل عمل معكم الكود على ويندوز XP

حيث أنه يعمل معي بشكل أكثر من ممتاز على ويندوز 7 ولكنه لا يعمل على XP

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

اخي ابو تميم

الكود شغال معي على كل الأوفيس

آسف على التأخير

ولكن كنت مسافر في الخارج و اليوم عدة من السفر

شكرا جزيلا أخي العزيز احمد زمان

أنا لا أقصد الأوفيس ولكني أقصد الويندوز XP فإنا أجرب العمل على الملف على ويندوز7 مع أوفيس 2010 أو أوفيس 2007 ويعمل معي الكود بشكل ممتاز

ولكني عندما أنقل الملف إلى ويندوز XP مع أوفيس 2010 أو أوفيس 2007 فإنه لا يعمل معي ويعطيني رسالة خطا على wia

**احمدزمان** · فبراير 8, 2014

اخي العزيز

انا الكود الآن يشتغل معي على جهازين استخدمهما باستمرار

عمل معي على جهاز XP و جهاز ويندوز7

**محمود_الشريف** · فبراير 8, 2014

أخى فى الله

أستاذى القدير / أحمد زمان

بارك الله فيكم

وحمد لله على سلامتكم

=============

فعلا الكود يعمل على جميع أنواع الويندوز

=============

أخى ابو تميم

راجع تسطيب الإسكانر الخاص بك على الجهاز او قم بتسطيبها من جديد

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

============

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

تسجيل الدخول

استدعاء الإسكانر من الاكسل

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

ابو تميم

ابو تميم

الـعيدروس

ابو تميم

الـعيدروس

ابو تميم

أستيكا

الـعيدروس

ابو تميم

الـعيدروس

ابو تميم

الـعيدروس

ابو تميم

الـعيدروس

ابو تميم

أبو أنس حاجب

عبدالله المجرب

الـعيدروس

احمدزمان

احمدزمان

ابو تميم

احمدزمان

ابو تميم

احمدزمان

محمود_الشريف

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information