Export vers un fichier Txt ou Word

[oguruma]

Vous trouverez ci-dessous une classe permettant de réaliser un export d'une mailbox soit vers un fichier de type texte soit vers un fichier de type MSWord.

Agent de démonstration :
[syntax="ls"]
Option Public
Use "GetCommonObjects"
Use "ClassExportMailBox"

Sub Initialize
Dim dbMail As NotesDatabase
Dim emb As ExportMailBox
On Error Goto handleError
Call loadSession
Set dbMail=New NotesDatabase("","")
Call dbmail.openmail
If Not dbmail.isopen Then
Msgbox "Impossible d'accèder à votre base courrier",16,"Installation" & APP
Exit Sub
End If
Set emb=New ExportMailBox(dbmail)
'// export par défaut
'Call emb.export()
'// export personnalisé
emb.TypeExport="DOC"
emb.Directory="c:\alpha\ExportCourrierLotusNotes"
emb.SDirectory="PiecesJointesCourrierLotusNotes"
emb.TargetFile="MonCourrierLotusNotes.doc"
emb.Visible=True
emb.Reply=False
emb.pageBreak=True
emb.Memo=True
Call emb.export()
Msgbox "Nombre de documents exportés " & emb.NBDoc
Exit Sub
handleError:
Msgbox "erreur n° " & Err &" : " & Error$ & " ligne " & Erl,16,Lsi_info(2) & " / " & Lsi_info(12)
Resume fin
fin:
End Sub
[/syntax]

La classe ExportMailBox

[syntax="ls"]
Option Public
Use "ClassWord"

Const MB_OK=0
Const MB_OKCANCEL=1
Const MB_YESNOCANCEL=3
Const MB_YESNO=4
Const MB_ICONQUESTION=32
Const MB_ICONEXCLAMATION=48
Const MB_ICONINFORMATION=64
Const IDOK=1
Const IDCANCEL=2
Const IDABORT=3
Const IDYES=6
Const IDNO=7

Public Class ExportMailBox
Private m_session As NotesSession
Private m_dbmail As Notesdatabase
Private m_typeExport As String
Private m_error As Integer
Private m_errorMsg As Integer
Private m_errorLine As Integer
Private m_errorString As String
Private m_viewMail As String
Private m_targetFile As String
Private m_directory As String
Private m_sdirectory As String
Private m_word As Variant
Private m_PJ As Integer
Private m_Memo As Integer
Private m_Reply As Integer
Private m_nbdoc As Long
Private m_logPJ As Integer
Private m_visible As Integer
Private m_pageBreak As Integer

'//-------------------------------------------------------------------------
'// Constructeur
'// dbmail : nom de la base courrier à exporter
'//-------------------------------------------------------------------------
Sub new (dbmail As NotesDatabase)
Set m_session=New NotesSession
Set m_dbmail=dbmail
m_typeExport="TXT"
m_viewMail="($All)"
m_directory=m_session.GetEnvironmentString("directory",True)
m_targetFile=m_directory & "\" & "CourrierNotes" & "." & m_typeExport
m_sdirectory=m_directory & "\" & "PiecesJointesNotes"
m_PJ=True
m_Memo=True
m_Reply=True
m_logPJ=True
m_visible=False
m_pageBreak=False
End Sub

'//-------------------------------------------------------
'// Format d'exportation
'// DOC pour un fichier winword
'// TXT pour un fichier de type texte
'//-------------------------------------------------------
Property Set TypeExport As String
Dim t As String
t=Ucase$(typeExport)
If t="TXT" Or t="DOC" Then
m_typeExport=t
End If
End Property

'//-------------------------------------------------------
'// Vue de la base courrier à explorer
'// Par défaut ($All) - tous les documents
'//-------------------------------------------------------
Property Set ViewMail As String
m_viewMail=ViewMail
End Property

'//------------------------------------------------------------------------------
'// Directory où sera déposé le fichier
'// par défaut le répertoire DATA du client notes
'//------------------------------------------------------------------------------
Property Set Directory As String
Dim tmpfile As String
tmpfile=m_TargetFile
m_directory=Directory
m_targetfile=""
m_targetFile=m_directory & "\" & tmpfile
End Property

'//------------------------------------------------------------------
'// Sous répertoire pour les pièces jointes
'// par défaut EMAIL2+Type d'export
'//-------------------------------------------------------------------
Property Set SDirectory As String
m_sdirectory=m_directory & "\" & SDirectory
End Property

