Populate Comments property from paragraph items

[phorest]

Hello,

Searching for something like this for many hours and still no luck.
I have an account that provides me with approx. 300 word documents a month.
I process these in batches and send them to a file server for further action.
Is it possible to write a script or macro to take the first 4 paragraphs and
insert that data into the document properties with BuiltinDocumentProperties?

I have tried recording a macro, and using keyboard shortcuts to copy the
paragraphs and pasting into the properties doesn't work.

Paragraph 1 is always Name [To Subject Field]
Paragraph 2 is always Date [To Keywords]
Paragraph 3 is always Account Number [Also to Keywords]
Paragraph 4 is alwayds chief complaint [To comments]

Thanks for any help on this in advance!

 

[phorest]

I figured it out. I need to do a two script transformation. First, I rename
the files with the paragraph information I needed: paragraphs 1 through 4.

It's too bad that there aren't many examples of working DSO scripts as it
seems to me that writing extended document properties in a batch is extremely
useful. My specific need was to make SearchServer 2008 Beta to work better
with word files which are converted to PDF files. I hope this can help
someone down the road.

'+++++++++++++++++ Start Script 1 ++++++++++++++++++++

'FilenamesFromWordParagraphs
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("I:\transcripts\DSO1")

Set objWord = CreateObject("Word.Application")
objWord.Visible = False

For Each objFile in objFolder.Files
Set objDoc = objWord.Documents.Open(objFile.Path)

strText = objDoc.Paragraphs(1).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
strUserName = arrText(intIndex)

arrUserName = Split(strUserName, " ")
intLength = Len(arrUserName(1))
strName = Left(arrUserName(1), intlength - 1)

strUserName = strName & ", " & arrUserName(0)

strText = objDoc.Paragraphs(2).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)

strDate = arrText(intIndex)
strDate = Replace(strDate, "/", "")

intLength = Len(strDate)
strDate = Left(strDate, intlength - 1)

'++++++++++++++++++ NEW Para 1 ++++++++++++++++++++

strText = objDoc.Paragraphs(3).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str3 = arrText(intIndex)

intLength = Len(str3)
str3 = Left(str3, intlength - 1)

'++++++++++++++++++ NEW Para 2 ++++++++++++++++++++

strText = objDoc.Paragraphs(4).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str4 = arrText(intIndex)

intLength = Len(str4)
str4 = Left(str4, intlength -1)

'++++++++++++++++++ NEW Para 3 ++++++++++++++++++++

strText = objDoc.Paragraphs(5).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str5 = arrText(intIndex)
str5 = Replace(str5, "/" , "")


intLength = Len(str5)
str5 = Left(str5, 6)
On Error Resume Next

strUserName = strName & ", " & arrUserName(0)

strFileName = "I:\transcripts\DSO3\" & strUserName & " " & strDate &" "
& str3 &" " & str4 &" " & str5 & ".doc"

objDoc.Close
Wscript.Sleep 2000

Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile objFile.Path, strFileName
Next
wscript.echo "All done: I:\transcripts\DSO3\ will open when you click OK! "
objWord.Quit

'+++++++++++++++++++++++ End Script +++++++++++++++++++

Then with this script, I am able to create an array of the renamed files,
and write to the properties as I see fit.

'++++++++++++++++++++ Start script2 ++++++++++++++++++++

'FillPropertiesFromFilename


Dim DocLocation
DocLocation = "I:\transcripts\DSO3"

Dim fso
Dim f
Dim f1
Dim fc
Dim sFileName


Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(DocLocation)
Set fc = f.Files

'Read filenames

For Each f1 in fc
sFileName = f1.Name

i = 0
Do While i < 3
i = i + 1
If i = 1 Then
If Lcase(Right(sFileName, 3)) <> Lcase("doc") Then
Exit Do
End If
ElseIf i = 2 Then

Set objFile = CreateObject("DSOFile.OleDocumentProperties")
CurrFile = f1.Path
objFile.Open(CurrFile)

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFile = oFSO.GetFile(CurrFile)

'+++++++++++++++++++ String Component Array +++++++++++++++++++++++++++++

strText=sFileName

