تحويل ملف اكسل الى جهات اتصال

[saffar]

السلام عليكم

في الحقيقة بحثت كثيرا في المنتدى وعلى الانترنت وجريب الكثير من الطرق ولم اصل الى حل مشكلة اللغة العربية بعد تحويل الملف من اكسل الى جهات اتصال vcard  ومن بعدها استراد الى outlook هن المكشلة اللغة العربية تظهر بالرموز 

استخدم office 365

اعداد اللغة في الجهاز اللغة العربية مع الدولة

يتم تحويل ملف اكسيل الى csv بدون مشاكل - استخدمت برنامج systools يتم تحويل جهات الاتصال vcard  بدول مشاكل 

تضهر المشكلة عند استيراد جهات الاتصال vcard الى outlook

 

[lionheart]

Attach sample of the file and the csv output. Also post the code you used to convert the data to csv file to have a look

[saffar]

تفضل المرفق

Book.rar

[lionheart]

How did you get the csv file? what is the code dis you use

or the csv file is the raw data and you need to convert the data in it to vcard

More details are required if you really need help

[saffar]

* تحويل الملف الى csv 

File - Save as - CSV UTF-8 (comma delimited) 

* استخدمت برنامج LiberOffice نفس الخطوات وعند التخزين يعطيك خيار اختيار UTF-8

* تحويل الى جهات اتصال Vcard 

استخدمت برنامج systool excel converter 

* استخدمت بعد المفات في منتدى اوفيسنا لتحويل اكسيل الى vcard

 

[lionheart]

Great. It should work well as you used UTF-8

Can you upload the systool excel conveter you used? and why didn't you use excel vba code for that purpose

Also upload sample of the desired vcard

[lionheart]

Try this code

Sub Test()
    Dim ws As Worksheet, FirstName As String, LastName As String, FullName As String, Mobile As String, HomePhone As String, BusinessPhone As String, Email As String, vCard As String, sFolder As String, sFileName As String, lr As Long, i As Long
    Application.ScreenUpdating = False
        Set ws = ActiveSheet
        lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
        sFolder = ThisWorkbook.Path & "\VCARDS\"
        If Len(Dir(sFolder, vbDirectory)) = 0 Then MkDir sFolder
        For i = 2 To lr
            With ws
                FirstName = .Cells(i, 1).Value
                LastName = .Cells(i, 2).Value
                FullName = FirstName & " " & LastName
                Mobile = .Cells(i, 3).Value
                HomePhone = .Cells(i, 4).Value
                BusinessPhone = .Cells(i, 5).Value
                Email = .Cells(i, 6).Value
            End With
            vCard = "BEGIN:VCARD" & vbCrLf
            vCard = vCard & "VERSION:3.0" & vbCrLf
            vCard = vCard & "N:" & LastName & ";" & FirstName & vbCrLf
            vCard = vCard & "FN:" & FullName & vbCrLf
            vCard = vCard & "TEL;TYPE=CELL:" & Mobile & vbCrLf
            vCard = vCard & "TEL;TYPE=CELL:" & HomePhone & vbCrLf
            vCard = vCard & "TEL;TYPE=CELL:" & BusinessPhone & vbCrLf
            vCard = vCard & "EMAIL;TYPE=INTERNET:" & Email & vbCrLf
            vCard = vCard & "END:VCARD" & vbCrLf
            sFileName = sFolder & FullName & ".vcf"
            Open sFileName For Output As #1
            Print #1, vCard
            Close #1
        Next i
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

 

[saffar]

طيب سوف ارفق الملفات

سؤال اذا تم انشاء ملفات vcard كيف يتم تصدير جميع ملفات vcard  الى Outlook مره واحد بدل ملف ملف 

[lionheart]

I didn't work on outlook but I think there must be a way to import the VCF from outlook at one shot

[saffar]

شكل البطاقة بالحقول حطيت الارقام في خانة company and job title لان اذا اضيفت في خانة ارقام الهواتف لا تظهر في برنامج Outlook للموبايل ( تحايل )

-----------

** حصلت هذا الكود شغال لاضافة جميع جهات الاتصال او البطاقات الى برنامج outlook

 

Sub OpenSaveVCard()
    
Dim objWSHShell As IWshRuntimeLibrary.IWshShell
Dim objOL As Outlook.Application
Dim colInsp As Outlook.Inspectors
Dim strVCName As String
Dim fso As Scripting.FileSystemObject
Dim fsDir As Scripting.Folder
Dim fsFile As Scripting.File
Dim vCounter As Integer
   
Set fso = New Scripting.FileSystemObject
Set fsDir = fso.GetFolder("C:\vcards")

For Each fsFile In fsDir.Files

'original code
'strVCName = "C:\vcards\" & fsFile.Name

