DominoArea.org [Archive]

'****************************************************************************************************************************************
'******************************** CLASSE WORD ****************************
'****************************************************************************************************************************************
Class Word '56789

Declare Property Set W_Visible As Integer
Declare Property Set W_SIGNET As Integer
Declare Property Set W_PlaceValWord As Integer
Declare Property Set W_NewFile As Integer
Declare Property Set W_NameFile As String
Declare Property Set W_MainDoc As NotesDocument
Declare Property Get W_FileName As String
Declare Property Set W_NameSaveFile As String
Declare Property Set W_Open As Integer
Declare Property Set W_DocParam As NotesDocument
Declare Property Get W_SaveFileName As String

Private P_Word As Integer
Private P_NewFile As Integer
Private P_strFileName As String
Private P_strSaveFileName As String
Private WO As Variant
Private WODoc As Variant
Private strVersion As String
Private WordDocList As Variant
Private WordDocAttachList As Variant
Private WordIsRunning As Integer
Private vListeSignet As Variant
Private iRet As Long
Private strField As String
Private ndDoc As notesdocument
Private ndDocParam As notesdocument
Private iOpen As Integer
'-----------------------------------------
'New Instance of the Class
'-----------------------------------------
Sub New
Print "Initialisation de la classe Word"
Dim NSsession As New notessession
Dim NuiW As New notesuiWorkspace
'Set ndDoc = NuiW.CurrentDocument.Document
End Sub

'------------------------------------------------------------------------
'Properties to Set the visible the object WORD
'------------------------------------------------------------------------
Property Set W_Visible As Integer
If W_Visible = 0 Then
Me.P_WORD = False
Elseif W_Visible =1 Then
Me.P_Word = W_Visible
Else
Me.P_Word = False
End If
End Property

'-------------------------------------------------------------------------------
'Properties to get the name of the template to Open
'-------------------------------------------------------------------------------
Property Set W_NameFile As String
If Dir$(W_NameFile) <> "" Then
P_strFileName = W_NameFile
Else
ManageError 0,"Ce modèle : "+ W_NameFile +" de document n'a pu être trouvé", "Avertissements"
End If
End Property


'-------------------------------------------------------------------------------
'Properties to get the name of the file to be saved
'-------------------------------------------------------------------------------
Property Set W_NameSaveFile As String
If Dir$ (W_NameSaveFile) <> "" Then
P_strSaveFileName = W_NameSaveFile
If (ManageError(1,"Ce document: "+ W_NameSaveFile +" existe déja." + Chr(13) + "Voulez-vous le supprimer?", "Sauvegarde du document " + W_NameSaveFile)) Then
Else
W_NameSaveFile = ""
End If
Else
P_strSaveFileName = W_NameSaveFile
End If
End Property


'---------------------------------------------------
'Get the name of file to be saved
'---------------------------------------------------
Property Get W_SaveFileName As String
W_SaveFileName = P_strSaveFileName
End Property

'---------------------------------------------
'Get the name of file template
'---------------------------------------------
Property Get W_FileName As String
W_FileName = P_strFileName
End Property

'--------------------------------------------------
'Properties to Set if it's a new file
'--------------------------------------------------
Property Set W_NewFile As Integer
If W_NewFile = 0 Then
P_NewFile = 0
Elseif W_NewFile = 1 Then
W_NewFile = 1
Else
P_NewFile = 0
End If
End Property

Property Set W_DocParam As NotesDocument
If Not (W_DocParam Is Nothing) Then
Set ndDocParam = W_DocParam
Else
Set ndDocParam = Nothing
End If
End Property

Property Set W_MainDoc As NotesDocument
If Not (W_MainDoc Is Nothing) Then
Set ndDoc = W_MainDoc
Else
Set ndDoc = Nothing
End If
End Property

Property Set W_Open As Integer
If W_Open = 1 Then
iOpen = W_Open
Else
iOpen = 0
End If
End Property

'---------------------------------------
'Close Word with Save
'---------------------------------------
Public Sub QuitWordWithSave
If Not(WO Is Nothing) Then
If W_SaveFileName <> "" Then
WODoc.Saveas(W_SaveFileName)
Call WO.Quit(0,0,0)
Else
'WO.SaveWorkspace
WO.Quit
End If
End If
End Sub

'*********************************************************************************************
'Fonction principale : lancement de Ms Word