'//-----------------------------------------------------------------------------
'// Nom du fichier cible contenant les mail
'// par défaut EMAIL2+type d'export.type d'export
'//-------------------------------------------------------------------------------
Property Set TargetFile As String
m_targetFile=m_directory & "\" & TargetFile
End Property

'//-------------------------------------------------------------------------------
'// Autorise-t-on l'extraction des pièces jointes
'// Oui par défaut
'//-------------------------------------------------------------------------------
Property Set PJ As Integer
m_PJ=PJ
End Property

'//-------------------------------------------------------------------------------
'// Export word visible
'//-------------------------------------------------------------------------------
Property Set Visible As Integer
m_visible=Visible
End Property

'//-------------------------------------------------------------------------------
'// Exporte les mémo
'//-------------------------------------------------------------------------------
Property Set Memo As Integer
m_Memo=Memo
End Property

'//-------------------------------------------------------------------------------
'// Exporte les réponse
'//-------------------------------------------------------------------------------
Property Set Reply As Integer
m_Reply=Reply
End Property

'//-------------------------------------------------------------------------------
'// Journal des pièces jointes
'//-------------------------------------------------------------------------------
Property Set LOGPJ As Integer
m_logPJ=LOGPJ
End Property

'//-------------------------------------------------------------------------------
'// Saut de page entre chaque message
'//-------------------------------------------------------------------------------
Property Set PageBreak As Integer
m_pageBreak=PageBreak
End Property


'//-------------------------------------------------------------------------------
'// Nombre de documents exportés
'//-------------------------------------------------------------------------------
Property Get NBDoc As Long
NBDoc=m_nbdoc
End Property


'//-------------------------------------------------------
'// Export du courrier de l'utilisateur
'//-------------------------------------------------------
Public Function Export() As Integer
Dim view As NotesView
Dim docMail As NotesDocument
Dim rep As Integer
Dim n As Long
Dim ok As Integer
Dim fp As Integer
On Error Goto handleErrorExport
'Msgbox "dir " & m_directory
'Msgbox "sdir " & m_sdirectory
'Msgbox "file " & m_targetfile
'//------------------------------------------------------------------
'// Création si nécessaire du répertoire pour les PJ
'//------------------------------------------------------------------
If Dir$(m_directory,16)="" Then
Mkdir m_directory
End If
If Dir$(m_sdirectory,16)="" Then
Mkdir m_sdirectory
End If
'//------------------------------------------------------------------
'// Objet Word
'//------------------------------------------------------------------
Select Case m_typeExport
Case "TXT"
fp=1
Open m_targetFile For Output As fp
Print #fp,"Base courrier : ";m_dbmail.title
Print #fp,"Fichier : ";m_dbmail.FilePath
Print #fp,""
Case "DOC"
Set m_word=New ExportToWord("")
Call m_word.setVisible(m_visible)
Call m_word.setDisplayAlerts(False)
Call m_word.FontName("Tahoma")
Call m_word.FontSize(8)
Call m_word.FontColorIndex(wdBlue)
Call m_word.AppendText("Base courrier : " & m_dbmail.title,True)
Call m_word.AppendText("Fichier : " & m_dbmail.FilePath,True)
Call m_word.Newline(2)
End Select
Set view=m_dbMail.Getview(m_viewMail)
'//------------------------------------------------------------------
'// Accès à la vue ?
'//------------------------------------------------------------------
If view Is Nothing Then
Msgbox "impossible d'accèder à la base " & m_viewMail
Exit Function
End If
'//------------------------------------------------------------------
'// Nombre de documents à traiter
'//------------------------------------------------------------------
total=view.allentries.count
Set docMail=view.Getfirstdocument
While Not (docMail Is Nothing)
n=n+1
Print "Analyse du document ";n;" / ";total
form=Ucase$(docMail.form(0))
'//------------------------------------------------------------------
'// Quels sont les masques à retenir ?
'//------------------------------------------------------------------
If (form="MEMO" And m_Memo) Or (form="REPLY" And m_Reply) Then
m_nbdoc = m_nbdoc+1
'//------------------------------------------------------------------
'// Aiguillage selon le type d'export choisi
'//------------------------------------------------------------------
Select Case m_typeExport
Case "DOC"
ok=ExtractTypeDOC(n,docMail)
Case "TXT"
ok=ExtractTypeTXT(n,docMail,fp)
End Select
'//---------------------------------------------------
'// Tout s'est-il bien passé ?
'//----------------------------------------------------
If Not ok Then
rep=GetYesNoMessage("Incident pendant le traitement du message " & n & " - voulez-vous continuer")
If rep=IDNO Then Exit Function
End If
End If
Set docMail=view.Getnextdocument(docMail)
Wend
'//------------------------------------------------------------------
'// Fin de la session
'//------------------------------------------------------------------
Select Case m_typeExport
Case "TXT"
Close fp
Case "DOC"
Call m_word.SaveAs(m_targetFile)
Call m_word.QuitSession
Case Else
'// Dummy
End Select
Export=True
Exit Function
handleErrorExport:
Call procError
Msgbox m_errorString
Resume fin
fin:
Export=False
End Function