temp = trim(mid(strText, instr(strText,",")+1))
lastname = trim(left(strText, instr(strText,",")))
pos1 = instr(temp," ")
firstname = trim(left(temp, pos1))

temp = trim(mid(temp, instr(temp," ")+1))
item1 = lastname & " " & firstname

item2 = trim(left(temp, instr(temp," ")))

pos2 = instrrev(temp," ")
temp = trim(mid(temp, pos2+1))
item3 = trim(left(temp, instr(temp,".")-1))

item4 = mid(strText, pos1, instrrev(strText," ")-pos1+1)


PropDateCreated = oFile.DateCreated
PropDateLastModified = oFile.DateLastModified
PropFileName = oFSO.GetFileName(CurrFile)

WrPropCategory = PropLastModified
WrPropTitle = PropFileName

objFile.SummaryProperties.Title = WrPropTitle
objFile.SummaryProperties.Subject = "Notes" & " " & item2
objFile.SummaryProperties.Category = "Transcribed Files " & item3
objFile.SummaryProperties.Keywords = Item2 & ", " & item3 & ", " & Item4
objFile.SummaryProperties.Comments = PropDateCreated
objFile.SummaryProperties.Author = WrPropTitle


objFile.Save
End If
Loop
Next
wscript.echo "All Files have been handled"

Hello,

Searching for something like this for many hours and still no luck.
I have an account that provides me with approx. 300 word documents a month.
I process these in batches and send them to a file server for further action.
Is it possible to write a script or macro to take the first 4 paragraphs and
insert that data into the document properties with BuiltinDocumentProperties?

I have tried recording a macro, and using keyboard shortcuts to copy the
paragraphs and pasting into the properties doesn't work.

Paragraph 1 is always Name [To Subject Field]
Paragraph 2 is always Date [To Keywords]
Paragraph 3 is always Account Number [Also to Keywords]
Paragraph 4 is alwayds chief complaint [To comments]

Thanks for any help on this in advance!

 

[fumei via OfficeKB.com]

Paragraph 1 is always Name [To Subject Field]
Paragraph 2 is always Date [To Keywords]
Paragraph 3 is always Account Number [Also to Keywords]
Paragraph 4 is alwayds chief complaint [To comments]

You do not state what application you are running this from. You are making
a instance of Word , but I do not know from where. The reason I wonder is
that you may be able to use Dir.

Sub AddProps()
Dim file
Dim path As String
Dim WorkingDoc As Word.Document
path = "c:\test\"
file = Dir(path & "*.doc")
Do While file <> ""
Set Working Doc = objWord.Documents.Open Filename:= path & file
With WorkingDoc
.BuiltinDocumentProperties(“Subjectâ€) = _
WorkingDoc.Range.Paragraphs(1).Range.Text
.BuiltinDocumentProperties(“Keywordsâ€) = _
WorkingDoc.Range.Paragraphs(2).Range.Text
‘ for Keywords, you can either use both paragraphs together,
‘ OR you can append, like this: paragraph 2 first (ABOVE) , then
‘ paragraph 3
.BuiltinDocumentProperties(“Keywordsâ€) = _
WorkingDoc.BuiltinDocumentProperties(“Keywordsâ€) & _
Range.Paragraphs(3).Range.Text
.BuiltinDocumentProperties(“Commentsâ€) = _
WorkingDoc.Range.Paragraphs(1).Range.Text
.Save
.Close
End With
Set WorkingDoc = Nothing
File = Dir
Loop

The above would loop through all .doc files in c:\test and:

make the Subject = paragraph 1
put paragraph 2 and paragraph 3 into Keywords
put paragraph 4 into Comments
Save
Close
go to next doc file

I figured it out. I need to do a two script transformation. First, I rename
the files with the paragraph information I needed: paragraphs 1 through 4.

It's too bad that there aren't many examples of working DSO scripts as it
seems to me that writing extended document properties in a batch is extremely
useful. My specific need was to make SearchServer 2008 Beta to work better
with word files which are converted to PDF files. I hope this can help
someone down the road.

'+++++++++++++++++ Start Script 1 ++++++++++++++++++++

'FilenamesFromWordParagraphs
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("I:\transcripts\DSO1")