'Zeda's fix for spaces in filenames
strVCName = """C:\vcards\" & fsFile.Name & """"

    Set objOL = CreateObject("Outlook.Application")
    Set colInsp = objOL.Inspectors
        If colInsp.Count = 0 Then
        Set objWSHShell = CreateObject("WScript.Shell")
        objWSHShell.Run strVCName
        Set colInsp = objOL.Inspectors
    If Err = 0 Then
            Do Until colInsp.Count = 1
                DoEvents
            Loop
            colInsp.Item(1).CurrentItem.Save
            colInsp.Item(1).Close olDiscard
            Set colInsp = Nothing
            Set objOL = Nothing
            Set objWSHShell = Nothing
        End If
    End If

Next

End Sub
 

 

 

st.rar

[lionheart]

No need to change the headers to get what you need. I have opened outlook on my side and imitate creating VCards and this is the new working code for the first attachment and this will save the fields properly for you

Sub Create_VCARDS()
    Dim ws As Worksheet, FirstName As String, LastName As String, FullName As String, Mobile As String, HomePhone As String, BusinessPhone As String, Email As String, vCard As String, sFolder As String, sFileName As String, lr As Long, i As Long
    Application.ScreenUpdating = False
        Set ws = ActiveSheet
        lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
        sFolder = ThisWorkbook.Path & "\VCARDS\"
        If Len(Dir(sFolder, vbDirectory)) = 0 Then MkDir sFolder
        For i = 2 To lr
            With ws
                FirstName = .Cells(i, 1).Value
                LastName = .Cells(i, 2).Value
                FullName = FirstName & " " & LastName
                Mobile = .Cells(i, 3).Value
                HomePhone = .Cells(i, 4).Value
                BusinessPhone = .Cells(i, 5).Value
                Email = .Cells(i, 6).Value
            End With
            vCard = "BEGIN:VCARD" & vbCrLf
            vCard = vCard & "VERSION:3.0" & vbCrLf
            vCard = vCard & "N:" & LastName & ";" & FirstName & vbCrLf
            vCard = vCard & "FN:" & FullName & vbCrLf
            vCard = vCard & "TEL;TYPE=CELL:" & Mobile & vbCrLf
            vCard = vCard & "TEL;TYPE=HOME:" & HomePhone & vbCrLf
            vCard = vCard & "TEL;TYPE=WORK:" & BusinessPhone & vbCrLf
            vCard = vCard & "EMAIL;TYPE=INTERNET:" & Email & vbCrLf
            vCard = vCard & "END:VCARD" & vbCrLf
            sFileName = sFolder & FullName & ".vcf"
            Open sFileName For Output As #1
            Print #1, vCard
            Close #1
        Next i
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

 

The code will create a folder with the name `VCARDS` at the same path of your workbook and it will contains all the VCFs

 

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

 

Now after creating the VCards, you can use late binding in the code you attached to export all the VCards to Outlook at one shot. I prefer to get the outlook application open before executing the code

Sub Save_VCARDS_To_OutLook()
    Dim fso As Object, fsDir As Object, fsFile As Object, objOL As Object, colInsp As Object, objWSHShell As Object, sFolder As String, strVCName As String
    sFolder = ThisWorkbook.Path & "\VCARDS"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fsDir = fso.GetFolder(sFolder)
    For Each fsFile In fsDir.Files
        strVCName = """" & sFolder & "\" & fsFile.Name & """"
        Set objOL = CreateObject("Outlook.Application")
        Set colInsp = objOL.Inspectors
        If colInsp.Count = 0 Then
            Set objWSHShell = CreateObject("WScript.Shell")
            objWSHShell.Run strVCName
            Set colInsp = objOL.Inspectors
            If Err = 0 Then
                Do Until colInsp.Count = 1
                    DoEvents
                Loop
                colInsp.Item(1).CurrentItem.Save
                colInsp.Item(1).Close olDiscard
                Set colInsp = Nothing: Set objWSHShell = Nothing
            End If
        End If
        Set objOL = Nothing
    Next fsFile
    Set fsFile = Nothing: Set fsDir = Nothing: Set fso = Nothing
    MsgBox "Done", 64
End Sub

 

[saffar]

الحقلين في company and job title

 

[lionheart]

I didn't get exactly what you mean

Generally, you can imitate the desired card by creating a card manually then to have a look at it and modify the code according to your requirement

I think you already have the solution for both creating vcards and exporting them to outlook

[saffar]

I tried to modify the code to show these two numbers in above fields it didn’t work

 

[lionheart]

I don't have any more to introduce in this topic

If you really need help, attach an excel file not csv file with some data and the desired output exactly

[saffar]

عزيزي ارفقت الملف سابقا 

وسارفق الملف بصيغة xlsx

st.xlsx

[lionheart]

Tomorrow I will have a look as I am not available now

[lionheart]

The data don't seem to be logical at all

Please attach a file with some logical data to know the real strucuture of the data