microsoft.public.word.vba.general

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!

"fumei via OfficeKB.com" wrote:

> 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
>
> phorest wrote:
> >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!
>
> --
> Message posted via OfficeKB.com
> http://www.officekb.com/Uwe/Forums.aspx/word-programming/200803/1
>
>