Set objWord = CreateObject("Word.Application")
objWord.Visible = False

For Each objFile in objFolder.Files
Set objDoc = objWord.Documents.Open(objFile.Path)

strText = objDoc.Paragraphs(1).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
strUserName = arrText(intIndex)

arrUserName = Split(strUserName, " ")
intLength = Len(arrUserName(1))
strName = Left(arrUserName(1), intlength - 1)

strUserName = strName & ", " & arrUserName(0)

strText = objDoc.Paragraphs(2).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)

strDate = arrText(intIndex)
strDate = Replace(strDate, "/", "")

intLength = Len(strDate)
strDate = Left(strDate, intlength - 1)

'++++++++++++++++++ NEW Para 1 ++++++++++++++++++++

strText = objDoc.Paragraphs(3).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str3 = arrText(intIndex)

intLength = Len(str3)
str3 = Left(str3, intlength - 1)

'++++++++++++++++++ NEW Para 2 ++++++++++++++++++++

strText = objDoc.Paragraphs(4).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str4 = arrText(intIndex)

intLength = Len(str4)
str4 = Left(str4, intlength -1)

'++++++++++++++++++ NEW Para 3 ++++++++++++++++++++

strText = objDoc.Paragraphs(5).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str5 = arrText(intIndex)
str5 = Replace(str5, "/" , "")


intLength = Len(str5)
str5 = Left(str5, 6)
On Error Resume Next

strUserName = strName & ", " & arrUserName(0)

strFileName = "I:\transcripts\DSO3\" & strUserName & " " & strDate &" "
& str3 &" " & str4 &" " & str5 & ".doc"

objDoc.Close
Wscript.Sleep 2000

Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile objFile.Path, strFileName
Next
wscript.echo "All done: I:\transcripts\DSO3\ will open when you click OK! "
objWord.Quit

'+++++++++++++++++++++++ End Script +++++++++++++++++++

Then with this script, I am able to create an array of the renamed files,
and write to the properties as I see fit.

'++++++++++++++++++++ Start script2 ++++++++++++++++++++

'FillPropertiesFromFilename

Dim DocLocation
DocLocation = "I:\transcripts\DSO3"

Dim fso
Dim f
Dim f1
Dim fc
Dim sFileName

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(DocLocation)
Set fc = f.Files

'Read filenames

For Each f1 in fc
sFileName = f1.Name

i = 0
Do While i < 3
i = i + 1
If i = 1 Then
If Lcase(Right(sFileName, 3)) <> Lcase("doc") Then
Exit Do
End If
ElseIf i = 2 Then

Set objFile = CreateObject("DSOFile.OleDocumentProperties")
CurrFile = f1.Path
objFile.Open(CurrFile)

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFile = oFSO.GetFile(CurrFile)

'+++++++++++++++++++ String Component Array +++++++++++++++++++++++++++++

strText=sFileName

temp = trim(mid(strText, instr(strText,",")+1))
lastname = trim(left(strText, instr(strText,",")))
pos1 = instr(temp," ")
firstname = trim(left(temp, pos1))

temp = trim(mid(temp, instr(temp," ")+1))
item1 = lastname & " " & firstname

item2 = trim(left(temp, instr(temp," ")))

pos2 = instrrev(temp," ")
temp = trim(mid(temp, pos2+1))
item3 = trim(left(temp, instr(temp,".")-1))

item4 = mid(strText, pos1, instrrev(strText," ")-pos1+1)

PropDateCreated = oFile.DateCreated
PropDateLastModified = oFile.DateLastModified
PropFileName = oFSO.GetFileName(CurrFile)

WrPropCategory = PropLastModified
WrPropTitle = PropFileName

objFile.SummaryProperties.Title = WrPropTitle
objFile.SummaryProperties.Subject = "Notes" & " " & item2
objFile.SummaryProperties.Category = "Transcribed Files " & item3
objFile.SummaryProperties.Keywords = Item2 & ", " & item3 & ", " & Item4
objFile.SummaryProperties.Comments = PropDateCreated
objFile.SummaryProperties.Author = WrPropTitle