Private Sub procError()
m_error=Err
m_errorMsg=Error$
m_errorLine=Erl
m_errorString="Erreur " & Err & " - " & Error$ & " ligne " & Erl & " - " & Lsi_info(12)
End Sub

'//------------------------------------------------------------------------------
'// Export au format Word
'//------------------------------------------------------------------------------
Private Function ExtractTypeDOC(n As Long, d As NotesDocument)
Dim v As Variant
On Error Goto handleError
Call m_word.AppendText("Created Date : " & d.created,True)
Call m_word.BorderAll(wdLineWidth225pt,wdLineStyleSingle,True,False,False,False,False)
Call m_word.AppendText("Extraction du message " & n,True)
If d.HasItem("DeliveredDate") Then
Call m_word.AppendText("Delivered Date : " & d.DeliveredDate(0),True)
End If
If d.HasItem("PostedDate") Then
Call m_word.AppendText("Posted Date : " & d.PostedDate(0),True)
End If
Call m_word.AppendText("Emis par : " & d.From(0),True)
Call m_word.AppendText("Envoyé à : ",False)
If d.Hasitem("SendTo") Then
v=d.SendTo
Forall st In v
Call m_word.AppendText(st & " ",False)
End Forall
End If
Call m_word.NewLine(1)
Call m_word.AppendText("Copie à : ",False)
If d.Hasitem("CopyTo") Then
v=d.CopyTo
Forall ct In v
Call m_word.AppendText(ct & " ",False)
End Forall
End If
Call m_word.NewLine(1)
Call m_word.AppendText("Copie cachée à : ",False)
If d.Hasitem("BlindCopyTo") Then
v=d.BlindCopyTo
Forall bct In v
Call m_word.AppendText(bct & " ",False)
End Forall
End If
Call m_word.NewLine(1)
Call m_word.FontName("Arial")
Call m_word.FontSize(8)
Call m_word.FontColorIndex(wdDarkBlue)
Call m_word.AppendText("Objet : " & d.Subject(0),True)
Call m_word.AppendText("Corps du message :",True)
Call m_word.AppendText(d.getItemValue("Body")(0),True)
Call m_word.FontName("Arial")
Call m_word.FontSize(8)
Call m_word.FontColorIndex(wdDarkRed)
Call m_word.FontBold(True)
Call m_word.NewLine(1)
Call m_word.Style("Normal")
'//----------------------------------------------
'// On passe au pièces jointes
'//----------------------------------------------
If m_PJ Then
If hasItemObject(d,"Body") Then
If Not ExtractPJ(n,d) Then
Msgbox "impossible d'extraire les pièces jointes dans le message n° " & n
Exit Function
End If
End If
End If
If m_pageBreak Then
Call m_word.InsertBreak(wdPageBreak)
Else
Call m_word.NewLine(1)
End If

ExtractTypeDOC=True
Exit Function
handleError:
Msgbox "Erreur n° " & Err & " - " & Error$ & " ligne " & Erl,16, Lsi_info(2)
Resume fin
fin:
End Function

'//------------------------------------------------------------------------------
'// Export au format texte
'//------------------------------------------------------------------------------
Private Function ExtractTypeTXT(n As Long, d As NotesDocument, fp As Integer)
Dim v As Variant
On Error Goto handleError
Print #fp,"[Extraction du message ";n;"]"
If d.HasItem("DeliveredDate") Then
Print "Delivered Date : ";d.DeliveredDate(0)
End If
If d.HasItem("PostedDate") Then
Print "Posted Date : ";d.PostedDate(0)
End If
Print #fp,"Created Date : "d.created
Print #fp,"Emis par : ";d.From(0)
Print #fp,"Envoyé à : ";
If d.Hasitem("SendTo") Then
v=d.SendTo
Forall st In v
Print #fp,st;" ";
End Forall
End If
Print #fp,""
Print #fp,"Copie à : ";
If d.Hasitem("CopyTo") Then
v=d.CopyTo
Forall ct In v
Print #fp,ct;" ";
End Forall
End If
Print #fp,""
Print #fp,"Copie cachée à : ";
If d.Hasitem("BlindCopyTo") Then
v=d.BlindCopyTo
Forall bct In v
Print #fp,bct;" ";
End Forall
End If
Print #fp,""
Print #fp,"Objet : ";d.Subject(0)
Print #fp,"Corps du message :"
Print #fp,d.getItemValue("Body")(0)
'//----------------------------------------------
'// On passe au pièces jointes
'//----------------------------------------------
If m_PJ Then
If hasItemObject(d,"Body") Then
If Not ExtractPJ(n,d) Then
Msgbox "impossible d'extraire les pièces jointes dans le message n° " & n
Exit Function
End If
End If
End If
If m_pageBreak Then
Print #fp,Chr$(12)
End If
Print #fp,""
ExtractTypeTXT=True
Exit Function
handleError:
Msgbox "Erreur n° " & Err & " - " & Error$ & " ligne " & Erl,16, Lsi_info(2)
Resume fin
fin:
End Function

