DominoArea.org [Archive]

Bjr TLm,Cmt effectuer l'exportation/Importation Lotus Notes <-> Outlook. Cordialement.

Bonjour,Export :Sub exppnaboutlook(pnab As String) Dim session As New notessession Dim db As notesdatabase Set db = session.GetDatabase("",pnab) Dim doc As notesdocument Dim exvname As String Dim exshname As String exvname = "People" Dim view As notesview Set view= db.getview (exvname) ' Set Outlook object Set Application = CreateObject("Outlook.Application") Set myNameSpace = Application.GetNameSpace("MAPI") Set myFolder = myNameSpace.GetDefaultFolder(10) Set myItem = Application.CreateItem(2) Set doc = view.getfirstdocument Do While Not (doc Is Nothing) Set myItem = Application.CreateItem(2) With myItem .FullName =doc.FirstName(0) + " " + doc.MiddleInitial(0) + " " + doc.LastName(0) .Suffix=doc.Suffix(0) .Title=doc.Title(0) .JobTitle = doc.JobTitle(0) .CompanyName = doc.CompanyName(0) .BusinessTelephoneNumber = doc.OfficePhoneNumber(0) .BusinessFaxNumber = doc.OfficeFaxPhoneNumber(0) .MobileTelephoneNumber = doc.CellPhoneNumber(0) .Email1Address = doc.MailAddress(0) .WebPage = doc.WebSite(0) If (doc.Birthday(0) <> " " And doc.Birthday(0) <> "") Then .Birthday=doc.Birthday(0) .PagerNumber=doc.PhoneNumber_6(0) .HomeTelephoneNumber=doc.PhoneNumber(0) .HomeAddress=doc.HomeAddress(0) .HomeAddressPostalCode=doc.Zip(0) .HomeAddressCountry=doc.Country(0) .HomeFaxNumber=doc.HomeFaxPhoneNumber(0) .BusinessAddress=doc.BusinessAddress(0) .BusinessAddressPostalCode=doc.OfficeZip(0) .BusinessAddressCountry=doc.OfficeCountry(0) .Spouse=doc.Spouse(0) .Children=doc.Children(0) .AssistantName=doc.Assistant(0) .ManagerName=doc.Manager(0) .OfficeLocation=doc.Location(0) .Department=doc.Department(0)' Display contact To user .save ' .quit End With ' Close object references. Set doc = view.getnextdocument(doc) Loop Application.quit End SubImport :Sub ImpOutlook ''Last Update: 03/15/01 at 9:26AM ''By David Wiggs <david.wiggs@netaspx.com> '' '' Version 2 '' - added support for Contact Notes field '' '' Version 3 - updated August 8, 2001 '' - added support for subfolders in the Contacts folder '' - moved all contacts processing to a subroutine '' - added support for skipping existing personal address book entries '' New email address - David.Wiggs@CODEalaCarte.com '' Dim session As New notessession Dim db As notesdatabase Dim doc As notesdocument, pdoc As notesdocument, pdoc2 As notesdocument, pdoc3 As notesdocument Dim profdoc As notesdocument Dim pnab_collection As notesdocumentcollection Dim pnabdoc As notesdocument Dim dateTime As New NotesDateTime( "01/01/70" ) Set db = session.getdatabase("","names.nsf") Set profdoc = db.GetProfileDocument("DirectoryProfile") ''Check to ensure that the person clicking the button is the owner of the personal address book. ''If the owner and user don't match exit If Not profdoc Is Nothing Then Print "Owner: " & profdoc.Owner(0) Print "I see this is your address book." Else Print "Sorry, not your address book." Exit Sub End If Dim ol As Variant Dim olns As Variant Dim objRootFolder As Variant Dim objAllContacts As Variant Dim objAllFolders As Variant Dim Folder1 As Variant Dim Contacts1 As Variant Dim Folder2 As Variant Dim Contacts2 As Variant Dim Folder3 As Variant Dim Contacts3 As Variant Dim Folder4 As Variant Dim Contacts4 As Variant Dim Items1 As Variant Dim category As String ' Set the Application object. Set ol = CreateObject("Outlook.Application") ' Set the Namespace object. Set olns = ol.GetNamespace("MAPI") ' Set the default Contacts folder. Set objRootFolder = olns.GetDefaultFolder(10) ' Set objAllContacts equal to the collection of all contacts. Set objAllContacts = objRootFolder.Items If objAllContacts.Count > 0 Then Call processitems(objAllContacts,category,db) End If Set objAllFolders = objRootFolder.Folders ' Loop through each contact. Stop Forall Folders In objAllFolders '' Setup the Categories field category = Folders.Name '' Find out if there are any contacts to process Set Contacts1 = Folders.Items If Contacts1.Count > 0 Then 'Forall Contacts In Contacts1 Call processitems(Contacts1,category,db) 'End Forall End If '' Find out if there is another level of folders to process Set Folder1 = Folders.Folders If Folder1.Count <> 0 Then Forall Folders1 In Folder1 category = Folders.Name & "\" & Folders1.Name '' Find out if there are any contacts that need to be processed Set Contacts2 = Folders1.Items If Contacts2.Count > 0 Then Call processitems(Contacts2,category,db) End If '' Find out if there is another level of folders that need to be processed Set Folder2 = Folders1.Folders If Folder2.Count <> 0 Then Forall Folders2 In Folder2 '' Setup the categories field category = Folders.Name & "\" & Folders1.Name & "\" & Folders2.Name '' Find out if there are any contacts that need to be processed Set Contacts3 = Folders2.Items If Contacts3.Count > 0 Then Call processitems(Contacts3,category,db) End If '' Find out if there is another level of folders that needs to be processed Set Folder3 = Folders2.Folders If Folder3.Count <> 0 Then Forall Folders3 In Folder3 '' Setup the categories field category = Folders.Name & "\" & Folders1.Name & "\" & Folders2.Name & "\" & Folders3.Name '' Find out if there are any contacts that need to be processed Set Contacts4 = Folders3.Items If Contacts4.Count > 0 Then Call processitems(Contacts4,category,db) End If End Forall End If End Forall End If End Forall End If End Forall Set ol = Nothing Set olns = Nothing Set objFolder = Nothing Set objAllContact = Nothing End SubFunction ReplaceSubstring (fullstring As String, oldString As String, newString As String) As String lenOldString = Len(oldString) position = Instr (fullString, oldString) Do While position > 0 And oldString <> "" fullString = Left (fullString, position -1) & newString & Mid (fullString, position + lenOldString) position = Instr (position + Len(newString), fullString, oldString) Loop ReplaceSubstring = fullStringEnd FunctionSub processitems(Contacts As Variant, category As String, db As notesdatabase) Dim pnab_collection As notesdocumentcollection Dim pdoc As notesdocument Dim pdoc3 As notesdocument Dim pdoc2 As notesdocument Dim dateTime As New NotesDateTime( "01/01/70" ) Forall Contact In Contacts If Contact.Class <> "69" Then If Contact.FullName <> "" Then Set pdoc = db.CreateDocument pdoc.Form = "Person" pdoc.Type = "Person" Print "Searching for: " & Contact.FullName searchFormula$ = "FullName = """ + ReplaceSubstring(Contact.FullName,|"|,"") + """" Print searchFormula$ Set pnab_collection = db.Search(searchFormula$,dateTime,0) Print pnab_collection.Count If pnab_collection.Count > 0 Then Set pnabdoc = pnab_collection.GetFirstDocument '' if the full name and email address matches then skip to the next entry If (pnabdoc.FullName(0) = Contact.FullName) And (pnabdoc.MailAddress(0) = Contact.Email1Address) Then Goto NextOne End If pdoc.LastName = Contact.LastName & " - " & Contact.Email1Address pdoc.FirstName = Contact.Firstname pdoc.FullName = Contact.FullName & " - " & Contact.Email1Address Else pdoc.FullName = Contact.FullName End If Print "Adding: " & Contact.FullName pdoc.Assistant = Contact.AssistantName If pdoc.LastName(0) = "" Then If Contact.FirstName <> "" And Contact.LastName = "" Then pdoc.FirstName = "" pdoc.LastName = Contact.FirstName Else pdoc.FirstName = Contact.FirstName pdoc.LastName = Contact.LastName End If End If pdoc.MailAddress = Contact.Email1Address pdoc.CompanyName = Contact.CompanyName pdoc.OfficeCity = Contact.BusinessAddressCity pdoc.OfficeCountry = Contact.BusinessAddressCountry pdoc.OfficeZip = Contact.BusinessAddressPostalCode pdoc.OfficeState = Contact.BusinessAddressState pdoc.OfficeStreetAddress = Contact.BusinessAddressStreet pdoc.OfficePhoneNumber = Contact.BusinessTelephoneNumber pdoc.OfficeFaxPhoneNumber = Contact.BusinessFaxNumber pdoc.Categories = Contact.Categories pdoc.Children = Contact.Children pdoc.Department = Contact.Department pdoc.City = Contact.HomeAddressCity pdoc.County = Contact.HomeAddressCountry pdoc.Zip = Contact.HomeAddressPostalCode pdoc.State = Contact.HomeAddressState pdoc.StreetAddress = Contact.HomeAddressStreet pdoc.PhoneNumber = Contact.HomeTelephoneNumber pdoc.HomeFaxPhoneNumber = Contact.HomeFaxNumber pdoc.JobTitle = Contact.JobTitle pdoc.Manager = Contact.ManagerName pdoc.CellphoneNumber = Contact.MobileTelephoneNumber pdoc.Location = Contact.OfficeLocation pdoc.PhoneNumber_6 = Contact.PagerNumber pdoc.Spouse = Contact.Spouse pdoc.Title = Contact.Title pdoc.Website = Contact.WebPage pdoc.Birthday = Contact.Birthday '' let's see if this works pdoc.Comment = Contact.Body If ( category <> "" ) Then pdoc.Categories = category End If Call pdoc.Save(True,True) If Contact.Email2Address <> "" Then Set pdoc2 = db.CreateDocument pdoc2.Form = "Person" pdoc2.Type = "Person" pdoc2.LastName = Contact.LastName + " - " + Contact.Email2Address pdoc2.FirstName = Contact.FirstName pdoc2.FullName = Contact.FullName + " - " + Contact.Email2Address pdoc2.CompanyName = Contact.CompanyName pdoc2.MailAddress = Contact.Email2Address If ( category <> "" ) Then pdoc2.Categories = category End If Call pdoc2.Save(True,True) End If If Contact.Email3Address <> "" Then Set pdoc3 = db.CreateDocument pdoc3.Form = "Person" pdoc3.Type = "Person" pdoc3.LastName = Contact.LastName + " - " + Contact.Email3Address pdoc3.FirstName = Contact.FirstName pdoc3.FullName = Contact.FullName + " - " + Contact.Email3Address pdoc3.CompanyName = Contact.CompanyName pdoc3.MailAddress = Contact.Email3Address If ( category <> "" ) Then pdoc3.Categories = category End If Call pdoc3.Save(True,True) End If End If End IfNextOne: End ForallEnd SubSub LastNameFirstName2(pnab As String) On Error Goto ErrorRoutine '1 = firstname lastname '2 = lastname firstname 'If Messagebox( "The contacts in your personal address book will be updated. Continue?", 4+32, "" ) = 7 Then Exit Sub sort$ = "2" Dim session As New NotesSession Dim db As New NotesDatabase( "", pnab ) Dim workspace As New NotesUIWorkspace 'update the profile document Dim profile As NotesDocument Set profile=db.GetProfileDocument("DirectoryProfile") If profile.Owner(0)="" Then Call CreateDefaultPersonalAddressBookProfile2( profile ) End If profile.NameDisplay = sort$ Call profile.Save(True,True,True) 'update any old contacts Dim dc As NotesDocumentCollection Set dc = db.Search( "Form=""Person"" | Type=""Person""", Nothing, 0 ) If dc Is Nothing Then Goto UpdateComplete If dc.Count = 0 Then Goto UpdateComplete Dim person As NotesDocument For q = 1 To dc.Count Print "updating " & q & " of " & dc.Count Set person = dc.GetNthDocument( q ) person.NameDisplayPref = sort$ Call person.Save(True,True,True) Next 'q Print "" UpdateComplete: 'ok = Messagebox( "Update Complete" ) Exit Sub ErrorRoutine: Messagebox Error$ & " " & Erl Exit SubEnd SubSub CreateDefaultPersonalAddressBookProfile2( profile As NotesDocument ) On Error Goto ErrorRoutine'the global variable "profile" is a profile document already'we need to add the fields to it Call profile.ReplaceItemValue("Owner", session.Username) Call profile.ReplaceItemValue("Form", "DirectoryProfile") Call profile.ComputeWithForm(False, False) Call profile.Save(True,True,True) Exit Sub ErrorRoutine: Messagebox "CreateDefaultProf: " & Error$ & " " & Erl Exit Sub End Sub[%sig%]

et hop, copier/coller ![%sig%]

Bonjour,Export MSAccess :Option PublicUselsx "*LSXODBC"Sub expvdatamdb(pnab As String, pmdb As String) Dim strDB As String 'Initialize string to database path. strDB = pmdb ' this is a directory you have 'Create new instance of Microsoft Access Set appAccess = CreateObject("Access.Application") 'Open database in Microsoft Access window appAccess.NewCurrentDatabase(strDB) 'Get Database variable. Set dbs = appAccess.CurrentDB() Set tdf = dbs.CreateTableDef("Contacts") 'Create new table. 'Create field in new table. dbText = 10 Set fld = tdf.CreateField("Salutation",dbText,100) 'Append Field and TableDef objects. tdf.FIELDS.Append fld dbs.TableDefs.Append tdf dbs.TableDefs.Refresh Set fld = tdf.CreateField("FirstName",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("MiddleInitial",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("LastName",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("Suffix",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("Title",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("CompanyName",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("BusinessAddress",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("BusinessZip",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("BusinessAddressCountry",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("OfficeLocation",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("Department",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("HomeAddress",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("HomeZip",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("HomeAddressCountry",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("OfficePhoneNumber",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("OfficeFaxPhoneNumber",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("CellPhoneNumber",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("Pager",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("HomePhoneNumber",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("HomeFaxPhoneNumber",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("EmailAddress",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("WebPage",dbText,150) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("BirthDay",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("Spouse",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("Children",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("AssistantName",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Set fld = tdf.CreateField("ManagerName",dbText,100) tdf.FIELDS.Append fld dbs.TableDefs.Refresh Dim workspace As New NotesUIWorkspace Set session = New NotesSession Set db = session.GetDatabase("",pnab) Set view = db.GetView("People") Set r = dbs.openrecordset("Contacts") Set doc = view.GetFirstDocument While Not(doc Is Nothing) With r .AddNew If doc.Title(0)<>"" Then .Salutation=doc.Title(0) If doc.FirstName(0)<>"" Then .FirstName=doc.FirstName(0) If doc.MiddleInitial(0)<>"" Then .MiddleInitial=doc.MiddleInitial(0) If doc.LastName(0)<>"" Then .LastName=doc.LastName(0) If doc.Suffix(0)<>"" Then .Suffix=doc.Suffix(0) If doc.CompanyName(0)<>"" Then .CompanyName=doc.CompanyName(0) If doc.JobTitle(0)<>"" Then .Title=doc.JobTitle(0) If doc.BusinessAddress(0)<>"" Then .BusinessAddress=doc.BusinessAddress(0) If doc.OfficeZip(0)<>"" Then .BusinessZip=doc.OfficeZip(0) If doc.OfficeCountry(0)<>"" Then .BusinessAddressCountry=doc.OfficeCountry(0) If doc.HomeAddress(0)<>"" Then .HomeAddress=doc.HomeAddress(0) If doc.Zip(0)<>"" Then .HomeZip=doc.Zip(0) If doc.Country(0)<>"" Then .HomeAddressCountry=doc.Country(0) If doc.OfficePhoneNumber(0)<>"" Then .OfficePhoneNumber=doc.OfficePhoneNumber(0) If doc.OfficeFaxPhoneNumber(0)<>"" Then .OfficeFaxPhoneNumber = doc.OfficeFaxPhoneNumber(0) If doc.PhoneNumber_6(0)<>"" Then .Pager = doc.PhoneNumber_6(0) If doc.CellPhoneNumber(0)<>"" Then .CellPhoneNumber = doc.CellPhoneNumber(0) If doc.PhoneNumber(0)<>"" Then .HomePhoneNumber = doc.PhoneNumber(0) If doc.HomeFaxPhoneNumber(0)<>"" Then .HomeFaxPhoneNumber = doc.HomeFaxPhoneNumber(0) If doc.MailAddress(0)<>"" Then .EMailAddress = doc.MailAddress(0) If doc.WebSite(0)<>"" Then .WebPage = doc.WebSite(0) If doc.Birthday(0)<>"" Then .BirthDay= doc.Birthday(0) If doc.Spouse(0)<>"" Then .Spouse=doc.Spouse(0) If doc.children(0)<>"" Then .Children=doc.Children(0) If doc.Assistant(0)<>"" Then .AssistantName=doc.Assistant(0) If doc.Manager(0)<>"" Then .ManagerName=doc.Manager(0) If doc.location(0)<>"" Then .OfficeLocation=doc.Location(0) If doc.Department(0)<>"" Then .Department=doc.Department(0) .Update End With Set doc = view.GetNextDocument(doc) Wend r.closeEnd SubExport Excel :Sub exppnabdata(pnab As String) Dim session As New notessession Dim db As notesdatabase Set db = session.GetDatabase("",pnab) Dim doc As notesdocument Dim exvname As String Dim exshname As String exvname = "People" exshname = "Contacts" Dim view As notesview Set view= db.getview (exvname) Dim vcols As Variant Dim xlApp As Variant Dim xlsheet As Variant Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True xlApp.Workbooks.Add xlApp.ReferenceStyle = 2 Set xlsheet = xlApp.Workbooks(1).Worksheets(1) xlsheet.Name = exshname Dim rows As Integer rows=1 Set doc = view.getfirstdocument rows = 2 xlsheet.Cells(1, 1).Value = "Salutation" xlsheet.Cells(1, 2).Value = "First Name" xlsheet.Cells(1, 3).Value = "Middle Initial" xlsheet.Cells(1, 4).Value = "Last Name" xlsheet.Cells(1, 5).Value = "Suffix" xlsheet.Cells(1, 6).Value = "Company Name" xlsheet.Cells(1, 7).Value = "Location" xlsheet.Cells(1, .Value = "Department" xlsheet.Cells(1, 9).Value = "Job Title" xlsheet.Cells(1, 10).Value = "Business Address" xlsheet.Cells(1,11).Value = "Office Zip" xlsheet.Cells(1, 12).Value = "Office Country" xlsheet.Cells(1, 13).Value = "Home Address" xlsheet.Cells(1, 14).Value = "Home Zip Code" xlsheet.Cells(1, 15).Value = "Home Country" xlsheet.Cells(1, 16).Value = "Office Phone Number" xlsheet.Cells(1, 17).Value = "Office Fax Phone Number" xlsheet.Cells(1, 18).Value = "Cell Phone Number" xlsheet.Cells(1, 19).Value = "Phone Number" xlsheet.Cells(1, 20).Value = "Home Fax Phone Number" xlsheet.Cells(1, 21).Value = "Pager" xlsheet.Cells(1, 22).Value = "EMail Address" xlsheet.Cells(1, 23).Value = "WebSite" xlsheet.Cells(1, 24).Value = "Birthday" xlsheet.Cells(1, 25).Value = "Spouse" xlsheet.Cells(1, 26).Value = "Children" xlsheet.Cells(1, 27).Value = "Assistant" xlsheet.Cells(1, 28).Value = "Manager" Do While Not (doc Is Nothing) xlsheet.Cells(rows, 1).Value = doc.Title(0) xlsheet.Cells(rows, 2).Value = doc.FirstName(0) xlsheet.Cells(rows, 3).Value = doc.MiddleInitial(0) xlsheet.Cells(rows, 4).Value = doc.LastName(0) xlsheet.Cells(rows, 5).Value = doc.Suffix(0) xlsheet.Cells(rows, 6).Value = doc.CompanyName(0) xlsheet.Cells(rows, 7).Value = doc.Location(0) xlsheet.Cells(rows, .Value = doc.Department(0) xlsheet.Cells(rows, 9).Value = doc.JobTitle(0) xlsheet.Cells(rows, 10).Value = doc.BusinessAddress(0) xlsheet.Cells(rows, 11).Value = doc.OfficeZip(0) xlsheet.Cells(rows, 12).Value = doc.OfficeCountry(0) xlsheet.Cells(rows, 13).Value = doc.HomeAddress(0) xlsheet.Cells(rows, 14).Value = doc.Zip(0) xlsheet.Cells(rows, 15).Value = doc.Country(0) xlsheet.Cells(rows, 16).Value = doc.OfficePhoneNumber(0) xlsheet.Cells(rows, 17).Value = doc.OfficeFaxPhoneNumber(0) xlsheet.Cells(rows, 18).Value = doc.CellPhoneNumber(0) xlsheet.Cells(rows, 19).Value = doc.PhoneNumber(0) xlsheet.Cells(rows, 20).Value = doc.HomeFaxPhoneNumber(0) xlsheet.Cells(rows, 21).Value = doc.PhoneNumber_6(0) xlsheet.Cells(rows, 22).Value = doc.MailAddress(0) xlsheet.Cells(rows, 23).Value = doc.WebSite(0) xlsheet.Cells(rows, 24).Value = doc.Birthday(0) xlsheet.Cells(rows, 25).Value = doc.Spouse(0) xlsheet.Cells(rows, 26).Value = doc.Children(0) xlsheet.Cells(rows, 27).Value = doc.Assistant(0) xlsheet.Cells(rows, 28).Value = doc.Manager(0) rows = rows+1 cols = 1 Set doc = view.getnextdocument(doc) Loop xlapp.range(xlsheet.cells(1,1), xlsheet.cells(rows, 28)).select xlapp.selection.columns.autofit End Sub[%sig%]