vba legge nominativi da un foglio excel e crea vcard per importazione rubrica telefono

'

Option Explicit

'

'  vba legge nominativi da un foglio excel e crea vcard per importazione rubrica telefono

'

Public Const cartella = "C:\telefoni\vcard\"

'

Public ragionesociale, cellulare

'

Public LASTNAME, FIRSTNAME, MOBILE

Public ADDRESS1, CITY, POSTALCODE, COUNTRY

'

Sub LeggiFoglioCreaVcard()

Dim quanterighe, contarighe, foglio, psContactID, esito

Set foglio = Sheets(ActiveSheet.Name)

'

Dim dblog, slog

dblog = cartella & "report-test-2008.vcf"

'

Dim colonnaragionesociale, colonnanumeromobile

colonnaragionesociale = "C"

colonnanumeromobile = "B"

'

Dim sFileName

sFileName = cartella & "rubrica-2008.vcf"

'

quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

'

contarighe = 2

While contarighe <= quanterighe

      psContactID = foglio.Cells(contarighe, colonnaragionesociale).Value ' ragione sociale

      psContactID = Replace(psContactID, ".", "")

'

      LASTNAME = foglio.Cells(contarighe, colonnaragionesociale).Value    ' ragione sociale

      FIRSTNAME = foglio.Cells(contarighe, colonnaragionesociale).Value   ' ragione sociale

      MOBILE = foglio.Cells(contarighe, colonnanumeromobile).Value      ' numero di cellulare

'

'

      Call preparavcf(sFileName)

      '

      If contarighe = 2 Then

         Call preparavcf(dblog)

      End If

      '

'

      contarighe = contarighe + 1

Wend

'

End Sub

'

Sub preparavcf(pfile)

'

Dim fVCardFile

'

fVCardFile = ""

fVCardFile = fVCardFile & "BEGIN:VCARD" & vbCrLf

fVCardFile = fVCardFile & "VERSION:2.1" & vbCrLf

fVCardFile = fVCardFile & "N:" & LASTNAME & ";" & FIRSTNAME & vbCrLf

fVCardFile = fVCardFile & "FN:" & FIRSTNAME & " " & LASTNAME & vbCrLf

'  fVCardFile = fVCardFile & "ORG:" & "ACCOUNT") & vbCrLf

'  fVCardFile = fVCardFile & "TITLE:" & "TITLE") & vbCrLf

'  fVCardFile = fVCardFile & "TEL;WORK;VOICE:" & "WORKPHONE".Value) & vbCrLf

'  fVCardFile = fVCardFile & "TEL;WORK;FAX:" & "FAX") & vbCrLf

'  fVCardFile = fVCardFile & "TEL;HOME;VOICE:" & "HOMEPHONE") & vbCrLf

'  fVCardFile = fVCardFile & "TEL;CELL:" & MOBILE & vbCrLf

'

fVCardFile = fVCardFile & "TEL;TYPE=WORK,MSG:+39" & MOBILE & vbCrLf

'

'  fVCardFile = fVCardFile & "EMAIL;WORK:" & "EMAIL" & vbCrLf

fVCardFile = fVCardFile & "ADR;HOME:;;" & ADDRESS1 & ";" & CITY & ";;" & POSTALCODE & ";" & COUNTRY & vbCrLf

fVCardFile = fVCardFile & "END:VCARD" & vbCrLf

'

Call ScriviFileJollyAppend(pfile, fVCardFile)

'

End Sub

'

' ==================

'

Sub ScriviFileJollyAppend(pNomeArchivio, pcosascrivere)

Dim fso, rifefile

Set fso = CreateObject("Scripting.FileSystemObject")

If (fso.FileExists(pNomeArchivio)) Then

      'msg = filespec & " esiste."

       Set rifefile = fso.OpenTextFile(pNomeArchivio, 8)

Else

      'msg = filespec & " Non esiste."

       Set rifefile = fso.CreateTextFile(pNomeArchivio, True)

End If

rifefile.WriteLine (pcosascrivere)

rifefile.Close

Set rifefile = Nothing

End Sub

'

' =========

'