• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Word Macro for inspecting document and removing 3 types of property

A

ananthram

New Member
Hi all,


I am using below macro to remove Document Properties, Personal Information & Custom XML Data. but what i am facing is when i run this macro all the .docx files will be as same extension. But when .doc and .docx will be mixed in the folder then it automatically changes .doc file extension to .rtf and .docx remains the same. Please help me to maintain same extension and let me know if other than removing property what all it does...Thanks in Advance.

Code: 
Sub Inspection()
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String, DocSrc As Document
'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub
strFile = Dir(strInFold & "*.docx", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFold & "Inspected"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFold & "*.docx", vbNormal)
'Process all documents in the chosen folder
While strFile <> ""
Set DocSrc = Documents.Open(FileName:=strInFold & "" & strFile, AddTorecentFiles:=False, Visible:=False)
With DocSrc
'remove personal information
.RemoveDocumentInformation (wdRDIDocumentProperties)
.RemoveDocumentInformation (wdRDIDocumentServerProperties)
.RemoveDocumentInformation (wdRDIContentType)
'String variable for the output filenames
strOutFile = strOutFold & Split(.Name, ".")(0)
'Save and close the document
.SaveAs FileName:=strOutFile
.Close
End With
strFile = Dir()
Wend
Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function
 
Last edited by a moderator:
Hi Ananth Ram ,


I am not sure , but try this ( I have not been able to try it out myself , so I cannot say it will work ) :

Code: 
With DocSrc
sf = .SaveFormat
'remove personal information
.RemoveDocumentInformation (wdRDIDocumentProperties)
.RemoveDocumentInformation (wdRDIDocumentServerProperties)
.RemoveDocumentInformation (wdRDIContentType)
'String variable for the output filenames
strOutFile = strOutFold & Split(.Name, ".")(0)
'Save and close the document
.SaveAs Filename:=strOutFile, FileFormat:=sf
.Close
End With
Replace the above section in your original code with this slightly modified code.


Narayan
 
Last edited by a moderator:
Sir it actually dint work what i am doubting on is


Code: 
trFile = Dir(strInFold & "*.docx", vbNormal)

or

strFile = Dir(strInFold & "*.docx", vbNormal)


has problem with it.
 
Last edited by a moderator:
Hi Ananth Ram ,


I am sorry I cannot help out in this problem , since I am not able to run the macro on my system ; it generates an error : ActiveX component can't create object


Only if this error can be resolved , I can go ahead and try to troubleshoot your macro.


Narayan
 
Narayan,


Did you try to run this macro from Excel?


Ananthram,

Does the following work as intended.

Code: 
Sub Inspection()
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String, DocSrc As Document

'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub

strFile = Dir(strInFold & "*.doc*", vbNormal)
'Check for documents in the folder - exit if none found
If strFile = "" Then Exit Sub

If strFile <> "" Then strOutFold = strInFold & "Inspected"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold

strFile = Dir(strInFold & "*.doc*", vbNormal)
'Process all documents in the chosen folder
While strFile <> ""
Set DocSrc = Documents.Open(FileName:=strInFold & "" & strFile, AddTorecentFiles:=False, Visible:=False)
With DocSrc
'remove personal information
.RemoveDocumentInformation (wdRDIDocumentProperties)
.RemoveDocumentInformation (wdRDIDocumentServerProperties)
.RemoveDocumentInformation (wdRDIContentType)
'String variable for the output filenames
strOutFile = strOutFold & .Name
'Save and close the document
.SaveAs FileName:=strOutFile
.Close
End With
strFile = Dir()
Wend

Set DocSrc = Nothing

Application.ScreenUpdating = True
End Sub

Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function
 
Last edited:
Hi Narayan,


I had also come across this and I had tried to find it out:

http://www.mrexcel.com/forum/excel-...429-activex-component-cant-create-object.html


In my opinion, it requires at least one instance of parent application (hidden / visible) running at the time of executing this code. If it is then the code can be run through Excel no problem. While in that thread, "Crystal"[the other user] said that it was not necessary but then she / anyone didn't reply / gave sample which contradicted the observations.


I could be wrong as I have been many times:)

Following code will run through Excel.

Code: 
Sub RunInspectionThroExcel()
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String, DocSrc As Document
Dim wdApp As Word.Application
Dim boolInstance As Boolean

'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub

strFile = Dir(strInFold & "*.doc*", vbNormal)
'Check for documents in the folder - exit if none found
If strFile = "" Then Exit Sub

If strFile <> "" Then strOutFold = strInFold & "Inspected"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold

'Check if instance of Word is running and set the pointer to it
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
Set wdApp = New Word.Application
boolInstance = True
End If
On Error GoTo 0

strFile = Dir(strInFold & "*.doc*", vbNormal)
'Process all documents in the chosen folder
While strFile <> ""
Set DocSrc = wdApp.Documents.Open(Filename:=strInFold & "" & strFile, AddTorecentFiles:=False, Visible:=False)
With DocSrc
'remove personal information
.RemoveDocumentInformation (wdRDIDocumentProperties)
.RemoveDocumentInformation (wdRDIDocumentServerProperties)
.RemoveDocumentInformation (wdRDIContentType)
'String variable for the output filenames
strOutFile = strOutFold & .Name
'Save and close the document
.SaveAs Filename:=strOutFile
.Close
End With
strFile = Dir()
Wend

Set DocSrc = Nothing

If boolInstance Then
wdApp.Quit
Set wdApp = Nothing
End If

Application.ScreenUpdating = True
End Sub

Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function
 
Last edited:
You must log in or register to reply here.
Back
Top