I have this code :
Dim word_fichier, word_fichier_sensiblité As Document
Dim fichier As String
Dim fichier_sensibilite As String
Dim word_app As Word.Application
'On récupère le template
fichier = ActiveWorkbook.Path & "\" & "fsm_template_balises_test.docx"
fichier_sensibilite = ActiveWorkbook.Path & "\" & "templates_sensibilité.docx"
'Ouverture de word
Set word_app = CreateObject("Word.Application")
With word_app
.Visible = True
.WindowState = 1
End With
'Définition de l'objet fichier word
Set word_fichier = word_app.Documents.Open(fichier)
Set word_fichier_sensiblité = word_app.Documents.Open(fichier_sensibilite)
'Copie du tableau
word_fichier_sensiblité.Tables(1).Range.Copy
'Collage du tableau
With word_fichier.Sections(1).Footers(wdHeaderFooterPrimary)
.Range.Paste
End With
I have an existing footer in my word_fichier and i want to paste a table from the word_fichier_sensiblité. For now my table is erasing my existing footer, idk how to paste this table at the beginning of my footer. Any advise ?
Thanks
With word_fichier.Sections(1).Footers(wdHeaderFooterPrimary).Range
.Collapse wdCollapseStart
.Paste
End With
Related
I am writing a vba macro for a word document. I use vba macro to generate textbox and text to the word document. The issue is that the textbox moves to the top of last page instead of staying on the first page.
I don't know what i am doing wrong. All i need is for that textbox to remain on the first page. I really need to include the textbox.
below is my code and the output image
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
ActiveDocument.Content.Select
Selection.Delete
With wdApp
.Visible = True
.Activate
With .Selection
Dim objShape As Word.Shape
Set objShape2 = ActiveDocument.Shapes.addTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
With .Selection
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
For i = 1 To 40
.TypeText i
.TypeParagraph
Next i
End With
End With
Word Shape objects must be anchored to a character position in the Word document. They will always appear on the page where the anchor character is and, if the anchor formatting is not to the page, they will move relatively on the page with the anchor character.
A special case ensues when a document is "empty" (a lone paragraph), so it helps to make sure the document has more than one character in it. In the code sample below an additional paragraph is inserted before adding the TextBox - to the first paragraph.
I've made some other adjustments to the code:
Added On Error GoTo 0 so that error messages will appear. Otherwise, debugging becomes impossible.
Removed the With for the Word application since it's not necessary when using Word objects
Declared and use a Word Range object for inserting content. As with Excel, it's better to not work with Selection whenever possible.
Used the wrdDoc object you declare and instantiate instead of ActiveDocument.
This code worked fine in my test, but I cannot, of course, repro your entire environment.
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
wdApp.Visible = True
wrdApp.Activate
Dim i As Long
Dim objShape2 As Word.Shape
Dim rng As Word.Range
Set rng = wrdDoc.Content
rng.Delete
With rng
.InsertAfter vbCr
.Collapse wdCollapseStart
Set objShape2 = ActiveDocument.Shapes.AddTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60, Anchor:=rng)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
rng.Start = ActiveDocument.Content.End
For i = 1 To 40
.Text = i & vbCr
.Collapse wdCollapseEnd
Next i
End With
Another solution for you to look at.
'12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
'========1=========2=========3=========4=========5=========6=========7=========8=========9=========A=========B=========C
Option Explicit
Sub textboxtest()
Const my_doc_name As String = "mydocument.docx"
Dim my_fso As Scripting.FileSystemObject
Dim my_doc As Word.Document
Dim my_range As Word.Range
Dim counter As Long
Dim my_text_box As Word.Shape
Dim my_shape_range As Word.ShapeRange
' There is no need to test for the Word app existing
' if this macro is in a Word template or Document
' because to run the macro Word MUST be loaded
Set my_fso = New Scripting.FileSystemObject
If my_fso.FileExists(ThisDocument.Path & "\" & my_doc_name) Then
Set my_doc = Documents.Open(ThisDocument.Path & "\" & my_doc_name)
Else
Set my_doc = Documents.Add
my_doc.SaveAs2 ThisDocument.Path & "\" & my_doc_name
End If
my_doc.Activate ' Although it should already be visible
my_doc.content.Delete
Set my_text_box = my_doc.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
left:=400, _
top:=100, _
Width:=250, _
Height:=60)
With my_text_box
.Name = "TextBox1"
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.left = wdShapeRight
.top = wdShapeTop
With .TextFrame
.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
Set my_range = my_text_box.Parent.Paragraphs(1).Range
'FROM
'
' https://learn.microsoft.com/en-us/office/vba/api/word.shape'
' Every Shape object is anchored to a range of text. A shape is anchored
' to the beginning of the first paragraph that contains the anchoring
' range. The shape will always remain on the same page as its anchor.
my_range.Collapse Direction:=wdCollapseEnd
With my_range
For counter = 1 To 90
.Text = counter
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
Next
End With
End Sub
I whould like to fill a word with values and export to pdf multiple times.
If is use a SaveAs2 the firt time it make a pdf but second or third it doesen't work.
'ActiveDocument.SaveAs2 FileName:="C:\alap\" & fajlneve & ".pdf", FileFormat:=wdFormatPDF
If I use the CutePDf printer, the result is the same, first time i=1 it works, but second it doesen't.
Public compname As String
Public filename As String
Function FillwordForm()
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Error.Clear
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
Path = "C:\pelda\MINTA.docx"
Set doc = appword.Documents.Open(Path, , True)
With doc
.formfields("szerzCegnev").result = compname
End With
appword.Visible = True
appword.Activate
Set doc = Nothing
Set appword = Nothing
appword.ActivePrinter = "CutePDF Writer"
ActiveDocument.PrintOut OutPutFileName:="C:\pelda\" & filename & ".pdf"
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Word.Application.Quit
End Function
'---------------------------------------------------------------
Sub cucc()
For i = 1 To 2
compname = Cells(i, 1)
filename = Cells(i, 2)
Call FillwordForm
Next i
End Sub
can you use:
ActiveDocument.SaveAs2(docname,17);
?
(17 is PDF-format -link to fileformats)
Greetz
I am trying to get the personalized message working. I have difficulty in sending pictures and text while preserving the text formatting (bold, italic,...).
I read on a related subject on this website regarding a similar problem (Preserve text format when sending the content of a word document as the body of an email,). It helped me to get started.
Code I am using:
Sub emailmergewithattachments_2()
Dim Source As Document, Maillist As Document, wdDoc As Document
Dim Datarange As Range
Dim wdRange As Range
Dim i As Long, j As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim Insp As Outlook.Inspector
Dim MySubject As String, Message As String, Title As String
'The source document is Word document that contains the personnalised
'letters sent to the recipients
Set Source = ActiveDocument
' Check if Outlook is running. If it is not, start Outlook
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
' Open the catalog mailmerge document
With Dialogs(wdDialogFileOpen)
.Show
End With
'The Maillist is a 2 column table containing the email adress and the second column
'contains the path and the name of the file to be joined with the email
Set Maillist = ActiveDocument
' Show an input box asking the user for the subject to be inserted into the email messages
Message = "Enter the subject to be used for each email message." ' Set prompt.
Title = " Email Subject Input" ' Set title.
' Display message, title
MySubject = InputBox(Message, Title)
' Iterate through the Sections of the Source document and the rows of the catalog mailmerge document,
' extracting the information to be included in each email.
For j = 1 To Source.Sections.Count - 1
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Subject = MySubject 'subject line
'reading the first column of the maillist (the email)
Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
Datarange.End = Datarange.End - 1
.To = Datarange 'recipient's email
'joining the personalised attachements to each recipient
For i = 2 To Maillist.Tables(1).Columns.Count
Set Datarange = Maillist.Tables(1).Cell(j, i).Range
Datarange.End = Datarange.End - 1
.Attachments.Add Trim(Datarange.Text), olByValue, 1
Next i
'Obtain the Inspector for this Email
Set Insp = oItem.GetInspector
'Obtain the Word document for the Inspector
Set wdDoc = Insp.WordEditor
'Use the Range object to insert text
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
wdRange.InsertAfter ("Text inserted") 'for testing only (to check if it really working)
'Word document containing the text and the images
Windows("lettres.docx").Activate
Selection.WholeStory
'*******************************************************************************
'Problematic part: trying to paste the selection into wdDoc while preserving the formatting
'and the entire content of the document of the file "lettres.docx"
'...missing code
'********************************************************************************
.Send
End With
Set oItem = Nothing
Next j
Maillist.Close wdDoNotSaveChanges
' Close Outlook if it was started by this macro.
If bStarted Then
oOutlookApp.Quit
End If
MsgBox Source.Sections.Count - 1 & " messages have been sent."
'Clean up
Set oOutlookApp = Nothing
End Sub
I took a different approach. I did a regular mail merge in MS Word and sent the mail in HTML format which keeps all the formatting and the graphics. Then in Outlook, i created a macro which adds the attachments when each email is sent. An Excel worksheet contains the path of files to be joined for each email.
==> important note: Outlook must be opened (application loaded) before sending the data from Word to Outlook or else the emails will likely get stuck in the outbox and as a result the macro will simply not work (emails will be sent but with no attachments)
Code in a ThisOutlookSession:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If Item.Class = olMail Then
Dim objCurrentMessage As MailItem
Set objCurrentMessage = Item
If UCase(objCurrentMessage.Subject) Like "PUBLIIDEM*" Then
On Error Resume Next
'Pour ajouter la même PJ à tous
Dim i As Long
i = 0
If publipostagePJ <> "" Then
While publipostagePJ(i) <> "fin"
objCurrentMessage.Attachments.Add Source:=publipostagePJ(i)
i = i + 1
Wend
End If
'On supprime le terme PUBLIIDEM du sujet
objCurrentMessage.Subject = Replace(objCurrentMessage.Subject, "PUBLIIDEM ", "")
ElseIf UCase(objCurrentMessage.Subject) Like "PUBLIPERSO*" Then
If Chemin = "" Then
Chemin = InputBox("Entrez le chemin d'accès et le nom du fichier:", "Envoies personnalisés")
On Error Resume Next
Set oExcelApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set oExcelApp = CreateObject("Excel.Application")
bStarted = True
End If
Workbooks.Open Chemin
Set oWB = Excel.ActiveWorkbook
oWB.Sheets("fichiers").Select
DerniereLigne = Cells(Rows.Count, 1).End(xlUp).Row
'DerniereColonne = Cells(1, Columns.Count).End(xlToLeft).Column
End If
For i = 1 To DerniereLigne
If Cells(i, 1) = objCurrentMessage.To Then
For j = 2 To 5
FichierJoin = Cells(i, j)
If Len(FichierJoin) > 0 Then objCurrentMessage.Attachments.Add Source:=FichierJoin
Next j
End If
Next i
'On supprime le terme PUBLIPERSO du sujet
objCurrentMessage.Subject = Replace(UCase(objCurrentMessage.Subject), "PUBLIPERSO ", "")
End If
Set objCurrentMessage = Nothing
End If
End Sub
Private Sub Application_Quit()
If bStarted Then
oExcelApp.Quit
End If
Set oExcelApp = Nothing
Set oWB = Nothing
End Sub
Code in a module
Public publipostagePJ As Variant
Public oExcelApp As Excel.Application
Public oWB As Excel.Workbook
Public DerniereLigne As Long
Public DerniereColonne As Long
Public bStarted As Boolean
Public FichierJoin, Chemin As String
Sub setPublipostage()
On Error Resume Next
If publipostagePJ(0) = "" Then publipostagePJ = Array("fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin")
While publipostagePJ(i) <> "fin"
contenu = contenu & vbCr & publipostagePJ(i)
i = i + 1
Wend
If contenu = "" Then contenu = "vide"
modifier = MsgBox(contenu & vbCr & "Voulez vous modifier les fichiers ?", vbYesNo, "Fichiers paramétrés")
If modifier = vbYes Then
For i = 0 To 9
If i > 0 Then encore = MsgBox("un autre ?", vbYesNo)
quest:
If encore <> vbNo Then
PJ = InputBox("Emplacement du fichier joint au PUBLIPOSTAGE?", _
"Paramétrage du PUBLIPOSTAGE pour la session", publipostagePJ(i))
If "" = Dir(PJ, vbNormal) Then GoTo quest
publipostagePJ(i) = PJ
Else: Exit For
End If
Next i
End If
MsgBox "Votre publipostage doit comporter le terme :" & vbCr & "PUBLIIDEM" & vbCr & "dans le sujet." & vbCr & "Celui-ci sera retiré lors de l'envoi"
End Sub
'This code is inside an module of a Workbook.
Sub Notes_Email_Excel_Cells2()
Application.WindowState = xlNormal
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim WordApp As Object
Dim subject As String
Dim dd As String
Dim stAttachment As String
Dim obAttachment As Object, EmbedObject As Object
Const EMBED_ATTACHMENT As Long = 1454
Dim Wb As Workbook
Dim FirstCell As Range, LastCell As Range
Dim CC(1)
CC(1) = "yyy#itc.in,"
If bIsBookOpen("Daily Beetle Count Report - MMGR.xlsx") = True Then
Set Wb = Workbooks("Daily Beetle Count Report - MMGR.xlsx")
Else
Workbooks.Open ("B:\Sangeet\Daily Beetle Count Report - MMGR.xlsx")
Set Wb = Workbooks("Daily Beetle Count Report - MMGR.xlsx")
End If
Set NSession = CreateObject("Notes.NotesSession")
'Next line only works with 5.x and above. Replace password with your password
subject = "HOT SPOTS Infestation " & Now
Debug.Print subject
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
'Create a new Lotus Notes document
Set NDoc = NDatabase.CreateDocument
stAttachment = ActiveWorkbook.FullName
Set obAttachment = NDoc.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
With NDoc
.SendTo = "xxx#itc.in" 'CHANGE RECIPIENT EMAIL ADDRESS
.CopyTo = ""
.subject = subject
'Email body text, including marker text which will be replaced by the Excel cells
.body = "Dear All," & vbLf & vbLf & "Please find the Hotspot areas" & vbLf & vbLf & _
"**PASTE HERE**" & vbLf & vbLf & vbLf & vbLf & _
"Auto Generated Mail. Please Donot Reply."
.Save True, False
End With
'Edit the just-created document to copy and paste the Excel cells into it via Word
Set NUIdoc = NUIWorkSpace.EDITDocument(True, NDoc)
With NUIdoc
'Find the marker text in the Body item
.GotoField ("Body")
.FINDSTRING "**PASTE HERE**"
'.DESELECTALL 'Uncomment to leave the marker text in place (cells are inserted immediately before)
'Copy Excel cells to clipboard
Wb.Sheets("HOT SPOT").Activate
Sheets("HOT SPOT").Range("v2:w21").Copy 'CHANGE SHEET AND RANGE TO BE COPIED AND PASTED
'Create a temporary Word Document
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False 'True to aid debugging
WordApp.Documents.Add
'Paste into Word document and copy to clipboard
With WordApp.Selection
.PasteSpecial DataType:=10 'Enum WdPasteDataType: 10 = HTML; 2 = Text; 1 = RTF
.WholeStory
.Copy
End With
'Paste from clipboard (Word) to Lotus Notes document
.Paste
Application.CutCopyMode = False
WordApp.Quit SaveChanges:=False
Set WordApp = Nothing
.Send
.Close
End With
Set NSession = Nothing
If bIsBookOpen("Daily Beetle Count Report - MMGR.xlsx") Then
Workbooks("Daily Beetle Count Report - MMGR.xlsx").Close SaveChanges:=False
Else
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
I created a macro in excel vba to process a list of file that I need to copy from a "source path" to a "target path". When copied I also need to remove the protection of the .doc file.
Everything is working perfectly fine but only on my station. When I try it on two others stations I get the following error message:
"Run time error '2147319779 (8002801d)'
Automation error
Library not registered"
Here's what I already checked: I've checked for the VBA references in Excel and Word and they are the same.
From what I can found on other forums it could be some hexkeys problem, but I'm so afraid of playing into this, and also the solution that was proposed wasn't working (I couldn't find the appropriate reg key on the problem station).
I also tried adding some delay, but still no luck
Here's my code below
Sub copy_file_and_unprotect()
Dim ws As Worksheet
Dim wb As Workbook
Dim original_name As String
Dim copied_name As String
Dim WdApp As Object
Dim source_path As String
Dim target_path As String
Dim pwd As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Liste de vérification") 'where the original folder is stored
target_path = ws.Cells(1, 6) & "\Sections de devis type"
Set ws = wb.Worksheets("Nom des divisions")
source_path = ws.Cells(4, 5) 'where the file will be copied
pwd = "cimaqc123" 'password to unprotect the file
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Plan de travail")
lig = 11
col = 26
Set WdApp = CreateObject("Word.Application")
While ws.Cells(lig, col) <> "" 'loop to copy & unprotect a list of file
num_sec = ws.Cells(lig, col)
nom_sec = ws.Cells(lig, col + 2)
file_name = num_sec & " - " & nom_sec & ".doc" 'name of the original file to be copied
F = Dir(source_path & "\" & "*.doc") 'loop to search thru the source file for the file "file_name"
Do While Len(F) > 0
If F = file_name Then '
original_name = source_path & "\" & F 'path and name of file to be copied
copied_name = target_path & "\" & file_name 'path and name of new file to be unlocked later on
FileCopy original_name, copied_name 'copying of the file
'-----THIS IS WHERE I GET THE ERROR MESSAGE AFTER THE FOLLOWING LINE-----
Set WdApp = Documents.Open(copied_name)
If Not WdApp.ProtectionType = -1 Then 'unprotect the file
WdApp.Unprotect pwd
WdApp.Close True
Else
WdApp.Close True
End If
GoTo file_copied:
End If
F = Dir()
Loop
file_copied:
lig = lig + 1 'on passe à la prochaine section de devis
Wend
End Sub
Could anyone share some taughts about this? How can I resolve the error message I get?
With the help from #KenWhite here's the updated code with error resolved
Sub copy_file_and_unprotect()
Dim ws As Worksheet
Dim wb As Workbook
Dim original_name As String
Dim copied_name As String
Dim WdApp As Object
Dim WdDoc As Object
Dim source_path As String
Dim target_path As String
Dim pwd As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Liste de vérification") 'where the original folder is stored
target_path = ws.Cells(1, 6) & "\Sections de devis type"
Set ws = wb.Worksheets("Nom des divisions")
source_path = ws.Cells(4, 5) 'where the file will be copied
pwd = "cimaqc123" 'password to unprotect the file
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Plan de travail")
lig = 11
col = 26
Set WdApp = CreateObject("Word.Application")
While ws.Cells(lig, col) <> "" 'loop to copy & unprotect a list of file
num_sec = ws.Cells(lig, col)
nom_sec = ws.Cells(lig, col + 2)
file_name = num_sec & " - " & nom_sec & ".doc" 'name of the original file to be copied
F = Dir(source_path & "\" & "*.doc") 'loop to search thru the source file for the file "file_name"
Do While Len(F) > 0
If F = file_name Then '
original_name = source_path & "\" & F 'path and name of file to be copied
copied_name = target_path & "\" & file_name 'path and name of new file to be unlocked later on
FileCopy original_name, copied_name 'copying of the file
'----------------LINE BELOW IS WHERE IT WAS CAUSING PROBLEM -------------------------
Set WdDoc = WdApp.Documents.Open(copied_name) 'line that was add
'Set WdApp = Documents.Open(copied_name) 'line that was removed
If Not WdDoc.ProtectionType = -1 Then 'unprotect the file
WdDoc.Unprotect pwd 'replaced WdApp by WdDoc
WdDoc.Save
WdDoc.Close True
Else
WdDoc.Close True
End If
GoTo file_copied:
End If
F = Dir()
Loop
file_copied:
lig = lig + 1
Wend
End Sub