looping problem - Xtreme Visual Basic Talk

12-08-2003, 09:08 AM

MDavid

Centurion

Join Date: Jun 2003

Posts: 138

looping problem

Hi everyone...I am having a problem with code I've put together. I'm trying to get this to loop through every Incident Report in my mail box, (which it does), copy and paste that from an Excel file into a Word doc (which it does) and save the word doc on my desktop with a different name for each Incident Report in my mail box (which it doesn't). It just opens up a new word doc for each Incident Report, it pastes the correct data into the doc, but it doesn't save the doc, it just leaves it open, and then opens a new one...etc until I have a bunch of open Word docs open.... I know I'm messing my loop up, but I've tried to move this part:

Code:

'Saves document 
        objWdDoc.SaveAs Filename:="C:\Documents and Settings\dmorri18\Desktop\IncidentReport" & myDte & ".doc"

all over in my code... and I can't seem to get it right...Can anyone out there tell me if that should go before my if...after my if...before my next...etch....

Here is my complete code:

Code:

Sub imPortInbox() 

Dim objWdApp As Word.Application 
Dim objWdDoc As Word.Document 
Dim objwdRange As Word.Range 
Dim myDte As String 
Dim OutApp As Object    'Outlook.Application 
Dim NmSpace As Object   'Outlook.NameSpace 
Dim Inbox As Object     'Outlook.MAPIFolder 
Dim MItem As Object     'Outlook.MailItem 

myDte = Range("myDte").Value 
myDte = Format(myDte, "mm-dd-yy hh:mm") 

Set olMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI") 
Set Inbox = olMAPI.GetDefaultFolder(6) 
'// In case of UNDELIVERABLES 
On Error Resume Next 
For Each MItem In Inbox.Items 
  DoEvents 
  '// Note Only looking for Incident Reports! 
  If Left(MItem.Subject, 16) = "INCIDENT REPORT:" Then 
       Sheets("Sheet1").Activate 

       Range("I3") = MItem.UserProperties("IncidentDateTime").Value 
       Range("B3") = MItem.UserProperties("IncidentDept").Value 
       Range("B5") = MItem.UserProperties("IncidentType").Value 
       Range("B7") = MItem.UserProperties("IncidentDescription").Value 
       Range("B9") = MItem.UserProperties("IncidentAffected").Value 
       Range("C11") = MItem.UserProperties("irAHT").Value 
       Range("C12") = MItem.UserProperties("irNCA").Value 
       Range("C13") = MItem.UserProperties("irOCC").Value 
       Range("C14") = MItem.UserProperties("irOCW").Value 
       Range("E11") = MItem.UserProperties("irASA").Value 
       Range("E12") = MItem.UserProperties("irNCH").Value 
       Range("E13") = MItem.UserProperties("irFD").Value 
       Range("E14") = MItem.UserProperties("irACC").Value 
       Range("G11") = MItem.UserProperties("irATA").Value 
       Range("G12") = MItem.UserProperties("irNCO").Value 
       Range("G13") = MItem.UserProperties("irQ").Value 
       Range("G14") = MItem.UserProperties("irSL").Value 
       Range("C17") = MItem.SenderName 
        
        Module2.clnData 
        Module2.getTime 
        Range("A3:J17").Copy 
        'Create instance of Word Application 
        Set objWdApp = New Word.Application 
        Set objWdDoc = objWdApp.Documents.Open(Filename:="C:\Documents and Settings\dmorri18\Desktop\CreateLetter\IncidentReport.dot") 
        'Set the range equal to the entire word doc 
        Set objwdRange = objWdDoc.Range 
        'pastes data 
        objwdRange.Paste 
        'Make word visible 
        objWdApp.Visible = True 
        'Saves document 
        objWdDoc.SaveAs Filename:="C:\Documents and Settings\dmorri18\Desktop\IncidentReport" & myDte & ".doc" 
        
    End If 
              
N:  Next MItem 

Set MItem = Nothing 
Set Inbox = Nothing 
Set NmSpace = Nothing 
Set OutApp = Nothing 
Set Attach = Nothing 

objWdApp.Quit 

Set objwdRange = Nothing 
Set objWdDoc = Nothing 
Set objWdApp = Nothing 

End Sub

Thanks,

Dave M...

P.S. Feel free to clean it up...you wont hurt my feelings....

12-08-2003, 10:09 AM

tinyjack

Captain TJ

Forum Leader
* Expert *

Join Date: Jun 2003

Location: England

Posts: 1,664

Couple of quick points:

You are creating a new instance of word every time you want to create a new document, but you only have one .Quit. Why not take the creation outside of your loop?

On the assumption that the creating of the Word instance is now outside of your loop, I would add a .Close line after your .SaveAs line.

I am quite busy a the minute, so have not been able to have a better look, but the above might give you a nudge.

TJ

__________________
Oh dear, I need a beer.
Online Motorsport Game

12-08-2003, 10:41 AM

MDavid

Centurion

Join Date: Jun 2003

Posts: 138

Thanks for the reply...I've altered the code as you've suggested...(I think). Now it does open only 1 instance of the Word.App. and does all the code except the save part...For some reason it wont save the document. There is data in the Word doc, I've stopped the code before it could close it, but it still doesn't want to save....:-(

Thanks for your help, and below is my altered code:

Code:

Sub imPortInbox()

Dim objWdApp As Word.Application
Dim objWdDoc As Word.Document
Dim objwdRange As Word.Range
Dim myDte As String
Dim OutApp As Object    'Outlook.Application
Dim NmSpace As Object   'Outlook.NameSpace
Dim Inbox As Object     'Outlook.MAPIFolder
Dim MItem As Object     'Outlook.MailItem

myDte = Range("myDte").Value
myDte = Format(myDte, "mm-dd-yy hh:mm")

Set olMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set Inbox = olMAPI.GetDefaultFolder(6)
'Create instance of Word Application
Set objWdApp = New Word.Application
'// In case of UNDELIVERABLES
On Error Resume Next
For Each MItem In Inbox.Items
  DoEvents
  '// Note Only looking for Incident Reports!
  If Left(MItem.Subject, 16) = "INCIDENT REPORT:" Then
       Sheets("Sheet1").Activate

       Range("I3") = MItem.UserProperties("IncidentDateTime").Value
       Range("B3") = MItem.UserProperties("IncidentDept").Value
       
        Module2.clnData
        Module2.getTime
        Range("A3:J17").Copy
        
        Set objWdDoc = objWdApp.Documents.Open(Filename:="C:\Documents and Settings\dmorri18\Desktop\CreateLetter\IncidentReport.dot")
        'Set the range equal to the entire word doc
        Set objwdRange = objWdDoc.Range
        'pastes data
        objwdRange.Paste
        'Make word visible
        objWdApp.Visible = True
        'Saves document
        objWdDoc.SaveAs Filename:="C:\Documents and Settings\dmorri18\Desktop\IncidentReport" & myDte & ".doc"
        objWdDoc.Close
        
    End If
              
N:  Next MItem

Set MItem = Nothing
Set Inbox = Nothing
Set NmSpace = Nothing
Set OutApp = Nothing
Set Attach = Nothing

objWdApp.Quit

Set objwdRange = Nothing
Set objWdDoc = Nothing
Set objWdApp = Nothing

End Sub

I've omitted unecessary parts to try and keep it brief...

Thanks again,

Dave M.

12-08-2003, 11:25 AM

herilane

Unashamed geek

Retired Moderator
* Expert *

Join Date: Jul 2003

Location: London, England

Posts: 8,988

Could be something as simple as a problem with the file name... set the path through a string, and make sure it looks ok.

Code:

Dim filepath As String
filepath = "C:\Documents and Settings\dmorri18\Desktop\IncidentReport" & myDte & ".doc"
'stop code here and check value of filepath
objWdDoc.SaveAs Filename:=filepath

12-08-2003, 12:38 PM

MDavid

Centurion

Join Date: Jun 2003

Posts: 138

Heh...umm....doh! Sorry but it was actually this line:

Code:

myDte = Format(myDte, "mm-dd-yy hh:mm")

that was causing the problems.... this little bugger ":" was the culprit! Of course if you use a : in a filename, it makes the file name invalid!!!

I just switched the line to:

Code:

myDte = Format(myDte, "mm-dd-yy HHmm")

and that solved my problems...except for the suggestions that were made above...so my working code is as follows:

Code:

Sub imPortInbox()

Dim objWdApp As Word.Application
Dim objWdDoc As Word.Document
Dim objwdRange As Word.Range
Dim myDte As String

Dim OutApp As Object    'Outlook.Application
Dim NmSpace As Object   'Outlook.NameSpace
Dim Inbox As Object     'Outlook.MAPIFolder
Dim MItem As Object     'Outlook.MailItem

myDte = Range("myDte").Value
myDte = Format(myDte, "mm-dd-yy HHmm")

'Create instance of Word Application
Set objWdApp = New Word.Application
Set olMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")
objWdApp.Visible = True
Set Inbox = olMAPI.GetDefaultFolder(6)
'// In case of UNDELIVERABLES
On Error Resume Next
For Each MItem In Inbox.Items
  DoEvents
  '// Note Only looking for Incident Reports!
  If Left(MItem.Subject, 16) = "INCIDENT REPORT:" Then
       Sheets("Sheet1").Activate
       
       Range("I3") = MItem.UserProperties("IncidentDateTime").Value
       Range("B3") = MItem.UserProperties("IncidentDept").Value
       Range("B5") = MItem.UserProperties("IncidentType").Value
       Range("B7") = MItem.UserProperties("IncidentDescription").Value
       Range("B9") = MItem.UserProperties("IncidentAffected").Value
       Range("C11") = MItem.UserProperties("irAHT").Value
       Range("C12") = MItem.UserProperties("irNCA").Value
       Range("C13") = MItem.UserProperties("irOCC").Value
       Range("C14") = MItem.UserProperties("irOCW").Value
       Range("E11") = MItem.UserProperties("irASA").Value
       Range("E12") = MItem.UserProperties("irNCH").Value
       Range("E13") = MItem.UserProperties("irFD").Value
       Range("E14") = MItem.UserProperties("irACC").Value
       Range("G11") = MItem.UserProperties("irATA").Value
       Range("G12") = MItem.UserProperties("irNCO").Value
       Range("G13") = MItem.UserProperties("irQ").Value
       Range("G14") = MItem.UserProperties("irSL").Value
       Range("C17") = MItem.SenderName
       
       myDte = Range("myDte").Value
       myDte = Format(myDte, "mm-dd-yy HHmm")
       
       Set objWdDoc = objWdApp.Documents.Open(Filename:="C:\Documents and Settings\dmorri18\Desktop\CreateLetter\IncidentReport.dot")
       Set objwdRange = objWdDoc.Range
       
       Module2.clnData
       Module2.getTime
       Range("A3:J17").Copy
       
       objwdRange.Paste
       
        objWdDoc.SaveAs Filename:="C:\Documents and Settings\dmorri18\Desktop\IncidentReport" & myDte & ".doc"
        objWdDoc.Close
    End If
          
N:  Next MItem

objWdApp.Quit
    
Set MItem = Nothing
Set Inbox = Nothing
Set NmSpace = Nothing
Set OutApp = Nothing
Set Attach = Nothing

Set objwdRange = Nothing
Set objWdDoc = Nothing
Set objWdApp = Nothing

End Sub

Thanks for all the help!!!

Dave M