'Private Sub MSWORDApplication
Public Function LanceWord
Dim strVersion As String
Set WO = CreateObject("Word.Application")
strVersion = WO.Version
Select Case Left(strVersion,1)
'--------------------------
'Version Word 7.0
'---------------------------
Case "7"
Print "Version 7.0 de Word"
If (P_Word) Then
WO.Visible=True
End If
Case "8"
Print "Version 8.0 de Word"
If (P_Word) Then
WO.Visible=True
End If
Set WODoc = WO.Workbooks
If (P_NewFile) Then
WODoc.Add
Else
WODoc.Add(W_FileName)
End If
Case "9"
Print "Version 9.0 de Word"
If (P_Word) Then
WO.Visible=True
End If
Set WODoc = WO.Documents
If (P_NewFile) Then
WO.Documents.Add("")
Else
If iOpen Then
WO.Documents.Open(W_FileName)
Else
WO.Documents.Add(W_FileName)
End If
End If
Set WODoc = WO.ActiveDocument
Set vListeSignet = WODoc.Fields
iRet = WODoc.FormFields.Count
Case Else
Print "Version 10.0 de Word"
If (P_Word) Then
WO.Visible=True
End If
Set WODoc = WO.Documents
If (P_NewFile) Then
WO.Documents.Add("")
Else
If iOpen Then
WO.Documents.Open(W_FileName)
Else
WO.Documents.Add(W_FileName)
End If
End If
Set WODoc = WO.ActiveDocument
Set vListeSignet = WODoc.Fields
iRet = WODoc.FormFields.Count
End Select
End Function
'*********************************************************************************************

Property Set W_SIGNET As Integer
If W_SIGNET = 1 Then
Call GetSignet
Else

End If
End Property

Property Set W_PlaceValWord As Integer
If W_PlaceValWord = 1 Then
Call PlaceVal
Else
End If
End Property

Private Function AddToList (Value As Variant, ValueList As Variant) As Variant
Dim tmpValueList As Variant
Dim x As Long
Dim i As Long
If Isempty(ValueList) Then
Redim ValueList(0)
End If
Redim tmpValueList(Ubound(ValueList))
For i = 0 To Ubound(ValueList)
tmpValueList(i) = ValueList(i)
Next
If Ubound(tmpValueList) = 0 And Cstr(tmpValueList(0)) = "" Then
x = 0
Else
x = Ubound(tmpValueList) + 1
End If
Redim Preserve tmpValueList(x)
tmpValueList(x) = Value
AddToList = tmpValueList
End Function

'------------------------------
'Recup des signets
'------------------------------
Private Sub GetSignet
Dim vListe As Variant
Dim Cpt As Long
Dim strField As String
Set vListeSignet = WODoc.Bookmarks
iRet = vListeSignet.Count
For Cpt = 1 To iRet
strField = WODoc.Bookmarks.Item(Cpt).Name
vListe = AddToList (strField, vListe)
Next
ndDoc.ListeSignet = vListe
ndDoc.ListeSignetEmpty = vListe
ndDoc.CacheWord = 1
Call WO.Quit(0,0,0)
End Sub

Public Function CountCharacters(TheString As String, CharactersToCheckFor As String) As Integer
Dim Char As String
Dim ReturnAgain As String
CountCharacters = 0


For i = 1 To Len(TheString)


If i < (Len(TheString) + 1 - Len(CharactersToCheckFor)) Then
Char = Mid(TheString, i, Len(CharactersToCheckFor))
ReturnAgain = "1"
Else
Char = Mid(TheString, i)
ReturnAgain = "0"
End If
If Char = CharactersToCheckFor Then CountCharacters = CountCharacters + 1
If ReturnAgain = "0" Then Goto NextPos
Next i
NextPos:
End Function

Public Function PlaceVal As Variant
Dim item As NotesItem

Dim vFieldNotes As Variant
Dim vFieldWord As Variant
Dim vValueNotes As Variant
Dim icpt As Long
Dim varChaine As Variant
Dim sChaine As String
Dim Cpt As Long
Dim vVal As Variant
Dim lenText As Integer
Dim sCommande As String
Dim sLangue As String

PlaceVal = True
vFieldNotes = ndDocParam.ChampsNotes
sLangue = ndDoc.GetItemValue ("Langue") (0)
If Lcase (sLangue) <> "ang" Then sLangue = "Fra" Else sLangue = "Ang"

