Solved: Groupwise Mail

[steve]

Hi

Does anyone know if its possible to create a macro that will open my mail message in groupwise and save it as a word doc??

Thanks
Steve

[Ken Puls]

Yes, can be done, I'm sure. What are the criteria that you want the mail message to have? ie, what folder is it in, what's the subject, etc...

[steve]

Hi Ken

Thanks for the response! Sounds promising

The folder there in is the mailbox! No Subject as they all need to be done...Our IT dept has decided to upgrade to outlook but will not install a migration tool!

Thanks again
Steve

[Ken Puls]

Hi Steve,

Will post something tonight. :)

[Ken Puls]

Hi Steve,

Okay, a bunch of code, a template, and some instructions. :)

For whatever reason, groupwise messages, despite having a SaveAs command in the User Interface, don't seem to expose the object in code. I built the template (uses word bookmarks) so that we could copy the details of each message in, save it as a word document, then start fresh.

I would save the template into your templates directory. I built the code with mine (running Win XP and Office 2003) in the following directory:
"C:\Documents and Settings\username\Application Data\Microsoft\Templates"
If the code bombs on that line, try qualifying the entire path to the template in the code (let us know if you need help doing that.) :)

I'm not sure of your level of familiarity with VBA code, so I might over simply something here for you, but if not, post back and someone can answer it if I'm not around.

Once you've saved the template in the right place, open Word and press Alt+F11 to enter the VBE. If you don't see a Windows style browser on the left, click CTRL+R to show it. Browse through the objects in the explorer window until you find Document1 (or whatever number), right click it and choose Insert|Module. In the resulting pane, paste the following code:

Option Explicit
Private ogwApp As GroupwareTypeLibrary.Application
Private ogwRootAcct As GroupwareTypeLibrary.Account

Sub Groupwise_SaveEmailToFile()
'Macro Written 10/17/2005 by Ken Puls
'Macro Purpose: Save all emails into word documents
'NOTE: Reference to Groupware Type Libary required

Dim i As Long, m As Long, _
sCommandOptions As String, _
sMailPassword As String, _
sLoginName As String, _
sSavePath As String, _
sFilename As String, _
sAttach As String, _
ogwMsg As Message, _
docTemp As Document

'Change required variables here!
sLoginName = "YourMailboxID"
sSavePath = "C:\Temp" 'do not add trailing \

'Set application object reference if needed
If ogwApp Is Nothing Then 'Need to set object reference
DoEvents
Set ogwApp = CreateObject("NovellGroupWareSession")
DoEvents
End If

'Create connection/login to email account
If ogwRootAcct Is Nothing Then 'Need to log in
'Login to root account
If Len(sMailPassword) Then 'Password was passed, so use it
sCommandOptions = "/pwd=" & sMailPassword
Else 'Password was not passed
sCommandOptions = vbNullString
End If

Set ogwRootAcct = ogwApp.Login(sLoginName, sCommandOptions, _
, egwPromptIfNeeded)
DoEvents
End If

'Turn off events and screen updates. Allows overwriting files without
'prompting and more speed
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

'Search all mail items, and save any matching attachments to the
'specified directory
For Each ogwMsg In ogwRootAcct.MailBox.Messages
With ogwMsg
'Create new document based on template
Set docTemp = Documents.Add("GWBackup.dot")

'Merge email details into document
docTemp.Bookmarks("bmrkDate").Range.Text = .CreationDate
docTemp.Bookmarks("bmrkFrom").Range.Text = .FromText
docTemp.Bookmarks("bmrkSender").Range.Text = .Sender
For i = 1 To .Recipients.Count
docTemp.Bookmarks("bmrkRecipients").Range.Text = _
.Recipients(i).EMailAddress & vbNewLine
Next i
docTemp.Bookmarks("bmrkSubject").Range.Text = .Subject
docTemp.Bookmarks("bmrkBody").Range.Text = .BodyText

