Transfert de donnée de outlook vers excel

Fermé
sidali - 15 mai 2012 à 16:08
Bonjour,

Sub Import_Frais()

'Déclarations des variables et objets
Dim objApply As Outlook.Application
Dim objNameSpace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim oRecip As Outlook.Recipient
Dim objContact As Outlook.ContactItem
Dim oFolder As Outlook.Folders
Dim MyItems
Dim OnletName As String
Dim user As String
Dim tagg As String
Dim line As Integer
Dim numsem() As String
Dim datedeb, datefin As Date
Dim Body As String
Dim Day As String
Dim Name As String
Dim Client As String
Dim Visited As String
Dim Project As String
Dim TypeAction As String

'Constante de l'Onglet "Note de Frais"
Const POSY_START_FRAIS As Integer = 7

Const POSX_DATE As Integer = 1
Const POSX_SALES_PERSON As Integer = 3
Const POSX_Visited_COMPANY As Integer = 4
Const POSX_VISITED_PERSON As Integer = 5
Const POSX_PROJECT As Integer = 6
Const POSX_SALES_PHASE As Integer = 7

' Numéro de Semaine
Const POSY_MOIS As Integer = 4
Const POSX_MOIS As Integer = 4

' Nombre de ligne
Const NB_LG_FRAIS As Integer = 22

Name = "Sid-ali BENANI"

'Initialisation le numéro de semaine
datedeb = ThisWorkbook.ActiveSheet.Cells(POSY_MOIS, POSX_MOIS)
datefin = DateAdd("d", -1, DateAdd("m", 1, datedeb))
MsgBox datedeb
MsgBox datefin
' Effacement du tableau Commerce
For i = POSY_START_FRAIS To POSY_START_FRAIS + NB_LG_FRAIS - 1
ThisWorkbook.ActiveSheet.Cells(i, POSX_DATE) = ""
ThisWorkbook.ActiveSheet.Cells(i, POSX_SALES_PERSON) = ""
ThisWorkbook.ActiveSheet.Cells(i, POSX_Visited_COMPANY) = ""
ThisWorkbook.ActiveSheet.Cells(i, POSX_VISITED_PERSON) = ""
ThisWorkbook.ActiveSheet.Cells(i, POSX_PROJECT) = ""
ThisWorkbook.ActiveSheet.Cells(i, POSX_SALES_PHASE) = ""
Next i

' Initialisation du numéro de ligne
line_FRAIS = POSY_START_FRAIS

'Instance des objets Outlook
Set objApply = Outlook.Application 'accéder a outlook
Set objNameSpace = objApply.GetNamespace("MAPI") 'permet d'accéder données Outlook stockées dans bases de messages.
Set oFolder = objNameSpace.Folders
Set oRecip = objNameSpace.CreateRecipient(Name)
oRecip.Resolve
MsgBox "Export 0"
' Résolution du User en fonction Nom et Prénom
If oRecip.Resolved = True Then
On Error Resume Next
MsgBox "Export 1"
'Recherche des contacts partagés
Set objFolder = objNameSpace.GetSharedDefaultFolder(oRecip, olFolderCalendar)

If Not objFolder Is Nothing Then
MsgBox "Export 2"
Set MyItems = objFolder.Items
line_COM = POSY_START_FRAIS
MsgBox "Export 3"
' Pour tous les RDV
For i = 1 To MyItems.Count
Set objCalendar = MyItems(i)

If (objCalendar.Start >= datedeb And objCalendar.Start < datefin) Then
'MsgBox objCalendar.Start
'MsgBox objCalendar.Title
' Corps de texte
Body = StrConv(objCalendar.Subject, vbUpperCase)

' MsgBox Body
' S'il y a des frais dans le RDV
' If (InStr(Body, "RDV") Or InStr(Body, "RES")) And (InStr(objCalendar.Categories, "RDV")) Then
If (InStr(Body, "RDVC")) Then
ThisWorkbook.ActiveSheet.Cells(line_COM, POSX_DATE) = objCalendar.Start

MsgBox "IN RDVC"
ThisWorkbook.ActiveSheet.Cells(line_COM, POSX_PROJECT) = objCalendar.Subject

ThisWorkbook.ActiveSheet.Cells(line_COM, POSX_SALES_PERSON) = Name

ThisWorkbook.ActiveSheet.Cells(line_COM, POSX_Visited_COMPANY) = Mid(Body, InStr(1, Body, "RDVC") + 2)

ThisWorkbook.ActiveSheet.Cells(line_COM, POSX_VISITED_PERSON) = Mid(Body, InStr(1, Body, "RDVC") + 2)
MsgBox "IN 2"
MsgBox Mid(Body, InStr(1, Body, "RDVC") + 1)

line_COM = line_COM + 1

' Plus de ligne dispo*
If line_COM > line_COM + NB_LG_COMMERCE Then
Exit For
End If
End If
End If
Next i
End If
End If

'Message de fin d'export
'MsgBox "Export terminé" & objFolder.Items.Count & " - " & objFolder.Name
End Sub

ma macro me permet de transferer des RDV de mon calendrier outlook vers un tableau excel. le principe est simple je vais sur mon calendrier j'ouvre un rdv et sur objet j'écrit ce que je veut et il me le transmet sur mon tableau excel sauf pour

ThisWorkbook.ActiveSheet.Cells(line_COM, POSX_Visited_COMPANY) = Mid(Body, InStr(1, Body, "RDVC") + 2)

ThisWorkbook.ActiveSheet.Cells(line_COM, POSX_VISITED_PERSON) = Mid(Body, InStr(1, Body, "RDVC") + 2)
le +2 me décale des lettre et moi je veut qu'il me décale un mot en entier ou une phrase
exemple de mon rdv : RDVC:client:nom de personne rencontrer:motif
dc je veut a chaque fois qu'il décale ce qu'il y a d'écrit entre chaque deux petit points.
merci de me répondre


A voir également: