تعديل على كود تحويل ملف الى اكسل

[ABOUOMER]

If Dir("\\PC1689\Ras Laffan Common Folder\Report\SupplyDetailed.csv") = "" Then
MsgBox "file SupplyDetailed.csv not found", vbCritical
DoCmd.CancelEvent
Exit Sub
End If
    Dim TextLine, File_Name, File_ext, Folder_Name, nFile_Name
   
    File_Name = Dir(Me.txtPath)                             'the file name only
    File_ext = Mid(File_Name, InStrRev(File_Name, ".") + 1) 'the file extension
    Folder_Name = Replace(Me.txtPath, File_Name, "")        'the folder name
   
    'a temp csv file to transfer to it the correct lines
    nFile_Name = Folder_Name & Mid(File_Name, 1, Len(File_Name) - Len(File_ext) - 1) & "_2." & File_ext
   
    'open both Input and Output files
    Open Me.txtPath For Input As #1
    Open nFile_Name For Output As #2
   
    i = 0
    Do While Not EOF(1)    ' Loop until end of file.
        Line Input #1, TextLine    ' Read line into variable.
        i = i + 1
       
        'skip the 1st 3 lines, and write the rest
        If i >= 1 Then
            Print #2, TextLine
        End If
       
    Loop
   
    Close #1
    Close #2
   
   
    'now we have a csv file correctly saved,
    'convert it to xls
   
    'make reference to Microsoft Excel xx.x object Library
   
    Dim wBook As workbook
   
    Set wBook = Workbooks.Open(nFile_Name, Format:=6, Delimiter:=",")
    wBook.SaveAs Replace(Me.txtPath, ".csv", ".xls"), FileFormat:=xlExcel8
    wBook.Close False
   
    'delete the temp cvs file
    Kill nFile_Name
 

 

 

الاخ الفاضل جعفر

نحية طيبة وبعد

الكود السابق من من تصميمك

وهو خاص بتحويل ملف csv

الى اكسل بعد حذف سطر  واحد فقط

المشكلة انة تظهر رسالة فى حالة وجود ملف سابق  ويظهر ملف بصيغة csv

مرقم برقم 2 ولا يمكن حذفة الا بعد عمل اعادة تشغيل للجهاز 

هل يمكن تحويل الملف الى اكسل  وحذف الاسطر المطلوبة بدون ظهور هذة الرسالة  وحتى  فى حالة وجود ملف سابق

تحياتى

 

[jjafferr]

6 ساعات مضت, ABOUOMER said:

1. الكود السابق من من تصميمك ، وهو خاص بتحويل ملف csv ، الى اكسل بعد حذف سطر  واحد فقط

2. المشكلة انة تظهر رسالة فى حالة وجود ملف سابق 

3. ويظهر ملف بصيغة csv مرقم برقم 2 ولا يمكن حذفة الا بعد عمل اعادة تشغيل للجهاز 

4. هل يمكن تحويل الملف الى اكسل  وحذف الاسطر المطلوبة بدون ظهور هذة الرسالة  وحتى  فى حالة وجود ملف سابق

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

 

1. ياريت تعطينا الرابط ، حتى اعرف خلفيته ، واستعمل الكود كاملا لتغييره حسب طلبك ،

2. الاسطر الخمسة الاولى في الكود هي التي تقوم بالتحقق من هذا الملف ، يمكنك حذفها للتجربة ،

3. ارى في الكود انه تم اغلاق صفحة الاكسل ، ولم يتم اغلاق برنامج الاكسل ، مما يؤدي الى قفل ملف csv لأنه رهن العمل (ادخل في Task Manager وشوف اذا الاكسل مفتوح ، اغلقه ، وبعدين بتقدر تحذف الملف رقم2) ،

4. جرب اللي اخبرتك اعلاه ، واخبرنا النتيجة ، وعليه نقدر نقوم بالخطوة التالية ، وهو تغيير الكود ليقوم بالعمل تلقائيا

 

جعفر

[ABOUOMER]

تفضل اخى

298.Remove_3_Lines_csv.mdb.zip

[ABOUOMER]

الاكسل لا يزال  مفتوحا اخى الكريم وموجود فى

Task Manager

[jjafferr]

السلام عليكم

 

الكود الجديد سيغلق الاكسل ، ويقوم بحذف الملف رقم 2

بدل هذا الكود
'make reference to Microsoft Excel xx.x object Library
   
    Dim wBook As workbook
   
    Set wBook = Workbooks.Open(nFile_Name, Format:=6, Delimiter:=",")
    wBook.SaveAs Replace(Me.txtPath, ".csv", ".xls"), FileFormat:=xlExcel8
    wBook.Close False


استخدم هذا

    'now we have a csv file correctly saved,
    'convert it to xls
       
    Dim objXLApp As Object
    Dim wBook As Object
    
    Set objXLApp = CreateObject("Excel.Application")
    Set wBook = objXLApp.Workbooks.Open(nFile_Name, Format:=6, Delimiter:=",")
    wBook.SaveAs Replace(Me.txtPath, ".csv", ".xls"), FileFormat:=xlExcel8
    wBook.Close 'False
    
    objXLApp.Quit
    Set wBook = Nothing
    Set objXLApp = Nothing

 

جعفر

862.298.Remove_3_Lines_csv.mdb.zip

[ABOUOMER]

اخى  الكريم جعفر

المطلوب  منع ظهور الرسالة الخاصة باستبدال الملف واستبدالة تلقائيا