'Check for attachments. If found, save them and merge details
to file
If .Attachments.Count = 0 Then
'No attachments, so do nothing
Else
'Attachments found. Save desired type to specified folder
For m = 1 To .Attachments.Count
If Not .Attachments(m).DisplayName = "Mime.822" Then
sAttach = .Attachments(m).DisplayName & vbNewLine
.Attachments(m).Save sSavePath & "\" &
.Attachments(m).FileName
End If
Next m
docTemp.Bookmarks("bmrkAttachment").Range.Text = sAttach
End If

sFilename = Format(.CreationDate, "yyyy,mm,dd hh,mm") & " " &
_
CleanFilename(GetFamiliarName(.FromText) & "-" & .Subject)
Debug.Print sFilename

'Save and close the document, then move on to next one
docTemp.SaveAs sSavePath & "\ " & sFilename & ".doc"
docTemp.Close savechanges:=False
End With
Next ogwMsg

'Release all objects before closing
Set ogwRootAcct = Nothing
Set ogwApp = Nothing
DoEvents

'Turn on events and screen updates
With Application
.ScreenUpdating = True
.DisplayAlerts = wdAlertsAll
End With

End Sub

Function CleanFilename(sName As String) As String
'Function Written 10/17/2005 by Ken Puls
'Function Purpose: To clean illegal file name characters from a String

Dim c As Long