If Not Isarray (vFieldNotes) Then
'ManageError 0,"Ce modele de document n' a aucune correspondance de champ." + Chr(10) + "Pour continuer vous devez effetuer ces correspondances dans votre moéle de document", "Transfert des informations de Notes vers Word"
PlaceVal = False
Exit Function
Elseif (vFieldNotes(0) = "" ) Then
'ManageError 0,"Ce modele de document n' a aucune correspondance de champ." + Chr(10) + "Pour continuer vous devez effetuer ces correspondances dans votre moéle de document", "Transfert des informations de Notes vers Word"
PlaceVal = False
Exit Function
End If
vFieldWord = ndDocParam.SignetsWord

If Not Isarray (vFieldWord) Then
ManageError 0,"Ce modele de document n' a aucun signet." + Chr(10) +"Avant de continuer vous devez saisir vos signets dans votre modele Word", "Transfert des informations de Notes vers Word"
PlaceVal = False
Exit Function
Elseif (vFieldWord(0) = "" ) Then
ManageError 0,"Ce modele de document n' a aucun signet." + Chr(10) +"Avant de continuer vous devez saisir vos signets dans votre modele Word", "Transfert des informations de Notes vers Word"
PlaceVal = False
Exit Function
End If

For Cpt = 0 To Ubound (vFieldNotes)

' récupération du champ (test si alias)
If ndDoc.HasItem (vFieldNotes (Cpt)) Then
If ndDoc.HasItem (vFieldNotes (Cpt) + "Fra") And _
ndDoc.GetItemValue (vFieldNotes (Cpt) + "Fra") (0) <> "" Then
Set item = ndDoc.GetFirstItem (vFieldNotes (Cpt) + sLangue)
Else
Set item = ndDoc.GetFirstItem (vFieldNotes (Cpt))
End If

vValueNotes = item.Values
vVal = vValueNotes
For iCpt = 0 To Ubound (vVal)
If Cstr (vVal (iCpt)) <> "" Then
If sChaine = "" Then
If item.Type = NAMES Then
sCommande = "@Name ([CN]; """ + vVal (iCpt) + """)"
varChaine = Evaluate (sCommande)
sChaine = varChaine (0)
Else
sChaine = Cstr (vVal (iCpt))
End If
Else
If item.Type = NAMES Then
sCommande = "@Name ([CN]; """ + vVal (iCpt) + """)"
varChaine = Evaluate (sCommande)
sChaine = sChaine + "," + varChaine (0)
Else
sChaine = sChaine + "," + Cstr (vVal (iCpt))
End If
End If
End If
Next

lenText = Len (sChaine) - CountCharacters (sChaine, Chr (10))
WODoc.Bookmarks (vFieldWord (cpt)).Select

' insertion du champ
Dim win As Variant
Dim sel As Variant
Set win = WODoc.ActiveWindow
Set sel = win.Selection
sel.TypeText (Cstr (sChaine))

Call sel.MoveLeft (wdCharacter, lenText, wdExtend)
' redefinition du signet avec le nouveau texte
Call WODoc.Bookmarks.Add (Cstr (vFieldWord (cpt)), sel.Range)
sChaine = ""
End If
Next
End Function



Function MiseAJourFieldDoc(vNotes As Variant,vWord As Variant)
Dim vValue As Variant
Dim Cpt As Long
On Error Goto TraiteError
For Cpt = 0 To Ubound(vNotes)
vValue = ndDoc.GetItemValue(vNotes(Cpt))
WODoc.FormFields.Item(vWord(Cpt)).Result = Cstr(vValue(0))
NextStep :
Next
Exit Function
TraiteError :
Goto NextStep
End Function
'---------------------
'Manage Error
'---------------------
Private Function ManageError(iType As Integer,strMessage As String,strTitle As String) As Variant
Dim iRet As Long
ManageError = False
Select Case iType
Case 0
iRet = Messagebox (strMessage, 0+16+0+0+4096,strTitle)
If Not(WO Is Nothing) Then
Call WO.Quit(0,0,0)
End If
Case 1
iRet = Messagebox (strMessage, 1+16+0+0+4096,strTitle)
If iREt = 1 Then
Kill P_strSaveFileName
ManageError = True
End If
End Select

End Function

'-----------------------
'Main Function
'-----------------------
'Public Function LaunchWord
' Call MSWORDApplication
'End Function

End Class