objFile.Save
End If
Loop
Next
wscript.echo "All Files have been handled"

Hello,

[quoted text clipped - 13 lines]

Thanks for any help on this in advance!

 

[phorest]

Howdy,

Well it's actually a wsh script. I am a little more comfortable with them. A
note about the paragraphs: I have to split them on a tab as there are common
paragraph content. e.g.
Customer Name: vbTab vbTab FirstName LastName
Encounter Date: vbTab vbTab mm/dd/yy

I don't have time tonight to try out your version, but it looks a little
lighter-weight compared to what I have. My problem is I am supposed to
implement on March 1st... oops

Thanks!

Paragraph 1 is always Name [To Subject Field]
Paragraph 2 is always Date [To Keywords]
Paragraph 3 is always Account Number [Also to Keywords]
Paragraph 4 is alwayds chief complaint [To comments]

You do not state what application you are running this from. You are making
a instance of Word , but I do not know from where. The reason I wonder is
that you may be able to use Dir.

Sub AddProps()
Dim file
Dim path As String
Dim WorkingDoc As Word.Document
path = "c:\test\"
file = Dir(path & "*.doc")
Do While file <> ""
Set Working Doc = objWord.Documents.Open Filename:= path & file
With WorkingDoc
.BuiltinDocumentProperties(“Subjectâ€) = _
WorkingDoc.Range.Paragraphs(1).Range.Text
.BuiltinDocumentProperties(“Keywordsâ€) = _
WorkingDoc.Range.Paragraphs(2).Range.Text
‘ for Keywords, you can either use both paragraphs together,
‘ OR you can append, like this: paragraph 2 first (ABOVE) , then
‘ paragraph 3
.BuiltinDocumentProperties(“Keywordsâ€) = _
WorkingDoc.BuiltinDocumentProperties(“Keywordsâ€) & _
Range.Paragraphs(3).Range.Text
.BuiltinDocumentProperties(“Commentsâ€) = _
WorkingDoc.Range.Paragraphs(1).Range.Text
.Save
.Close
End With
Set WorkingDoc = Nothing
File = Dir
Loop

The above would loop through all .doc files in c:\test and:

make the Subject = paragraph 1
put paragraph 2 and paragraph 3 into Keywords
put paragraph 4 into Comments
Save
Close
go to next doc file

I figured it out. I need to do a two script transformation. First, I rename
the files with the paragraph information I needed: paragraphs 1 through 4.

It's too bad that there aren't many examples of working DSO scripts as it
seems to me that writing extended document properties in a batch is extremely
useful. My specific need was to make SearchServer 2008 Beta to work better
with word files which are converted to PDF files. I hope this can help
someone down the road.

'+++++++++++++++++ Start Script 1 ++++++++++++++++++++

'FilenamesFromWordParagraphs
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("I:\transcripts\DSO1")

Set objWord = CreateObject("Word.Application")
objWord.Visible = False

For Each objFile in objFolder.Files
Set objDoc = objWord.Documents.Open(objFile.Path)

strText = objDoc.Paragraphs(1).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
strUserName = arrText(intIndex)

arrUserName = Split(strUserName, " ")
intLength = Len(arrUserName(1))
strName = Left(arrUserName(1), intlength - 1)

strUserName = strName & ", " & arrUserName(0)

strText = objDoc.Paragraphs(2).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)

strDate = arrText(intIndex)
strDate = Replace(strDate, "/", "")

intLength = Len(strDate)
strDate = Left(strDate, intlength - 1)

'++++++++++++++++++ NEW Para 1 ++++++++++++++++++++

strText = objDoc.Paragraphs(3).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str3 = arrText(intIndex)

intLength = Len(str3)
str3 = Left(str3, intlength - 1)

'++++++++++++++++++ NEW Para 2 ++++++++++++++++++++

strText = objDoc.Paragraphs(4).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str4 = arrText(intIndex)

intLength = Len(str4)
str4 = Left(str4, intlength -1)

'++++++++++++++++++ NEW Para 3 ++++++++++++++++++++

strText = objDoc.Paragraphs(5).Range.Text
arrText = Split(strText, vbTab)
intIndex = Ubound(arrText)
str5 = arrText(intIndex)
str5 = Replace(str5, "/" , "")