For c = 1 To Len(sName)
Select Case Mid(sName, c, 1)
Case Is = ":", "\", "/", "?", "*", "[", "]", """"
'do nothing
Case Else
CleanFilename = CleanFilename & Mid(sName, c, 1)
End Select
Next c

End Function

Function GetFamiliarName(sAddy As String) As String
'Function Written 10/17/2005 by Ken Puls
'Function Purpose: To get the person's familiar name from an email
header

'if < is not found, use whole string
'if < is first character, use whole string
'otherwise, use up to <
Select Case InStr(1, sAddy, "<")
Case Is = 0
GetFamiliarName = sAddy
Case Is = 1
GetFamiliarName = Mid(sAddy, 2, Len(sAddy) - 2)
Case Else
GetFamiliarName = Mid(sAddy, 1, InStr(1, sAddy, "<") - 1)
End Select
End Function

Once all the code is pasted into the module (don't miss any, now ;) ) then we need to set a reference to the Groupware Type Library. In the VBE, go to Tools|References. Scroll through the huge long list until you find "Groupware Type Library", check it, and say okay.

You'll need to put your mailbox ID in there now. Find the section of the code in the first routine that looks like this:
'Change required variables here!
sLoginName = "YourMailboxID"
sSavePath = "C:\Temp" 'do not add trailing \

Put your mailbox (groupwise login in) in place of YourMailboxID (leave the quotes. Change the directory from C:\Temp to whatever you want.

Now you're ready to run the code.

Close the VBE and return to Word. Press Alt+F8, and choose the Groupwise_SaveEmailToFile routine.

Just a warning, depending on the amount of emails you have, it could take a LONG time to complete. It save the files like this:

2005,10,17 08,57 From-Subject.doc

First is date and time (sorry, can't use the : character), and then the familiar name and subject. It also saves the attachments, but will overwrite any attachment already found without prompting.

Hope this is what you need and it works well. :)

[steve]

Ken

Thanks for this its brilliant!! :)

One issue when there an embedded message the macro just doesnt like to save it. A runtime error occurs :( "This method or property is not supported.", -2147352567 (80020009). Is there a way of being able to save the message as a word document? Also is it possible to scan that message for any attachments?

Thanks again
Steve

[Ken Puls]

Hi Steve,

Sorry for the late reply here. Embedded message... do you mean something like a Forwarded message where the entire message is attached, rather than just the text being forwarded?

[steve]

Hi Ken

Yeah when you forward a message in groupwise it attaches the original message. I found a developer pdf file on the novell website which had some code in it which I have managed to incoroprate into your code which will determine whether the attachment is a message or file:

Private ogwAttachment As GroupwareTypeLibrary.Attachment

Set ogwAttachment = ogwMsg.Attachments.Item(m)
sAttach = .Attachments(m).DisplayName & vbNewLine
docTemp.Bookmarks("bmrkAttachment").Range.Text = sAttach
If Not ogwAttachment.ObjType = egwMessage Then
.Attachments(m).Save _
sSavePath & "\" & .Attachments(m).FileName
End If

The problem I have now is if theres a message thats been forwarded more then once, i need to save all messages and attachments.

Thanks
Steve

[steve]

Hi Ken

I think I may have solved this problem and I have also incorporated some additional code to create an index of the e-mails that are being saved. I will hopefully post the code etc later tonight or tomorrow morning...Still in the process of testing it.

Thanks for all your help (If I'm not speaking too soon :-) )
Steve

[Ken Puls]

Hi Steve,

Sounds great! I'm curious to see it and know if it works. I have so few forwarded messages in my inbox that it would take hours to test that part myself. (Not why I hadn't answered though... just busy ;) )

Cheers!

[steve]

Hi Ken

Sorry for the delay in posting back...been a bit tied up last few days. Anyway this is the code I have used, I also added in a Excel index of all the e-mails that were saved as word docs with hyperlinks to the doc which I have hopefully attached correctly!! :) .


Option Explicit
Private ogwApp As GroupwareTypeLibrary.Application
Private ogwRootAcct As GroupwareTypeLibrary.Account
Private ogwAttachment As GroupwareTypeLibrary.Attachment
Private ogwAttachment1 As GroupwareTypeLibrary.Attachment
Dim i As Long, m As Long, n As Long, j As Long, _
sCommandOptions As String, _
sMailPassword As String, _
sLoginName As String, _
sSavePath As String, _
sFilename As String, _
sAttach As String, _
ogwMsg As Message, _
docTemp As Document, _
docTemp1 As Document, _
ExcelApp, _
Index, _
RelatedTo As String, _
RelatedToFileName As String
Sub Groupwise_SaveEmailToFile()
'With Thanks to Ken Puls for supplying the code to extract groupwise e-mail details to
'a word document and save all attachments. Amended by Steve Cottam to check for
'embedded messages and save them as word documents also to create an Excel index of all
'e-mails saved to word document with hyperlinks from excel to each file.

sSavePath = "W:\emails" 'do not add trailing \

'Set application object reference if needed
If ogwApp Is Nothing Then 'Need to set object reference
DoEvents
Set ogwApp = CreateObject("NovellGroupWareSession")
DoEvents
End If

'Create connection/login to email account
If ogwRootAcct Is Nothing Then 'Need to log in
'Login to root account
If Len(sMailPassword) Then 'Password was passed, so use it
sCommandOptions = "/pwd=" & sMailPassword
Else 'Password was not passed
sCommandOptions = vbNullString
End If

Set ogwRootAcct = ogwApp.Login(sLoginName, sCommandOptions, _
, egwPromptIfNeeded)
DoEvents
End If

'Turn off events and screen updates. Allows overwriting files without
'prompting and more speed
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

'Creates excel application and hides this from the user as we do not want them to
'interfere with this during runtime

Set ExcelApp = CreateObject("Excel.Application")
Workbooks.Open FileName:="W:\Emails\Index of EMails.xls"
ExcelApp.Visible = False
'Check to ensure user has not already got the index file open
If ExcelApp.ActiveWorkbook.ReadOnly = True Then
MsgBox "The Index of EMails.xls file is being used by another program" & Chr(13) & "Please ensure this file is closed & Try again", _
vbCritical, "EMail Backup"
ExcelApp.ActiveWorkbook.Close Savechanges:=False
ExcelApp.Quit
End
End If
ExcelApp.DisplayAlerts = False
'For every mail item in the GroupWise Mailbox convert to a word document using template
'save any attachments and create index in Excel


For Each ogwMsg In ogwRootAcct.MailBox.Messages
With ogwMsg
'Create new document based on template
Set docTemp = Documents.Add("GWBackup.dot")

'Merge email details into document & Index
docTemp.Bookmarks("bmrkDate").Range.Text = .CreationDate
docTemp.Bookmarks("bmrkFrom").Range.Text = .FromText
docTemp.Bookmarks("bmrkSender").Range.Text = .Sender
For i = 1 To .Recipients.Count
docTemp.Bookmarks("bmrkRecipients").Range.Text = _
.Recipients(i).EmailAddress & vbNewLine
Next i
docTemp.Bookmarks("bmrkSubject").Range.Text = .Subject
docTemp.Bookmarks("bmrkBody").Range.Text = .BodyText
ExcelApp.Range("A1").Select
ExcelApp.Application.GoTo Reference:="R65536C1"
ExcelApp.Selection.End(xlUp).Offset(1, 0).Select
ExcelApp.ActiveCell = .FromText
ExcelApp.ActiveCell.Offset(0, 1) = .CreationDate
ExcelApp.ActiveCell.Offset(0, 2) = .Subject

'Check for attachments. If found, save them and merge details
'To file
If .Attachments.Count = 0 Then
'No attachments found so save file & update index
sFilename = Format(.CreationDate, "dd, mm, yyyy hh,mm") & " " & _
CleanFilename(GetFamiliarName(.FromText) & "-" & .Subject)
Debug.Print sFilename

'Save word document & update index
docTemp.SaveAs sSavePath & "\" & sFilename & ".doc"
docTemp.Close Savechanges:=False
ExcelApp.ActiveCell.Offset(0, 3) = "None"
ExcelApp.ActiveCell.Offset(0, 4) = sSavePath & "\" & sFilename & ".doc"
ExcelApp.ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 4), Address:= _
sFilename & ".doc", TextToDisplay:=sSavePath & "\" & sFilename & ".doc"
Else
'Attachments found get attachment name and merge into word doc & excel index
For m = 1 To .Attachments.Count
If Not .Attachments(m).DisplayName = "Mime.822" And Not .Attachments(m).DisplayName = "Part.001" _
And Not Right(.Attachments(m).FileName, 4) = ".vcf" Then
sAttach = .Attachments(m).DisplayName & vbNewLine
docTemp.Bookmarks("bmrkAttachment").Range.Text = sAttach
If Not ExcelApp.ActiveCell.Offset(0, 3) = "" Then
ExcelApp.ActiveCell.Offset(0, 3) = ExcelApp.ActiveCell.Offset(0, 3) & ", " & .Attachments(m).DisplayName
Else
ExcelApp.ActiveCell.Offset(0, 3) = .Attachments(m).DisplayName
End If
End If
Next m

'Save Document & update index
sFilename = Format(.CreationDate, "dd, mm, yyyy hh,mm") & " " & _
CleanFilename(GetFamiliarName(.FromText) & "-" & .Subject)
Debug.Print sFilename
docTemp.SaveAs sSavePath & "\" & sFilename & ".doc"
docTemp.Close Savechanges:=False
ExcelApp.ActiveCell.Offset(0, 4) = sSavePath & "\" & sFilename & ".doc"
ExcelApp.ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 4), Address:= _
sFilename & ".doc", TextToDisplay:=sSavePath & "\" & sFilename & ".doc"

'Save every attachment to nessacary location
For m = 1 To .Attachments.Count
If Not .Attachments(m).DisplayName = "Mime.822" And Not .Attachments(m).DisplayName = "Part.001" And Not Right(.Attachments(m).FileName, 4) = ".vcf" Then

Set ogwAttachment = ogwMsg.Attachments.Item(m)

'Check attachment type
If Not ogwAttachment.ObjType = egwMessage Then
'If attachment is not an embedded message then save attachment
.Attachments(m).Save _
sSavePath & "\" & Format(.CreationDate, "dd, mm, yyyy hh,mm") & " " & .Attachments(m).FileName

Else
'If attachment is embedded message (a message that been forward) then
'goto More_Mail Procedure
RelatedTo = .FromText & " " & .Subject & " " & .CreationDate
Call More_Mail
End If
End If
Next m
End If
End With
Next ogwMsg

ExcelApp.DisplayAlerts = True

'Close excel workbook and savechanges
ExcelApp.ActiveWorkbook.Close Savechanges:=True
'Close Excel Application
ExcelApp.Quit

'Release all objects before closing
Set ogwRootAcct = Nothing
Set ogwApp = Nothing
Set ogwAttachment = Nothing
Set ogwAttachment1 = Nothing
Set ExcelApp = Nothing
DoEvents

'Turn on events and screen updates
With Application
.ScreenUpdating = True
.DisplayAlerts = wdAlertsAll
End With

End Sub

Function CleanFilename(sName As String) As String
'Function Purpose: To clean illegal file name characters from a String

Dim c As Long

For c = 1 To Len(sName)
Select Case Mid(sName, c, 1)
Case Is = ":", "\", "/", "?", "*", "[", "]", """"
'do nothing
Case Else
CleanFilename = CleanFilename & Mid(sName, c, 1)
End Select
Next c

