ملف اسماء مساعدة فى تصحيح كود تصدير الاسماء الى ملف VCF

[king5star]

السلام عليكم اخوانى

ما اريدة هو تعديل لكود تصدير اسماء الزوار الى ملف VCF لسهولة استدعاءة للهاتف المحمول.الكود يعمل بنجاح ولكن لاول اسم فقط ولا يقوم بتصدير باقى الاسماء الكود :

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim rst As DAO.Recordset
Dim fs, f, ts, s
'انشاء الملف فى المسار المحدد بالسطر التالى
    ActiveControl.Hyperlink.CreateNewDocument "E:\LotusNotes_VCard.vcf", True, True
' فتح الملف المصدر
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile("E:\LotusNotes_VCard.vcf")
    
    Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
' استدعاء البيانات من الجدول
Set rst = CurrentDb.OpenRecordset("Invetion")
rst.MoveFirst
Do Until rst.EOF
    ts.writeLine "begin:vcard"
    ts.writeLine "fn:" & rst![Inv_Name]
    ts.writeLine "tel;cell;voice:" & rst![Inv_Mobile]
    ts.writeLine "ts.write version:2.1"
    ts.writeLine "End: vcard"
    rst.MoveNext
Loop
' اغلاق الجدول
rst.Close
' اغلاف الملف
    ts.Close

VCard.zip

[king5star]

لقد وجت الحل تعديل الكود الى :

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim rst As DAO.Recordset
Dim fs, f, ts, s
    ActiveControl.Hyperlink.CreateNewDocument "E:\LotusNotes_VCard.vcf", True, True

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile("E:\LotusNotes_VCard.vcf")
    
    Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)

Set rst = CurrentDb.OpenRecordset("Cus_Invetion")
rst.MoveFirst
Do Until rst.EOF
    ts.writeLine "BEGIN:VCARD"
    ts.writeLine "VERSION:2.1"
    ts.writeLine "FN:" & rst![Inv_Name]
    ts.writeLine "TEL;CELL;VOICE:" & rst![Inv_Mobile]
    ts.writeLine "END:VCARD"
    rst.MoveNext
Loop

rst.Close

    ts.Close

 

[وليد حجاب]

عفوا اخي هل يعمل مع الاسماء باللغة العربية

و تظهر بدون اي مشاكل ؟؟

20 hours ago, king5star said:

لقد وجت الحل تعديل الكود الى :

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim rst As DAO.Recordset
Dim fs, f, ts, s
    ActiveControl.Hyperlink.CreateNewDocument "E:\LotusNotes_VCard.vcf", True, True

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile("E:\LotusNotes_VCard.vcf")
    
    Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)

Set rst = CurrentDb.OpenRecordset("Cus_Invetion")
rst.MoveFirst
Do Until rst.EOF
    ts.writeLine "BEGIN:VCARD"
    ts.writeLine "VERSION:2.1"
    ts.writeLine "FN:" & rst![Inv_Name]
    ts.writeLine "TEL;CELL;VOICE:" & rst![Inv_Mobile]
    ts.writeLine "END:VCARD"
    rst.MoveNext
Loop

rst.Close

    ts.Close

 

 

[king5star]

في 5/5/2018 at 11:15, وليد حجاب said:

عفوا اخي هل يعمل مع الاسماء باللغة العربية

و تظهر بدون اي مشاكل ؟؟

 

يعمل بكفاءه عاليه

[وليد حجاب]

12 hours ago, king5star said:

يعمل بكفاءه عاليه

 

 

هل بالأمكان اخي الكريم ، وضع ملف اكسل يحتوي على الكود و يكون مفعل

 

شاكر لك ردك و تعاونك ^_^

[king5star]

في 5/7/2018 at 15:25, وليد حجاب said:

 

 

هل بالأمكان اخي الكريم ، وضع ملف اكسل يحتوي على الكود و يكون مفعل

 

شاكر لك ردك و تعاونك ^_^

تفضل اخي الكريم

Convert Excel Contacts To VCF YasserKhalil Officena.xlsm

[وليد حجاب]

On 5/7/2018 at 3:43 AM, king5star said:

يعمل بكفاءه عاليه

 

بس عند وضع الاسم بالعربي ، يظهر الاسم على شكل ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟ علامات استفهام

 

[omarahmed1424]

هذا الملف شغال 100 %

Excel Contacts To VCF.xlsm

[Shereen Ahmed]

مجهود طيب بارك الله فيكم 

بس عندي استفسار 

الاسم العربي و باقي البيانات العربية تظهر علي شكل مربعات فيها علامات استفهام فكيف يمكن تصحيح هذا الخطأ 

مع الشكر