Open .doc, pick out key words and save with key words. 1

[aarondewberry]

All

I have some code to detach attachments from outlook express to a folder. Now I would like to take it on a step further.
See below example paragraph:

This is for a Jambo pack at 4%. Selling to you for $4000. If you would like.....

What I want to do, is to be able to open up the attachment, and then save the attachment with..
firstly the underlined word (always underlined) and then with the selling price ($4000 in example).
So my example .doc would be saved like this: Jambo_$4000.doc

Is this possible or am I asking a bit too much?

Notes:
The word will always be underlined.
There may also be other currency values in the .doc, but the sentence I want to pull the currency from will always read: Selling to you for $4000.

 

[Remou]

Here we go.

Sub ProcessWordDocs()
Dim wd As Object 'Word.Application
Dim doc As Object 'Word.Document
Dim aDoc
Dim strDoc As String
Dim strProduct As String
Dim strPrice As String
Dim rs As DAO.Recordset
Dim rsProc As DAO.Recordset

   'On Error GoTo ProcessWordDocs_Error

    Set wd = CreateObject("Word.Application")
    
    aDoc = Dir("C:\Docs\*.doc")
    
    Do While aDoc <> ""
    
        strDoc = "C:\Docs\" & aDoc
        Set doc = wd.Documents.Open _
            (FileName:=strDoc, ReadOnly:=True, AddToRecentFiles:=False)
        
            wd.Selection.Find.ClearFormatting
            wd.Selection.Find.Font.Underline = 1 'wdUnderlineSingle
            wd.Selection.Find.Text = ""
            wd.Selection.Find.Wrap = 1 'wdFindContinue

            wd.Selection.Find.Execute
            
            If wd.Selection.Find.Found Then
                strProduct = wd.Selection.Range
            Else
                strProduct = "NONE: " & aDoc
            End If
        
            wd.Selection.Find.ClearFormatting
            wd.Selection.Find.Text = "Selling to you for $"
            wd.Selection.Find.Wrap = 1 'wdFindContinue
            
            wd.Selection.Find.Execute

            'wdWord=2, wdExtend=1
            If wd.Selection.Find.Found Then
                wd.Selection.MoveRight Unit:=2, Count:=1, Extend:=1
                strPrice = Mid(wd.Selection.Range, InStr(wd.Selection.Range, "$"))
            Else
                strPrice = "NONE: " & aDoc
            End If
        
        doc.Close
        
        Debug.Print strProduct, strPrice


        aDoc = Dir
    Loop
    
    Set doc = Nothing
    wd.Quit
    Set wd = Nothing
End Sub

 

[aarondewberry]

Remou your a legend, thanks buddy!

 

[aarondewberry]

Right... pushing my luck a little, if not alot....
The above works perfectly. However..
What I am now trying to do is to add $300 to the $4000 and change it in the word doc. Then I would like to excute the above.

So the doc would end up saving like this:-

Jambo_$4300.doc

And when you open the doc, the sentence "Selling to you for $4000", would now read "Selling to you for $4300"

Many thanks.. again

Note:
Regardless of the original cost in the sentence, I will always want to add $300.

 

[Remou]

This is possible and you have all the ingredients in my post. have fun.

 

[PHV]

A starting point:

...
'wdWord=2, wdExtend=1
If wd.Selection.Find.Found Then
  wd.Selection.MoveRight Unit:=2, Count:=1, Extend:=0
  wd.Selection.EndOf Unit:=2, Extend:=1
  strPrice = "$" & (wd.Selection + 300)
Else
  strPrice = "NONE: " & aDoc
End If
...

I'd revise the Open call and I'd call the SaveAs method before the Close.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[PHV]

would now read "Selling to you for $4300"
Replace this:
strPrice = "$" & (wd.Selection + 300)
with this:
strPrice = wd.Selection + 300
wd.Selection.Text = strPrice
strPrice = "$" & strPrice


Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[aarondewberry]

Thanks for the response PHV.
I have modified the code but I keep getting a runtime error '13' - Type Mismatch on the "strPrice = wd.Selection + 300" line.

Here is the full modified code, to make sure i'm not going wrong...

Sub ProcessWordDocs()
Dim wd As Object 'Word.Application
Dim doc As Object 'Word.Document
Dim aDoc
Dim strDoc As String
Dim strProduct As String
Dim strPrice As String
Dim rs As DAO.Recordset
Dim rsProc As DAO.Recordset

   'On Error GoTo ProcessWordDocs_Error

    Set wd = CreateObject("Word.Application")
    
    aDoc = Dir("C:\Docs\*.doc")
    
    Do While aDoc <> ""
    
        strDoc = "C:\Docs\" & aDoc
        Set doc = wd.Documents.Open _
            (FileName:=strDoc, ReadOnly:=True, AddToRecentFiles:=False)
        
            wd.selection.Find.ClearFormatting
            wd.selection.Find.Font.Underline = 1 'wdUnderlineSingle
            wd.selection.Find.Text = ""
            wd.selection.Find.Wrap = 1 'wdFindContinue

            wd.selection.Find.Execute
            
            If wd.selection.Find.Found Then
                strProduct = wd.selection.Range
            Else
                strProduct = "NONE: " & aDoc
            End If
        
            wd.selection.Find.ClearFormatting
            wd.selection.Find.Text = "The agreed recovery of this stock is £"
            wd.selection.Find.Wrap = 1 'wdFindContinue
            
            wd.selection.Find.Execute

            'wdWord=2, wdExtend=1
            If wd.selection.Find.Found Then
                wd.selection.MoveRight Unit:=2, Count:=1, Extend:=1
                wd.selection.endof Unit:=2, Extend:=1
                strPrice = wd.selection + 300
                wd.selection.Text = strPrice
                strPrice = "£" & strPrice
            Else
                strPrice = "NONE: " & aDoc
            End If
        
        doc.Close
        
        Debug.Print strProduct, strPrice


        aDoc = Dir
    Loop
    
    Set doc = Nothing
    wd.Quit
    Set wd = Nothing