End Function

Function GetFamiliarName(sAddy As String) As String
'Function Purpose: To get the person's familiar name from an email
'header

'if < is not found, use whole string
'if < is first character, use whole string
'otherwise, use up to <
Select Case InStr(1, sAddy, "<")
Case Is = 0
GetFamiliarName = sAddy
Case Is = 1
GetFamiliarName = Mid(sAddy, 2, Len(sAddy) - 2)
Case Else
GetFamiliarName = Mid(sAddy, 1, InStr(1, sAddy, "<") - 1)
End Select
End Function
Private Sub More_Mail()
Start_Again:
With ogwAttachment.Message
Set docTemp1 = Documents.Add("GWBackup.dot")
docTemp1.Bookmarks("bmrkDate").Range.Text = .CreationDate
docTemp1.Bookmarks("bmrkFrom").Range.Text = .FromText
docTemp1.Bookmarks("bmrkSender").Range.Text = .Sender
For i = 1 To .Recipients.Count
docTemp1.Bookmarks("bmrkRecipients").Range.Text = _
.Recipients(i).EmailAddress & vbNewLine
Next i
docTemp1.Bookmarks("bmrkSubject").Range.Text = .Subject
docTemp1.Bookmarks("bmrkBody").Range.Text = .BodyText

'Add e-mail details to Excel index on next row
ExcelApp.Range("A1").Select
ExcelApp.Application.GoTo Reference:="R65536C1"
ExcelApp.Selection.End(xlUp).Offset(1, 0).Select
ExcelApp.ActiveCell = .FromText
ExcelApp.ActiveCell.Offset(0, 1) = .CreationDate
ExcelApp.ActiveCell.Offset(0, 2) = .Subject
'Check for attachments
If .Attachments.Count = 0 Then
'If no attachments then just save file and update excel index
sFilename = Format(.CreationDate, "dd, mm, yyyy hh,mm") & " " & _
CleanFilename(GetFamiliarName(.FromText) & "-" & .Subject)
Debug.Print sFilename

