تعديل على كود حفظ مكان الصورة

[bakry kassala]

بعد التحية لكم اساتذتي الكرام ..

 

 

الكود التالي يعمل 100% ولله الحمد ولكن يحفظ الصورة بعد مسحها (scan) داخل مجلد photo والمطلوب الحفظ في مجلد فرعي داخل مجلد photo 

 

علماً بان المجلد الفرعي مسمى بالرقم الوظيفي للموظف .. حيث لكل موظف مجلد فرعي يحتوي على صور وارشيف الموظف المحدد حسب id

 

ارجو شاكراً التعديل على الكود ليحفظ الصورة في المجلد الفرعي داخل مجلد صور الموظفين الموجود في مجلد البرنامج الرئيس ..

Set img = CreateObject("wia.commondialog").ShowAcquireImage.SaveFile(Application.CodeProject.Path & "\photo\" & "\\" & [id] & ".jpg")

كما في الكود

بحيث  ...

id هو اسم الصورة حسب حقل الرقم الوظيفي للموظف

photo هو المجلد الرئس لصور البرنامج 

 

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

 

مثلاً إذا كان اسم الصورة aa.jpg  فإن اسم المجلد الفرعي aa 

 

اتمنى اكون قدرت اوصل الفكرة ..

 

شاكر ومقدر لكم ... 

[jjafferr]

وعليكم السلام 

 

 

كود الاخ رمهان هو عبارة عن مجموعة اسطر مدمجة في سطر واحد:

Set img = CreateObject("wia.commondialog")
Image_Path = (Application.CodeProject.Path & "\photo\" & "\\" & [id] & ".jpg")
img.ShowAcquireImage.SaveFile Image_Path

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

 

 

طلبك هو:

 (4) ليحفظ الصورة في (3) المجلد الفرعي داخل (2) مجلد صور الموظفين الموجود في (1) مجلد البرنامج الرئيس 

Set img = CreateObject("wia.commondialog")

'1
Image_Path = Application.CurrentProject.Path
'2
Image_Path = Image_Path & "\photo\"
'3
Image_Path = Image_Path & "\" & [id] & "\"
'4
Image_Path = Image_Path & [id] & ".jpg"

img.ShowAcquireImage.SaveFile Image_Path

وللعلم ، فالصورة التي يحفظها الكود ليست jpg وانما bmp (كما اوضحتها انا هنا http://www.officena.net/ib/index.php?showtopic=61540&p=399567 )

 

 

جعفر

تم تعديل يونيو 1, 2015 بواسطه jjafferr

[bakry kassala]

اشكرك من قلبي استاذي الحبيب جعفر

على هذه الاجابة الوافية والشافية ...

 

تمت المهمة بفضل من الله ...

ثم باجابة من خبير نفتخر به ..

[bakry kassala]

استاذي الفاضل جعفر 

تحياتي ..

رجعت لك مرة أخرى لتعديل آخر على الكود اعلاه ..

 

في حالة عمل مسح (scan) للصورة وكانت هناك صورة أخرى تحمل ذات الاسم في المجلد الفرعي 

ارغب في التعديل بالاضافة على الكود بحيث يتم تعديل اسم الصورة الموجودة الى aa_img.jpg

لتحل محلها الصورة الجديدة بالاسم aa.jpg وهو الـ id كما في الكود دون تغيير ..

Set img = CreateObject("wia.commondialog").ShowAcquireImage.SaveFile(Application.CodeProject.Path & "\photo\" & "\" & [id] & "\" & [id] & ".jpg")

مع كامل احترامي ..

تم تعديل يونيو 1, 2015 بواسطه bakry kassala

[jjafferr]

واذا كانت عندك الصورة aa_img.jpg  في المجلد ، فماذا تريد ان تفعل؟

 

اقتراحي ان يكون هناك عدد تسلسلي من رقمين مثل:

aa_01.jpg

aa_02.jpg

 

بحيث لأقدم دائما يكون عنده الرقم الاكبر !!

 

ايش رايك؟

طلبك اسهل واجد من اقتراحي   

 

وبعدين عندي سؤال للعلم:

انا سهلت لك العمل في عدة اسطر ، ليش رجعتها سطر واحد؟؟

 

 

جعفر

[bakry kassala]

وهو كذلك استاذي جعفر فكرتك الأفضل للعمل aa.01.jpg ..

 وتدل على الخبرة والتجربة لأني سأحتاجها بعد أن تكثر الصور في المجلد وعندها لن تفلح التسمية aa_img.jpg

بارك الله فيك وفي علمك ..

 

وسوف استخدم الكود المختصر بعد التعديل الجاري .. بإذن الله

[jjafferr]

تفضل 

 

والكود يعمل المجلدات الغير موجودة تلقائيا 

 

الكود اصبح:

Private Sub cmd_scan_Click()
On Error GoTo err_cmd_scan_Click

    Dim Image_Path As String
    
    

    Set img = CreateObject("wia.commondialog")

   '1
    Image_Path = Application.CodeProject.Path
    
   '2
    Image_Path = Image_Path & "\photo\"
    'if the photo Dir dose not exist, creat it
    If Dir(Image_Path, vbDirectory) = "" Then
        MkDir Image_Path
    End If
    
   '3
    Image_Path = Image_Path & "\" & [ID] & "\"
    'if the [id] Dir dose not exist, creat it
    If Dir(Image_Path, vbDirectory) = "" Then
        MkDir Image_Path
    End If
    
    
    
    'check the Dir for the file existance
    How_Many_Files_Exist = FileList(Image_Path, [ID] & "_*.jpg")
        
    'Rename the old existing file
    Old_File_Name = Image_Path & [ID] & ".jpg"
    New_File_Name = Image_Path & [ID] & "_" & Format(How_Many_Files_Exist + 1, "00") & ".jpg"
    Name Old_File_Name As New_File_Name

   
   '4
    Image_Path = Image_Path & [ID] & ".jpg"
    
    img.ShowAcquireImage.SaveFile Image_Path


Exit Sub
err_cmd_scan_Click:

    If Err.Number = 53 Then
        'file not found
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Sub


Function FileList(iPath_In As String, iCondition As Variant, Optional iItemsList As Control)
    
    'to call this sub:
    'call FileList(iPath_In, iCondition, iItemsList)
    'iPath_In   : folder path
    'icondition : "*.pdf" or "*.jpg" or "*.*"
    'iItemsList : file list separated by ;
    '
    
    Dim fdr As String
    Dim File_Count As Integer
    
    'clear the list
'    iItemsList.RowSource = ""
    
    'get the jpg files from the Forlder
    fdr = Dir(iPath_In & "\" & iCondition)
    Do While fdr <> ""
'        iItemsList.AddItem Item:=fdr
        File_Count = File_Count + 1
        fdr = Dir
    Loop
    
'    Me.List_Count = iItemsList.ListCount
    FileList = File_Count
    
End Function

جعفر

Scan.zip

[bakry kassala]

اخي واستاذي جعفر ..

بارك الله فيك وشكراً جميلاً وتقديراً على مجهودك الكبير في هذا العمل ..

عسى أن ينفع الله به الكثير من طلاب العلم ..

 

لكن استاذي شوية شوية على أخوك .. واااحده واحده ..

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

حملت المرفق ولم يعمل لفقدان الملف  ezvidC60.ocx

كما اختلفت المسميات ..

 

خلينا نرجع للكود الاول ..

ونضيف له تعديل اسم الصورة القديمة كما تفضلت aa_01.jpg لأن عرض الصورة مرتبط باسم حقل الرقم الوظيفي للصورة الحديثة aa.jpg

 

وحاول مع الشكر اعادة تفصيل الكود والشرح عليه لتعم الفائدة 

 

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

 

 

[jjafferr]

أعتذر عن هذا الخطأ ،

فلقد استخدمت برنامج سابق واضفت عليه ، ولم انتيه 

 

ماعليك من شئ ، مجرد جرب المرفق الجديد ، وبعدين نتكلم اذا عندك استفسار 

 

لا تعمل اي مجلدات رئيسية او فرعية ،

مجرد افتح البرنامج ، اضغط على scan ، وشوف الصورة في النموذج وفي المجلد ،

واضغط على scan مرة ثانية ، وشوف الصورة في النموذج وفي المجلد ، وبعدين اسال ، اذا عندك سؤال 

 

 

جعفر

Scan.zip

تم تعديل يونيو 2, 2015 بواسطه jjafferr

[bakry kassala]

100/100 وكفى .. أستاذي ...

 

لكن لا أعفيك من وضع تفاصيل شرح على الكود .. 

ارجو تلبية ذلك حتى تكتمل الصورة بارك الله فيك 

تعبتك معي لكن جزاك عند الله كثير .. بارك الله فيك ..

[bakry kassala]

استاذي جعفر 

 

باقي حاجة بسيطة ويكتمل البدر بإذن الله - جزاك الله خير ..

 

ركز معي ..( على طريقة الاستاذة زهرة بارك الله فيها اينما كانت )

مثلاً :

هناك مجلد فرعي جاهز لموظف ولكن بدون صورة داخله ..

عند البحث عن هذا الموظف الذي لا توجد لديه صور داخل مجلده تأتي هذه الرسالة ...

---------------------

2101

الاعداد الذي ادخلته لهذه الخاصية غير صحيح .

----------------------

 

وهناك حالة أخرى وهي عند الانتقال بالبحث عن سجل ليس لديه صورة تظل الصورة السابقة في العرض لهذا السجل ايضاً ..

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

علماً بأنني استخدم مربع_تحرير_وسرد عادي للبحث في حقل الـ id

وجزاك الله عني كل خير ..

 

تعبتك معي .. تقبل اعتذاري ..

تم تعديل يونيو 2, 2015 بواسطه bakry kassala

[jjafferr]

الله يطول في عمرك أخوي 

 

مثال ، وعملت من عندي ، والحمدلله 

لكن ، صحيح اني عماني ، لكن سحري بعده مو قوي اللي اقدر اجيب برنامجك: واشغله ، واشوف وين النموذج ، واجرب مربع تحرير وسرد ، وعلى اي حدث تيجي الرسالة ، وكيف مانخلي الصورة تتكرر ، وووو

 

عندك حلين:

1. يا انك تصبر الى ان اقوي سحري ، واقدر اوصل اجيب برنامجك من كمبيوترك لعندي ، وبعدين اشتغل عليه ،

2. او ان ترفق برنامجك.

 

وانت صاحب القرار 

 

 

اما علمي فيقول:

على الحدث اللي يبحث فيه مربع_تحرير_وسرد ، وانا بسميه iSearch فاعمل التالي:

private sub iSearch_After_Update
on error goto err_iSearch_After_Update

الكود حقك يكون هنا


    'show the new image in the Form
    Call Form_Current
    

Exit Sub
err_iSearch_After_Update:

    If Err.Number = 2101 Then
        '
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Sub

واعتقد سبب الخطأ:

هل انت كاتب مسار الصورة في الجدول ؟

الظاهر ان عندك مسار خطأ وهو عامل المشكلة !!

 

 

 

جعفر

[محمد سلامة]

الله عليك استاذي جعفر

بارك الله فيك

[bakry kassala]

اخي واستاذي جعفر ...

الساحر الذي لم يرى برنامجاً ولكنه بسحره أنجز كل المطلوب في براعة خبير محترف لا يبخل بعلمه

ما شاء الله تبارك الله ..

بارك الله فيك جعفر وزادك علما على علمك ..

 

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

فشكراً جميلاً ودعوات صالحات لك أخي على المجهود المقدر والمساعدة لي ولغيري ...

 

[jjafferr]

حياك الله 

[bakry kassala]

الاستاذ الفاضل جعفر - لك التحية والتقدير ..

عدنا بعد طول غياب ..

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

حيث لا يقبل المسح الضوئي للصور اكثر من صورتين (2) فقط للموظف في داخل مجلده الفرعي ..

واذا تذكر اتفقنا على أن يستمر مسمى الصور aa_1 ثم aa_2 عند إضافة صورة جديدة 

وكان الوضع سليماً حتى اتت الحاجة ليكون لديه اكثر من صورتين داخل الملف والرسالة : 58 file already exists

أرجو استاذي الفاضل ان يكون عدد الصور لا نهائي وغير محدد .

كما أرجو ملاحظة ان مسمى الحقل (id) تغير الى (code) لأنني حجزت الاول لرقم الهوية ..

وإنني استخدم حالياً office2013

شاكر لك ومقدر استاذي جعفر

 

Private Sub cmd_scan_Click()
On Error GoTo err_cmd_scan_Click

    Dim Image_Path As String
    
    Set img = CreateObject("wia.commondialog")

   '1
    Image_Path = Application.CodeProject.Path
    
   '2
    Image_Path = Image_Path & "\photo\"
    'if the photo Dir dose not exist, creat it
    If Dir(Image_Path, vbDirectory) = "" Then
        MkDir Image_Path
    End If
    
   '3
    Image_Path = Image_Path & [code] & "\"
    'if the [code] Dir dose not exist, creat it
    If Dir(Image_Path, vbDirectory) = "" Then
        MkDir Image_Path
    End If
    
 
    'check the Dir for the file existance
    'How_Many_Files_Exist = FileList(Image_Path, [code] & "\" & [code] & "_*.jpg")
        
    'Rename the old existing file
    Old_File_Name = Image_Path & [code] & ".jpg"
    New_File_Name = Image_Path & [code] & "_" & Format(How_Many_Files_Exist + 1, "00") & ".jpg"
    Name Old_File_Name As New_File_Name

   
   '4
    Image_Path = Image_Path & [code] & ".jpg"
    
    img.ShowAcquireImage.SaveFile Image_Path

    'show the new image in the Form
    Call Form_Current
    

Exit Sub
err_cmd_scan_Click:

    If Err.Number = 53 Then
        'file not found
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
End Sub

 

[bakry kassala]

الاساتذه الكرام ...

هل من مجيب ..

 

[bakry kassala]

ليس خروجاً ولكن مجرد سؤال .. أسأل أين اساتذتي الكرام ..

رمهان

جعفر

ابوخليل 

وووووو القائمة تطول ....

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

اين انتم ايها المعلمين نفتقدكم كتيراً ..

 

* ملاحظة أرجو من الادمن تداركها ..

كل المرفقات لا يمكن تحميلها .. لعل هذا نتيجة التحديث للاصدار الجديد ... حاول تحديث الجداول من لوحة التحكم للموقع ...

[ابوخليل]

بارك الله فيك

1- الموضوع قديم  وصاحبه غير متواجد الآن  وهو الاولى بالرد عليك

2- لايوجد مرفقات

3- تستخدم اوفيس 2013

 هذه الامور  هي السبب في عدم الرد عليك من الاخوة الزملاء

ارى ان تفتح موضوعا بعنوان جديد مرفقا ملفاتك وطلبك فلعلك تجد من يمد لك يد المساعدة

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

يغلق ،،،

[رمهان]

اخينا بكري

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

لي عودة وبفكرة اخرى وبعد اذن الغائب الحاضر الاستاذ جعفر..

تحياتي