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

[ابو تميم]

تحية طيبة

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

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

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

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

scan2Excel1111.rar

[ابو تميم]

up

[الـعيدروس]

السلام عليكم

أولا اذاهب الى محرر الأكواد قائمة 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 بواسطه ابو تميم

[الـعيدروس]

السلام عليكم

اخي ابو تميم

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

يبحث عن مسميات المجلدات الاكبر اذا المجلدت مسمى رقمي ؟؟؟

[ابو تميم]

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

أقصد بأكبر رقم أني أريد ترتيب الصور بأرقام وليس بالاسم My_Img بحيث تكون هذه الصور أي أنه كلما تم إضافة صورة جديدة يتم البحث في المجلد عن أرقام الصور وتسمية الصورة الجديدة حسب تسلسل هذه الأرقام ويبحث عن أكبر رقم موجود ويعطي الصورة الجديدة الرقم الاكبر +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(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#

[ابو تميم]

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

جربت الكود

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

.Properties("6152").Value = 1167

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

x(i) = M_v(i)

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

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

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

[الـعيدروس]

عذرا على هذا الخطاء

ارجو تجربة الكود بعد التعديل

اما خطاء الكود في التقاط الصور من الاسكنار

لم تتضح المشكلة من وين

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

جرب الكود بعد التعديل

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

ومعك إن شاء الله إلى أن يعمل بشكل سليم

تحياتي

[ابو تميم]

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

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

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

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

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

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

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

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

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

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

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

[الـعيدروس]

السلام عليكم

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

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

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

  Kill Path_F & A_M & ".jpg"

End If

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

[ابو تميم]

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

التعديل لم يفلح في إصلاح المشكلة

ولكني قمت بتعديل الأسطر التالية من الكود وهي التي كانت سبب مشكلة الترقيم عند اول صورة وهو الآن يعمل بشكل ممتاز جدا وابتداء من أول صورة

الأسطر بعد التعديل تصبح كما يلي :

If Ar_Max = 0 Then

A_M = Ar_Max + 1

Else

Ar_Max = 1

A_M = Ar_Max + 1

End If

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

جزاكم الله خيرا أستاذنا القدير ابو نصار وكفاكم شر أبناء السوء ورزقكم ما تتمنون بالحلال والخير

غفر الله لنا ولكم .... جمعة مباركة إن شاء الله

نراكم قريبا إن شاء الله

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

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

[الـعيدروس]

الحمد لله

السموحه منك

انا ليس لدي اسكنر ولا كنت جربت الكود

وعرفت اين تكمن المشكله

تحياتي

[ابو تميم]

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

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

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

جزاكم الله خيرا وأكثر من أمثالكم

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

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

[أبو أنس حاجب]

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

آمييييييييييييييييييييييييييييييييييييييييييييييييييييييييين يارب العالمين.

أسف لم أستطع أكتب أكثر من ذلك.

أبو أنس

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

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

[الـعيدروس]

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

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

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

[احمدزمان]

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

 

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

 

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

 

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

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

 

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

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

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

[احمدزمان]

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

 

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

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

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

 

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

 

[ابو تميم]

تحية طيبة

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

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

[احمدزمان]

تحية طيبة

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

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

 

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

اخي ابو تميم 

 

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

 

 

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

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

[ابو تميم]

 

تحية طيبة

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

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

 

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

اخي ابو تميم 

 

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

 

 

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

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

 

 

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

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

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

[احمدزمان]

اخي العزيز 

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

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

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

أخى فى الله

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

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

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

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

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

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

أخى ابو تميم 

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

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

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

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