|
Posto la mia soluzione
Dim strsql As String
Dim olkAddressList As Outlook.AddressEntry
Dim ns As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set ns = GetNamespace("MAPI")
Set objFolder = ns.PickFolder
Dim obj As Outlook.MailItem
Dim olKList As Outlook.AddressList
Dim intCounter As Integer
Set adoConn = CreateObject("ADODB.Connection")
Set adors = CreateObject("ADODB.Recordset")
adoConn.Open "DSN=DatiOutlook;"
Cartella = objFolder
Label1.Caption = "Nome contatto: " & objFolder & " con " & objFolder.Items.Count & " elementi."
adors.Open "SELECT * FROM email", adoConn, adOpenDynamic ', adLockBatchOptimistic
For intCounter = objFolder.Items.Count To 1 Step -1
With objFolder.Items(intCounter) 'Print the
' se ci sono i segni ' allora li devo sostituirecon gli spazi
Nomecont = .FullName: List1.AddItem .FullName
If TestPos <> InStr(1, Nomecont, "'") Then Nomecont = Replace(Nomecont, "'", "")
Emailcont = .Email1Address: List1.AddItem .Email1Address
If TestPos <> InStr(1, Emailcont, "'") Then Emailcontt = Replace(Emailcont, "'", "")
IndirizzoCont = .HomeAddress: List1.AddItem .HomeAddress
If TestPos <> InStr(1, IndirizzoCont, "'") Then IndirizzoCont = Replace(IndirizzoCont, "'", "")
TelefonoCont = .HomeTelephoneNumber: List1.AddItem .HomeTelephoneNumber
If TestPos <> InStr(1, TelefonoCont, "'") Then TelefonoCont = Replace(TelefonoCont, "'", "")
CellulareCont = .MobileTelephoneNumber: List1.AddItem .MobileTelephoneNumber
If TestPos <> InStr(1, CellulareCont, "'") Then CellulareCont = Replace(CellulareCont, "'", "")
End With 'for the Contact with
If Emailcont <> "" Then
' adesso devo scrivere sul DB
strsql = "INSERT INTO email " & _
"(CartellaContatti,Nome,Email,Telefono,Cellulare,Indirizzo)" & _
"VALUES " & _
"('" & Cartella & "','" & Nomecont & "','" & Emailcont & "','" & TelefonoCont & "','" & CellulareCont & "','" & IndirizzoCont & "')"
adoConn.Execute strsql 'scrivo sul file del db
End If
Next
adors.Close
Set adors = Nothing
Set adoConn = Nothing
Set ns = Nothing
Set objFolder = Nothing
| 