docTemp1.SaveAs sSavePath & "\" & sFilename & ".doc"
docTemp1.Close Savechanges:=False

'Update excel index
ExcelApp.ActiveCell.Offset(0, 3) = "None"
ExcelApp.ActiveCell.Offset(0, 4) = sSavePath & "\" & sFilename & ".doc"
ExcelApp.ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 4), Address:= _
sFilename & ".doc", TextToDisplay:=sSavePath & "\" & sFilename & ".doc"
ExcelApp.ActiveCell.Offset(0, 5) = RelatedTo
Else
'If attachments are found then save to desired area
For m = 1 To .Attachments.Count
If Not .Attachments(m).DisplayName = "Mime.822" And Not .Attachments(m).DisplayName = "Part.001" _
And Not Right(.Attachments(m).FileName, 4) = ".vcf" Then
Set ogwAttachment1 = ogwAttachment.Message.Attachments.Item(m)
sAttach = .Attachments(m).DisplayName & vbNewLine
docTemp1.Bookmarks("bmrkAttachment").Range.Text = sAttach
End If
Next m

sFilename = Format(.CreationDate, "dd, mm, yyyy hh,mm") & " " & _
CleanFilename(GetFamiliarName(.FromText) & "-" & .Subject)
Debug.Print sFilename


docTemp1.SaveAs sSavePath & "\ " & sFilename & ".doc"
docTemp1.Close Savechanges:=False
ExcelApp.ActiveCell.Offset(0, 5) = RelatedTo
ExcelApp.ActiveCell.Offset(0, 4) = sFilename & ".doc"
ExcelApp.ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 4), Address:= _
sFilename & ".doc", TextToDisplay:=sSavePath & "\" & sFilename & ".doc"
For m = 1 To .Attachments.Count
If Not .Attachments(m).DisplayName = "Mime.822" And Not .Attachments(m).DisplayName = "Part.001" _
And Not Right(.Attachments(m).FileName, 4) = ".vcf" And Not ogwAttachment1.ObjType = egwMessage Then
.Attachments(m).Save _
sSavePath & "\" & Format(.CreationDate, "dd, mm, yyyy hh,mm") & .Attachments(m).FileName
If Not ExcelApp.ActiveCell.Offset(0, 3) = "" Then
ExcelApp.ActiveCell.Offset(0, 3) = ExcelApp.ActiveCell.Offset(0, 3) & ", " & .Attachments(m).DisplayName
Else
ExcelApp.ActiveCell.Offset(0, 3) = .Attachments(m).DisplayName
End If
End If
If ogwAttachment1.ObjType = egwMessage Then
Set ogwAttachment = ogwAttachment1
If Not ExcelApp.ActiveCell.Offset(0, 3) = "" Then
ExcelApp.ActiveCell.Offset(0, 3) = ExcelApp.ActiveCell.Offset(0, 3) & ", " & .Attachments(m).DisplayName & " (E-MAIL ATTACHMENT)"
Else
ExcelApp.ActiveCell.Offset(0, 3) = .Attachments(m).DisplayName & " (E-MAIL ATTACHMENT)"
End If
RelatedTo = .FromText & " " & .Subject & " " & .CreationDate
GoTo Start_Again
End If