'//------------------------------------------------------------------------------
'// Extraction des pièces jointes
'//------------------------------------------------------------------------------
Private Function ExtractPJ(n As Long,d As NotesDocument)
Dim rtItem As Variant
Dim target As String
On Error Goto handleError
Set rtitem = d.GetFirstItem("Body")
If Isarray( rtitem.EmbeddedObjects) Then
Forall EmbedObject In RTItem.EmbeddedObjects
If ( EmbedObject.Type = EMBED_ATTACHMENT) Then
Print "Extraction de ";EmbedObject.source
target=m_sdirectory & "\" & EmbedObject.source
Call EmbedObject.extractFile(target)
If m_logPJ Then
Select Case m_typeExport
Case "DOC"
Call m_word.AppendText("Pièce jointe : " & EmbedObject.source,True)
Case "TXT"
Print #1,""
Print #1,"Piece jointe ";EmbedObject.source
End Select
End If
End If
End Forall
End If
ExtractPJ=True
Exit Function
handleError:
Msgbox "Erreur " & Err & " ligne " & Erl & " " & Error$,16,Lsi_info(2)
Resume fin
fin:

End Function

'//-----------------------------------------------------------------
'// Le document a-t-il des pièces jointes
'//-----------------------------------------------------------------
Private Function hasItemObject(doc As NotesDocument, itemname As String)
Dim thisItem As Variant
On Error Goto NoObject
If doc.hasembedded Then
Set thisItem = doc.GetFirstItem( itemname )
If (thisItem.EmbeddedObjects(0) Is Nothing) Then
hasItemObject=False
Else
hasItemObject=True
End If
Else
hasItemObject=False
End If
Exit Function
NoObject:
hasItemObject = False
Resume Next
End Function

Private Function getYesNoMessage(texteMessage As String) As Integer
getYesNoMessage=Msgbox (texteMessage,MB_ICONQUESTION+MB_YESNO)
End Function
End Class
[/syntax]

Classe Word

[syntax="ls"]
Option Public
Use "WORDCONST"

Public Class WordSession
Private WApp As Variant
Private Documents As Variant
Private Document As Variant
Private ActiveDocument As Variant
Private Windows As Variant
Private Window As Variant
Private ActiveWindow As Variant
Private Selection As Variant
Private Sections As Variant
Private Section As Variant

'//--------------------------------------------------------------------
'// Constructeur
'//--------------------------------------------------------------------
Sub new()
Call CreateSession
End Sub

'//--------------------------------------------------------------------
'// Accès aux propriétés
'//--------------------------------------------------------------------
Function getSelection() As Variant
Set getSelection=Selection
End Function

Function getDocument() As Variant
Set getDocument=Document
End Function

Function getDocuments() As Variant
Set getDocuments=Documents
End Function

Function getActiveDocument() As Variant
Set getActiveDocument=ActiveDocument
End Function

Function getApplication() As Variant
Set getApplication=WApp
End Function

Function getSections() As Variant
Set getSections=Sections
End Function

'//------------------------------------------------------------------
'// Ajout d'un nouveau document
'//-----------------------------------------------------------------
Public Sub AddNewDocument(template As String)
If template="" Then
WApp.Documents.Add
Else
WApp.Documents.Add(template)
End If
Set Documents=Wapp.Documents
Set Windows=WApp.Windows

Call ActivateDocument(Documents.Count)
End Sub