شكرا جزيلاا

[jjafferr]

المرفق ما فيه رساله اصلا

[ABOUOMER]

شاهد اخى الكريم

 

[jjafferr]

اها

دقيقة

 

الكود الجديد اصبح

Private Sub cmd_Remove3_Click()
On Error GoTo err_cmd_Remove3_Click

    Dim TextLine, File_Name, File_ext, Folder_Name, nFile_Name
    
    File_Name = Dir(Me.txtPath)                             'the file name only
    File_ext = Mid(File_Name, InStrRev(File_Name, ".") + 1) 'the file extension
    Folder_Name = Replace(Me.txtPath, File_Name, "")        'the folder name
    
    'a temp csv file to transfer to it the correct lines
    nFile_Name = Folder_Name & Mid(File_Name, 1, Len(File_Name) - Len(File_ext) - 1) & "_2." & File_ext
    
    'open both Input and Output files
    Open Me.txtPath For Input As #1
    Open nFile_Name For Output As #2
    
    i = 0
    Do While Not EOF(1)    ' Loop until end of file.
        Line Input #1, TextLine    ' Read line into variable.
        i = i + 1
        
        'skip the 1st 3 lines, and write the rest
        If i >= 4 Then
            Print #2, TextLine
        End If
        
    Loop
    
    Close #1
    Close #2
    
    
    Kill Replace(Me.txtPath, ".csv", ".xls")
    
    'now we have a csv file correctly saved,
    'convert it to xls

    Dim objXLApp As Object
    Dim wBook As Object

    Set objXLApp = CreateObject("Excel.Application")
    Set wBook = objXLApp.Workbooks.Open(nFile_Name, Format:=6, Delimiter:=",")
    wBook.SaveAs Replace(Me.txtPath, ".csv", ".xls"), FileFormat:=xlExcel8
    wBook.Close 'False

    objXLApp.Quit
    Set wBook = Nothing
    Set objXLApp = Nothing
    
    
    'delete the temp cvs file
    Kill nFile_Name


Exit_cmd_Remove3_Click:
    Exit Sub

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

 

جعفر

 

 

 

862.298.Remove_3_Lines_csv.mdb.zip

[ABOUOMER]

نسخة مضغوطة ZIP

[jjafferr]

اصلحت المرفق السابق

[ABOUOMER]

اشتغل اول مرة  بنجاح

ولكن عن تشغيلة مرة اخرى ظهرت الرسالة التالية

    On Error Resume Next

 

تمت اضافة السطر السابق  وانحلت المشكلة

    Kill Replace(Me.txtPath, ".csv", ".xls")
   
    'now we have a csv file correctly saved,
    'convert it to xls

    Dim objXLApp As Object
    Dim wBook As Object

    Set objXLApp = CreateObject("Excel.Application")
    Set wBook = objXLApp.Workbooks.Open(nFile_Name, Format:=6, Delimiter:=",")
    wBook.SaveAs Replace(Me.txtPath, ".csv", ".xls"), FileFormat:=xlExcel8
    wBook.Close 'False

    objXLApp.Quit
    Set wBook = Nothing
    Set objXLApp = Nothing
   
   
    'delete the temp cvs file
    Kill nFile_Name

سلمت يداك اخى العزيز جعفر

زاداك الله من علمة ونفع بك

[jjafferr]

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

 

إحترافياً ، الامر On Error Resume Next يجب استخدامه في حالات خاصة وضيقة جداً (طبعا حالتك كانت خاصه علشان تحصل على الجواب السريع) ، 

لأن الامر يوقف جميع رسائل الخطأ ، والتي بعضها ضروري لمعرفة ماهية الخطأ ، ومن ثم معالجته.

 

قمت بالتعديل على الملف المرفق ، والذي يصطاد الخطأ (وفي حالتنا ، البرنامج اخبرنا بأن رقم الخطأ هو 53):

Private Sub cmd_Remove3_Click()    
On Error GoTo err_cmd_Remove3_Click

    ....
    ....
    
    'delete the temp cvs file
    Kill nFile_Name


Exit_cmd_Remove3_Click:
    Exit Sub

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

.

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

 

جعفر

 

[ABOUOMER]

كود الخطا لم يعمل معى

انا وصعت  الكود عند دبل كليك  على صورة

Image5_DblClick

 

        On Error GoTo err_Image5_DblClick:

    Kill Replace(Me.txtPath, ".csv", ".xls")
   
    'now we have a csv file correctly saved,
    'convert it to xls

    Dim objXLApp As Object
    Dim wBook As Object

    Set objXLApp = CreateObject("Excel.Application")
    Set wBook = objXLApp.Workbooks.Open(nFile_Name, Format:=6, Delimiter:=",")
    wBook.SaveAs Replace(Me.txtPath, ".csv", ".xls"), FileFormat:=xlExcel8
    wBook.Close 'False

    objXLApp.Quit
    Set wBook = Nothing
    Set objXLApp = Nothing
   
   
    'delete the temp cvs file
    Kill nFile_Name

Exit_Image5_DblClick:

    Exit Sub

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

[jjafferr]

الظاهر عندك شيء آخر في البرنامج يمنع هذا ،

لذلك لازم ترفق لي البرنامج بالكامل اذا اردت النظر فيه ،

ولكن مثل قلت انت ، مادام البرنامج اشتغل تمام ، فمافي داعي لكل هذا

 

جعفر

[ABOUOMER]

تم حل المشكلة

تحياتى