intLength = Len(str5)
str5 = Left(str5, 6)
On Error Resume Next

strUserName = strName & ", " & arrUserName(0)

strFileName = "I:\transcripts\DSO3\" & strUserName & " " & strDate &" "
& str3 &" " & str4 &" " & str5 & ".doc"

objDoc.Close
Wscript.Sleep 2000

Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile objFile.Path, strFileName
Next
wscript.echo "All done: I:\transcripts\DSO3\ will open when you click OK! "
objWord.Quit

'+++++++++++++++++++++++ End Script +++++++++++++++++++

Then with this script, I am able to create an array of the renamed files,
and write to the properties as I see fit.

'++++++++++++++++++++ Start script2 ++++++++++++++++++++

'FillPropertiesFromFilename

Dim DocLocation
DocLocation = "I:\transcripts\DSO3"

Dim fso
Dim f
Dim f1
Dim fc
Dim sFileName

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(DocLocation)
Set fc = f.Files

'Read filenames

For Each f1 in fc
sFileName = f1.Name

i = 0
Do While i < 3
i = i + 1
If i = 1 Then
If Lcase(Right(sFileName, 3)) <> Lcase("doc") Then
Exit Do
End If
ElseIf i = 2 Then

Set objFile = CreateObject("DSOFile.OleDocumentProperties")
CurrFile = f1.Path
objFile.Open(CurrFile)

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFile = oFSO.GetFile(CurrFile)

'+++++++++++++++++++ String Component Array +++++++++++++++++++++++++++++

strText=sFileName

temp = trim(mid(strText, instr(strText,",")+1))
lastname = trim(left(strText, instr(strText,",")))
pos1 = instr(temp," ")
firstname = trim(left(temp, pos1))

temp = trim(mid(temp, instr(temp," ")+1))
item1 = lastname & " " & firstname

item2 = trim(left(temp, instr(temp," ")))

pos2 = instrrev(temp," ")
temp = trim(mid(temp, pos2+1))
item3 = trim(left(temp, instr(temp,".")-1))

item4 = mid(strText, pos1, instrrev(strText," ")-pos1+1)

PropDateCreated = oFile.DateCreated
PropDateLastModified = oFile.DateLastModified
PropFileName = oFSO.GetFileName(CurrFile)

WrPropCategory = PropLastModified
WrPropTitle = PropFileName

objFile.SummaryProperties.Title = WrPropTitle
objFile.SummaryProperties.Subject = "Notes" & " " & item2
objFile.SummaryProperties.Category = "Transcribed Files " & item3
objFile.SummaryProperties.Keywords = Item2 & ", " & item3 & ", " & Item4
objFile.SummaryProperties.Comments = PropDateCreated
objFile.SummaryProperties.Author = WrPropTitle

objFile.Save
End If
Loop
Next
wscript.echo "All Files have been handled"

Hello,

[quoted text clipped - 13 lines]

Thanks for any help on this in advance!

 

[fumei via OfficeKB.com]

Oh, I did nothing with your strings of the paragraphs. You have some fancy
string manipulations going on. Personally I would do that part as wee
Functions, and use them.

Function GetSubject(strIn As String) As String
' yadda yadda
' do your stuff
End Function


then in the main procedure:

With WorkingDoc
.BuiltInDocumentProperties(“Subjectâ€) = _
GetSubject(WorkingDoc.Range.Paragraphs(1).Range.Text)
End Sub

Light-weight? Perhaps. Yours seems overly heavy, but I don't really know
what your situation is.

Howdy,

Well it's actually a wsh script. I am a little more comfortable with them. A
note about the paragraphs: I have to split them on a tab as there are common
paragraph content. e.g.
Customer Name: vbTab vbTab FirstName LastName
Encounter Date: vbTab vbTab mm/dd/yy

I don't have time tonight to try out your version, but it looks a little
lighter-weight compared to what I have. My problem is I am supposed to
implement on March 1st... oops

Thanks!

Paragraph 1 is always Name [To Subject Field]
Paragraph 2 is always Date [To Keywords]

[quoted text clipped - 219 lines]