'//--------------------------------------------------------------------------------------------
'// Rend actif le document n ou le dernier document créé
'//--------------------------------------------------------------------------------------------
Public Sub ActivateDocument(n As Integer)
'// A priori ça ne devrait pas se produire, mais ?
If n>Documents.Count Then
Error 9999,"Impossible d'activer le document " & n
End If
If n=0 Then
Error 9999,"Aucun document monté en mémoire"
End If
Set Document=Documents(n)
Document.Activate
Set ActiveDocument=WApp.ActiveDocument
Set Sections=ActiveDocument.Sections
Set Window=Windows(n)
Window.Activate
Set ActiveWindow=Wapp.ActiveWindow
Set Selection=Window.Selection
Windows(n).Activate
End Sub


'//--------------------------------------------------------------------
'// Ouverture d'une session MS Word
'//--------------------------------------------------------------------
Private Function CreateSession() As Variant
On Error Goto CreateSession
'// On tente de récupérer une session existante
'// Si aucune session on l'instancie sur une génération d'erreur
Set WApp = GetObject("", "Word.Application")
CreateSessionOk:
Exit Function
CreateSession:
Err = 0
Print "Création de la session MS Word"
'// Création de la session Word
Set WApp = CreateObject("Word.Application")
'// Si impossible de la créer on force l'erreur
If WApp Is Nothing Then
Error 9999,"Impossibile d'initialiser la session MS Word"
Resume EndCreationSession
End If
Print "Session MS Word initialisée "
'// On sort proprement pour initialiser les objets
Resume CreateSessionOK
EndCreationSession:
End Function

Sub setDisplayAlerts(toggle As Integer)
WApp.DisplayAlerts=toggle
End Sub

Sub setVisible(toggle As Integer)
WApp.Visible=toggle
End Sub

'//--------------------------------
'// Coller
'//--------------------------------
Sub Past()
WApp.Selection.Paste
End Sub

'//---------------------------------------------------------------------------
'// Ajout d'un texte
'//----------------------------------------------------------------------------
Sub AppendText(text As String, newline As Integer)
Selection.TypeText(text)
If newline Then Selection.TypeParagraph
End Sub

'//--------------------------------------
'// Nouvelle ligne
'//--------------------------------------
Sub NewLine(n As Integer)
Dim i As Integer
For i=1 To n
Selection.TypeParagraph
Next
End Sub

'//--------------------------------------
'// Saut page ou de section
'//--------------------------------------
Sub InsertBreak(t As Integer)
Call Selection.InsertBreak(t)
End Sub

'//----------------------------------------
'// Orientation de la page
'//---------------------------------------
'// wdOrientLandscape=1
'// wdOrientPortrait=0
Sub Orientation(o As Integer)
With Selection.PageSetup
.Orientation = o
End With
End Sub

'//---------------------------------
'// Style de texte
'//---------------------------------
Sub Style(sn As Variant)
Selection.Style = sn
End Sub

'/////////////////////////////////////
'// liste des couleurs colorIndex
'// wdAuto
'// wdBlack
'// wdBlue
'// wdBrightGreen
'// wdByAuthor
'// wdDarkBlue
'// wdDarkRed
'// wdDarkYellow
'// wdGray25
'// wdGray50
'// wdGreen
'// wdNoHighlight
'// wdPink
'// wdRed
'// wdTeal
'// wdTurquoise
'// wdViolet
'// wdWhite
'// wdYellow
'////////////////////////////////////////////

'//---------------------------------------
'// ColorIndex
'//---------------------------------------
Sub FontColorIndex(color As Integer)
Selection.Font.ColorIndex = color
End Sub

'//---------------------------------------
'// Fonte
'//---------------------------------------
Sub FontName(n As String)
Selection.Font.Name = n
End Sub

'//-----------------------------------------
'// Taille des caractères
'//-----------------------------------------
Sub FontSize (fz As Integer)
Selection.Font.Size = fz
End Sub

'//--------------------------------------------
'// Gras
'//---------------------------------------------
Sub FontBold(toggle As Integer)
Selection.Font.Bold = Toggle
End Sub

'//------------------------------------------------------
'// Souligné
'//-------------------------------------------------------
Sub FontUnderline(toggle As Integer)
'wdUnderlineDashHeavy
'wdUnderlineDashLongHeavy
'wdUnderlineDotDashHeavy
'wdUnderlineDotDotDashHeavy
'wdUnderlineDottedHeavy
'wdUnderlineNone
'wdUnderlineThick
'wdUnderlineWavyDouble
'wdUnderlineWords
'wdUnderlineDash
'wdUnderlineDashLong
'wdUnderlineDotDash
'wdUnderlineDotDotDash
'wdUnderlineDotted
'wdUnderlineDouble
'wdUnderlineSingle
'wdUnderlineWavy
'wdUnderlineWavyHeavy
Selection.Font.Underline = toggle
End Sub

