|
 |

Excel et Word
Si vous ne l'avez pas déjà fait :
Dans l'éditeur VB, ajoutez une référence à "Microsoft Word 8.0
Object Library" Menu Outils --> Références
Ouvre Word et le fichier Test.doc
Sub ouvreWord()
spécifier le chemin au cas où...
Si vous attribuez la valeur 1 au 2 ème argument l'application s'ouvre à sa taille normale et devient l'application active.
MyAppID = Shell _
("C:\Program Files\Microsoft Office\Office\Winword.EXE D:\ajeter\test.doc", 1)
AppActivate MyAppID
End Sub
Sub ouvreWord2()
'comme celà...
MyAppID = Shell _
("C:\Office\Office\Winword.EXE D:\ajeter\test.doc", 1)
AppActivate MyAppID
End Sub
Sub ouvrwd97()
'où bien comme celà...avec Office 97
MyAppID = Shell _
("C:\Office97\Office\Winword.EXE D:\ajeter\test.doc", 1)
AppActivate MyAppID
End Sub
Ouvre Word et le fichier Test.doc même avec un espace dans le chemin
Sub ouvrwordAvecEspace()
'Lorsqu'il y a un espace dans le nom du repertoire: ajout de " "
MyAppID = Shell("Winword.EXE ""C:\Mes documents\test.doc""", 1)
End Sub
Procédure pour écrire dans Word
Sub EcriDansWord()
Dim WordObj As Object
On Error Resume Next
Set WordObj = CreateObject("Word.Application.8")
'Pour afficher Word
WordObj.Visible = True
'Ajoute un document
WordObj.Documents.Add
With WordObj.Selection
.TypeParagraph
.TypeText Text:="Procédure pour écrire dans Word "
.TypeParagraph
.TypeText Text:="Daniel :o)"
.TypeParagraph
End With
'pour imprimer le document
WordObj.PrintOut
Set WordObj = Nothing
End Sub
Procédure pour exécuter une macro de Word (LancerParXL)
'Macro qui, par exemple, ouvre un document et l'imprime
Sub EcriDansWord()
Dim WordObj As Object
Set WordObj = CreateObject("Word.Application.8")
WordObj.Visible = True
WordObj.Documents.Add
WordObj.Run "LancerParXL"
End Sub
2 procédures maintenant:
La première écrit les commentaires de cellules dans Word
La deuxième écrit les formules. (Auteur=?)
Public Sub PrintCellComments()
Dim Cmt As String
Dim C As Range
Dim I As Integer
Dim WordObj As Object
Dim ws As Worksheet
Dim PrintValue As Boolean
Dim res As Integer
On Error Resume Next
Err.Number = 0
res = MsgBox("Voulez-vous éditer les commentaires?", _
vbYesNoCancel + vbQuestion, "Edition des commentaires de cellules")
Select Case res
Case vbCancel
Exit Sub
Case vbYes
PrintValue = True
Case Else
PrintValue = False
End Select
Set WordObj = GetObject(, "Word.Application.8")
If Err.Number = 429 Then
Set WordObj = CreateObject("Word.Application.8")
Err.Number = 0
End If
WordObj.Visible = True
WordObj.Documents.Add
With WordObj.Selection
.TypeText Text:="Commentaires dans le classeur: " + ActiveWorkbook.Name
.TypeParagraph
.TypeText Text:="Date: " + Format(Now(), "dd-mmm-yy hh:mm")
.TypeParagraph
.TypeParagraph
End With
For Each ws In Worksheets
For I = 1 To ws.Comments.Count
Set C = ws.Comments(I).Parent
Cmt = ws.Comments(I).Text
With WordObj.Selection
.TypeText Text:="Commentaire dans la cellule: " + _
C.Address(False, False, xlA1) + " feuille: " + ws.Name
If PrintValue = True Then
.TypeText Text:=" Cell Value: " + Format(C.Value)
End If
.TypeParagraph
.TypeText Text:=Cmt
.TypeParagraph
.TypeParagraph
End With
Next I
Next ws
Set WordObj = Nothing
MsgBox "OK...commentaires dans Word", vbInformation, "Edition des Commentaires"
End Sub
Public Sub PrintFormulasToWord()
Dim Cnt As String
Dim C As Range
Dim WordObj As Object
Dim HasArr As Boolean
On Error Resume Next
Err.Number = 0
Set WordObj = GetObject(, "Word.Application.8")
If Err.Number = 429 Then
Set WordObj = CreateObject("Word.Application.8")
Err.Number = 0
End If
WordObj.Visible = True
WordObj.Documents.Add
With WordObj.Selection
.Font.Name = "Arial"
.TypeText "Formules dans la feuille: " + ActiveSheet.Name
.TypeParagraph
.TypeText "Cells: " + Selection.Cells(1, 1).Address(False, False, xlA1) _
& " to " & Selection.Cells(Selection.Rows.Count, Selection.Columns.Count) _
.Address(False, False, xlA1)
.TypeParagraph
.TypeParagraph
End With
For Each C In Selection
HasArr = C.HasArray
Cnt = C.Formula
If HasArr Then
Cnt = "{" + Cnt + "}"
End If
If Cnt <> "" Then
With WordObj.Selection
.Font.Bold = True
.TypeText C.Address(False, False, xlA1) & ": "
.Font.Bold = False
.TypeText Cnt
.TypeParagraph
.TypeParagraph
End With
End If
Next C
MsgBox "Edition des formules dans Word. ", , "Formules dans Word"
End Sub
Comment envoyer la valeur d'une cellule vers un signet?
'Supposant un document lettre.doc contenant les signets: "Monsignet" et "Monsignet2"
Sub EcritVersSignet()
Dim LaLettre As String
Dim LeMontant
Dim LeTexte2
Dim ObjWord As Word.Application
Dim LeDocWord As Word.Document
On Error Resume Next
LaLettre = ThisWorkbook.Path & "\lettre.doc"
Set ObjWord = CreateObject("Word.Application")
ObjWord.Visible = True
Set LeDocWord = ObjWord.Documents.Open(LaLettre)
LeMontant = [A1]
LeTexte2 = [A2]
With LeDocWord
'Le nom du signet dans le document word est ici "Monsignet"
.Bookmarks("Monsignet").Range.Text = LeMontant
'Le nom du signet dans le document word est ici "Monsignet2"
.Bookmarks("Monsignet2").Range.Text = LeTexte2
End With
'Pour enregistrer le document et quitter Word
'LeDocWord.Save
'ObjWord.Quit
Set ObjWord = Nothing
End Sub
[top]
|