Next m
End If
End With
End Sub

Let me know what you think.

Thanks again for your help..couldnt have done it without ya!

Steve

[steve]

Sorry does anyone know how I can test the users template path and change if necessary??

[Ken Puls]

Hi Steve,

Glad you got the groupwise code working! I'd probably do things a tiny bit different in the ExcelApp sections, but only to remove the "select"ing of cells. It isn't necessary, and is a practice to be avoided if possible. Regardless, if it works, it works, and that's the main part. :)

As for the next question, do you mean just the template directories in Word? Try these:

Options.DefaultFilePath(Path:=wdPicturesPath) = "J:\"
Options.DefaultFilePath(Path:=wdDocumentsPath) = "J:\"
Options.DefaultFilePath(Path:=wdWorkgroupTemplatesPath) = "F:\templates\"
Options.DefaultFilePath(Path:=wdAutoRecoverPath) = _
"C:\Documents and Settings\username\Application Data\Microsoft\Word\"
Options.DefaultFilePath(Path:=wdToolsPath) = _
"C:\Program Files\Microsoft Office\OFFICE11\"
Options.DefaultFilePath(Path:=wdStartupPath) = _
"C:\Documents and Settings\username\Application Data\Microsoft\Word\STARTUP\"

If you want to change one, you should be able to try something like the following... (although I haven't tested it myself).

Options.DefaultFilePath(Path:=wdWorkgroupTemplatesPath) = myvariablehere

FYI, I got the code for this using the macro recorder, so you can see exactly which properties you need to change by doing that. ;)

[steve]

Thanks for your help with this Ken. Have finished it completely now. attached is the final version.


Thanks
Steve