'//--------------------------------------------
'// Italic
'//--------------------------------------------
Sub FontItalic(toggle As Integer)
Selection.Font.Italic = Toggle
End Sub

'//--------------------------------------------
'// Italic
'//--------------------------------------------
Sub FontColor(color As Integer)
Selection.Font.Italic = color
End Sub

'//--------------------------------------------------------------------------
'// Texte dans un paragraphe
'//--------------------------------------------------------------------------
Function AddTextToDoc(text As String) As Variant
Dim doc As Variant
Set doc=document
Set lastParagraph = doc.Paragraphs(doc.Paragraphs.Count).Range
newRangeStart = lastParagraph.End-1 ' This is where the new text will be placed
Call lastParagraph.InsertAfter(text)
End Function

'//------------------------------------------------------------------
'// Centrage du texte
'//-----------------------------------------------------------------
Sub AlignCenterParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Sub

'//------------------------------------------------------------------
'// Cadrage à droite
'//-----------------------------------------------------------------
Sub AlignRightParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
End Sub

'//------------------------------------------------------------------
'// Cadrage à gauche
'//-----------------------------------------------------------------
Sub AlignLeftParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
End Sub

'//-------------------------------------------------------------------------
'// Gestion des bordures de cadres
'//-------------------------------------------------------------------------
Sub BorderAll(lw As Integer, ls As Integer, t As Integer, b As Integer, r As Integer, l As Integer, ts As Integer)
'wdLineWidth025pt=2, 'wdLineWidth050pt=4
'wdLineWidth075pt=6, 'wdLineWidth100pt=8
'wdLineWidth150pt=12, 'wdLineWidth225pt=18
'wdLineWidth300pt=24, 'wdLineWidth450pt=36
'wdLineWidth600pt=48, 'wdLineStyleDashDot=5
'wdLineStyleDashDotDot=6, 'wdLineStyleDashDotStroked=20
'wdLineStyleDashLargeGap=4, 'wdLineStyleDashSmallGap=3
'wdLineStyleDot=2, 'wdLineStyleDouble=7
'wdLineStyleDoubleWavy=19, 'wdLineStyleEmboss3D=21
'wdLineStyleEngrave3D=22, 'wdLineStyleNone=0
'wdLineStyleSingle=1, 'wdLineStyleSingleWavy=18
'wdLineStyleThickThinLargeGap=16, 'wdLineStyleThickThinMedGap=13
'wdLineStyleThickThinSmallGap=10, 'wdLineStyleThinThickLargeGap=15
''wdLineStyleThinThickMedGap=12, 'wdLineStyleThinThickSmallGap=9
'wdLineStyleThinThickThinLargeGap=17, 'wdLineStyleThinThickThinMedGap=14
'wdLineStyleThinThickThinSmallGap=11,'ls=wdLineStyleSingle
With Selection.ParagraphFormat
If l Then
With .Borders(wdBorderLeft)
.LineStyle = ls
.LineWidth = lw
.Color = wdBlue
End With
End If
If r Then
With .Borders(wdBorderRight)
.LineStyle = ls
.LineWidth = lw
.Color = wdBlue
End With
End If
If t Then
With .Borders(wdBorderTop)
.LineStyle = ls
.LineWidth = lw
.Color = wdBlue
End With
End If
If b Then
With .Borders(wdBorderBottom)
.LineStyle = ls
.LineWidth = lw
.Color = wdBlue
End With
End If
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = ts
End With
End With

End Sub

'//-----------------------------------------------------------------
'// Création d'un tableau
'//-----------------------------------------------------------------
Sub CreateTable(rows As Integer, cols As Integer)
Call ActiveDocument.Tables.Add(Selection.Range,rows,cols)
End Sub

Sub InsertRowsBelow(n As Integer)
Call Selection.InsertRowsBelow(n)
End Sub

Sub InsertRowsAbove(n As Integer)
Call Selection.InsertRowsAbove(n)
End Sub

Sub SelectRow
Selection.SelectRow
End Sub

Sub SelectColumn
Selection.SelectColumn
End Sub

Sub RowDelete
Selection.Rows.Delete
End Sub

Sub SelectTable(n As Integer)
Selection.Tables(n).Select
End Sub