End Sub

 

[PHV]

Replace this:
strPrice = wd.selection + 300
with this:
strPrice = CStr(Val(wd.Selection.Text) + 300)

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Remou]

You may want to change the file from ReadOnly=True.

 

[aarondewberry]

Thanks for the response guys, I don't get the runtime error anymore but we're still not quite there yet.
The sentence I am trying to change, before modification, reads like this.. The agreed recovery of this stock is £2100. I've had to tweek it a bit and change it to pounds, but that should be fine, as per above code in my last post.

When I run the code with PHV's, CStr(.., suggestion, the sentence modifys to leave just this.. 300.
So I am losing the sentence and £ sign, plus it is not summing to the original figure.
Sorry to be a pain guys.

 

[Remou]

Ok.

Sub ProcessWordDocs()
Dim wd As Object 'Word.Application
Dim doc As Object 'Word.Document
Dim aDoc
Dim strDoc As String
Dim strProduct As String
Dim strPrice As String
Dim strDocName
Dim rs As DAO.Recordset
Dim rsProc As DAO.Recordset

   'On Error GoTo ProcessWordDocs_Error

    Set wd = CreateObject("Word.Application")
    wd.Visible = True
    aDoc = Dir("C:\Docs\*.doc")
    
    Do While aDoc <> ""
    
        strDoc = "C:\Docs\" & aDoc
        Set doc = wd.Documents.Open _
            (FileName:=strDoc, AddToRecentFiles:=False)
        
            wd.selection.Find.ClearFormatting
            wd.selection.Find.Font.Underline = 1 'wdUnderlineSingle
            wd.selection.Find.Text = ""
            wd.selection.Find.Wrap = 1 'wdFindContinue

            wd.selection.Find.Execute
            
            If wd.selection.Find.Found Then
                strProduct = wd.selection.range
            Else
                strProduct = "NONE: " & aDoc
            End If
        
            wd.selection.Find.ClearFormatting
            wd.selection.Find.Text = "Selling to you for $"
            wd.selection.Find.Wrap = 1 'wdFindContinue
            
            wd.selection.Find.Execute

            'wdWord=2, wdExtend=1
            If wd.selection.Find.Found Then
                wd.selection.MoveRight Unit:=2, Count:=1, Extend:=1
                strPrice = Mid(wd.selection.range, InStr(wd.selection.range, "$") + 1)
                strDocName = "C:\Docs\" & strProduct & "_$" & strPrice
                strPrice = strPrice + 300
                wd.selection.range.Text = "Selling to you for $" & strPrice & ".doc"
                doc.saveas strDocName
            Else
                strPrice = "NONE: " & aDoc
            End If
        
        doc.Close
        
        Debug.Print strProduct, strPrice


        aDoc = Dir
    Loop
    
    Set doc = Nothing
    wd.Quit
    Set wd = Nothing
End Sub

 

[Remou]

Oops:

                strDocName = "C:\Docs\" & strProduct & "_$" & strPrice & ".doc"
                strPrice = strPrice + 300
                wd.selection.range.Text = "Selling to you for $" & strPrice 
                doc.saveas strDocName

 

[Remou]

Major oops:

strDocName = "C:\SomeDirectoryOtherThanTheOneYouAreUsingThisIsImportant\" & strProduct & "_$" & strPrice & ".doc"

 

[aarondewberry]

Briliant. We have got their guys.
Thanks very much.

 

[aarondewberry]

Hey guys, i have seemed to have run into a bit of a problem with the strProduct side of things.

Some of my .doc's have tables below the first 5 or 6 sentences and some more text below that. When the above code is running and there are no words that are underlined, instead of saving my doc with the..
Else
strProduct = "NONE: " & aDoc
I instead get a Runtime error '5487', word cannot save due to a file permission error.
So to check, I debug and hover over the ELSE part of the IF statement and it returns the value of "(squarebox)". Like you'd get in a line of corrupt data.

However, if I remove the table and the below text from the .doc, the IF statement works quite perfectly.

So, as a work around, as I cannot remove the table and below text. Are we able to change the code to look for the underlined text in the first 5 sentences ONLY, and ignore the rest of the doc. So the if statement would work.

Sorry to be a pain guys.