'//-----------------------------------------------------------------
'// Largeur des d'une colonne d'un tableau
'//-----------------------------------------------------------------
Sub SetTableColumnWidth(t As Integer, c As Integer, w As Single)
Dim table As Variant
Dim column As Variant
Set table=ActiveDocument.Tables(t)
Set column = table.Columns(c)
column.PreferredWidthType = 3
column.Width = WApp.CentimetersToPoints(w)
End Sub

'//-----------------------------------------------------------------
'// Hauteur d'une ligne d'un tableau
'//-----------------------------------------------------------------
Sub SetTableColumnHeight(t As Integer, r As Integer, h As Single)
'wdRowHeightAtLeast=1
'wdRowHeightAuto=0
'wdRowHeightExactly=2
Dim table As Variant
Dim row As Variant
Set table=ActiveDocument.Tables(t)
Set row = table.Rows(r)
Row.HeightRule = 2
Row.Height = WApp.CentimetersToPoints(h)
End Sub

'//-----------------------------------------------------------------
'// Lire le contenu d'une cellule d'un tableau
'//-----------------------------------------------------------------
Function GetTableCell(t As Integer, row As Long, col As Long) As Variant
Set GetTableCell=ActiveDocument.Tables(t).Cell(row,col)
End Function

'/////////////////////////////////////////
'// u = inité de déplacement
'// n = nombre de fois
'// e = extension de la sélection
'//////////////////////////////////////////

'/////////////////////////////////////////
'// Unités de déplacement
'// wdLine
'// wdParagraph
'// wdWindow
'// wdScreen
'// wdCell
'// wdSentence
'// wdSection
'// wdStory
'/////////////////////////////////////////

'//----------------------------------------------------------------
'// Déplacement à droite
'//-----------------------------------------------------------------
Sub MoveRight(u As Integer, n As Integer, e As Integer)
Call Selection.MoveRight(u,n,e)
End Sub

'//----------------------------------------------------------------
'// Homekey
'//-----------------------------------------------------------------
Sub HomeKey(u As Integer,e As Integer)
Call Selection.HomeKey(u)
End Sub

'//----------------------------------------------------------------
'// EndKey
'//-----------------------------------------------------------------
Sub EndKey(u As Integer,e As Integer)
Call Selection.EndKey(u,e)
End Sub

'//--------------------------------------------------------------------
'// Déplacement à gauche
'//-------------------------------------------------------------------
Sub MoveLeft(u As Integer,n As Integer,e As Integer)
Call Selection.MoveLeft(u,n,e)
End Sub

'//--------------------------------------------------------------------
'// Déplacement vers la fin
'//-------------------------------------------------------------------
Sub MoveEnd(u As Integer,n As Integer)
Call Selection.MoveEnd(u,n)
End Sub

'//--------------------------------------------------------------------
'// Déplacement vers le début
'//-------------------------------------------------------------------
Sub MoveStart(u As Integer,n As Integer)
Call Selection.MoveStart(u,n)
End Sub

'//--------------------------------------------------------------------
'// Déplacement vers le bas
'//-------------------------------------------------------------------
Sub MoveDown(u As Integer,n As Integer,e As Integer)
Call Selection.MoveDown(u, n,e)
End Sub

'//--------------------------------------------------------------------
'// Déplacement vers le haut
'//-------------------------------------------------------------------
Sub MoveUp(u As Integer,n As Integer,e As Integer)
Call Selection.MoveUp(u, n, e)
End Sub

'//--------------------------------------------------------------------
'// BackSpace
'//-------------------------------------------------------------------
Sub BackSpace(n As Integer,e As Integer)
Call Selection.TypeBackspace(n,e)
End Sub

'//--------------------------------------------------------------------
'// Taquet de tabulation positionné
'//-------------------------------------------------------------------
Sub TabStop(p As Single)
Call Selection.ParagraphFormat.TabStops.Add(WApp.CentimetersToPoints(p))
End Sub

'//--------------------------------------------------------------------
'// Taquet de tabulation effacé
'//-------------------------------------------------------------------
Sub TabStopClear(p As Single)
Call Selection.ParagraphFormat.TabStops(WApp.CentimetersToPoints(p)).Clear
End Sub

'//------------------------------------------------------------------------
'// Ajouter un signet
'//------------------------------------------------------------------------
Public Sub AddBookmark ( bookmark As String)
Call Document.Bookmarks.Add (bookmark)
End Sub

'//---------------------------------------------------------------------------
'// Remplacer le texte d'un signet
'//---------------------------------------------------------------------------
Public Sub UpdateTextBookmark (bookmark As String, value As String)
ActiveDocument.Bookmarks(bookmark).Range.Text=value
End Sub

'//---------------------------------------------------------------------------
'// Remplacer le texte d'un signet juste après
'//---------------------------------------------------------------------------
Public Sub InsertAfterBookmark (bookmark As String, value As String)
ActiveDocument.Bookmarks(bookmark).Range.InsertAfter(value)
End Sub

'//---------------------------------------------------------------------------
'// Supprimer un signet
'//---------------------------------------------------------------------------
Public Sub DeleteBookmark (bookmark As String)
ActiveDocument.Bookmarks(bookmark).Delete
End Sub

'//-----------------------------------------------------------------------
'// Selectionner un signet
'//------------------------------------------------------------------------
Sub GotoBookmark(bookmark As String)
ActiveDocument.Bookmarks(bookmark).Select
End Sub

'//-----------------------------------------------------------------------
'// Nombre de signets
'//------------------------------------------------------------------------
Function getBoorkmarks() As Integer
getBoorkmarks=ActiveDocument.Bookmarks.Count
End Function

'//-----------------------------------------------------------------------
'// Tester existance d'un signet
'//------------------------------------------------------------------------
Function ExistBookmark(bookmark As String) As Integer
ExistBookmark=ActiveDocument.Bookmarks.Exists(bookmark)
End Function

'//-----------------------------------------------------------------------
'// Affiche les signets
'//------------------------------------------------------------------------
Sub ShowBookmarks(toggle As Integer)
ActiveWindow.View.ShowBookmarks = toggle
End Sub

'//---------------------------------------------------------------------------
'// Mise à jour d'un champ
'//---------------------------------------------------------------------------
Public Sub UpdateField (field As String, value As String)
Document.FormFields(field).result = value
End Sub

'//--------------------------------------------------------------------
'// Enregistrement du document
'//-------------------------------------------------------------------
Sub saveAs(fn As String)
Activedocument.SaveAs fn
End Sub

Sub Save
ActiveDocument.Save
End Sub

'//----------------------------------------
'// Ferme le document
'//----------------------------------------
Sub CloseDocument(toogle)
Call Document.Close(toogle)
End Sub

'//--------------------------------------------------------------------
'// Appeler une macro
'//--------------------------------------------------------------------
Sub RunMacro(macro As String)
WApp.Run("[" & macro & "]")
End Sub

'//----------------------------------------
'// Entête de page
'//----------------------------------------
Sub SetHeader(t1 As String, t2 As String, t3 As String)
Dim Paragraph As Variant
Dim header As Variant
Dim p As Long
Set Section=document.Sections(1)
Set header = section.Headers(1)
Set Paragraph = header.Range
Call Paragraph.InsertBefore(t1 & Chr$(9) & t2 & Chr$(9) & t3)
Call showHeader
End Sub

'//-------------------------------------
'// Bas de page
'//------------------------------------
Sub SetFooter(t1 As String, t2 As String, t3 As String)
Dim Paragraph As Variant
Dim footer As Variant
Dim p As Long
Set Section=document.Sections(1)
Set footer = section.Footers(1)
Set Paragraph = footer.Range
Call Paragraph.InsertBefore(t1 & Chr$(9) & t2 & Chr$(9) & t3 & Chr$(9))
Set Paragraph = footer.Range
p = Paragraph.End
Call Paragraph.SetRange(p, p)
Call Paragraph.Fields.Add(Paragraph, 33)
Set Paragraph = footer.Range
p = Paragraph.End
Call Paragraph.SetRange(p, p)
Call Paragraph.InsertBefore("/")
Set Paragraph = footer.Range
p = Paragraph.End
Call Paragraph.SetRange(p, p)
Call Paragraph.Fields.Add(Paragraph, 26)
Call showHeader
End Sub

Private Sub showHeader
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Private Sub initPanes
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If

If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
End Sub

'//--------------------------------------------------------------------
'// Fermeture d'une session MS Word
'//--------------------------------------------------------------------
Sub QuitSession
On Error Goto CreateSession
Set WApp = GetObject("", "Word.Application")
ExistSessionOK:
WApp.Quit
Print "Session MS Word terminée"
Exit Sub
CreateSession:
Err = 0
WApp = CreateObject("Word.Application")
If WApp Is Nothing Then
Error 9999,"Impossibile d'initialiser la session MS Word"
Resume EndCloseSession
End If
Resume ExistSessionOK
EndClosesession:
End Sub
End Class

Public Class ExportToWord As WordSession
Sub new (template As String)
Call AddNewDocument(template)
End Sub
End Class
[/syntax]


Les constantes Word sont dans la rubrique Import/Export.
Je tiens à votre disposition une base d'exemple.