PDA

View Full Version : [SOLVED] Import from Outlook to Excel



mvidas
10-13-2004, 06:14 AM
Hi Everyone,

I made a routine to import selected messages from outlook into excel, and I'm looking for any help possible with this. It currently works perfectly for me, but being that I'm relatively new to the integration between the two programs I'm sure there are more efficient ways to do some of the things I'm doing.

I'm open to any suggestions about this, so please feel free to share!

I have a couple more things I am planning to do before it's complete, such as adding a prompt for moving the selected messages to Deleted Items, and a prompt for saving the new worksheet, among a couple others. Theres no reason I haven't added them yet, I'm just anxious to see what can be done so far before I add more.

Thanks!!
Matt


Sub ImportFromOutlook()
'Will import all selected messages in current outlook window and import into new excel
' spreadsheet, and will embed any/all attachments
'Sender Email routine modified from http://www.outlookcode.com/d/code/getsenderaddy.htm
'Basic outlook use taken from Will_Scarlet7 http://www.experts-exchange.com/Q_21165137.html
Dim oOutlook As New Outlook.Application, oSelection As Outlook.Selection
Dim oMessage As Outlook.MailItem, objSession, objCDOMsg, strEntryID, strStoreID
Dim SndName As String, SndAddr As String, ToName As String, CCName As String
Dim Subj As String, Rcvd As String, MsgBody As String, AtchName As String
Dim Atch As Outlook.Attachment, AtchCell As Range
Application.ScreenUpdating = False
Set oSelection = oOutlook.ActiveExplorer.Selection
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "", "", False, False
Workbooks.add
Application.DisplayAlerts = False
Sheets(2).Delete
Sheets(2).Delete
Application.DisplayAlerts = True
For Each oMessage In oSelection
Sheets.add after:=Sheets(Sheets.Count)
If oMessage.Class = olMail Then
Subj = oMessage.Subject
SndName = oMessage.SenderName
ToName = oMessage.To
CCName = oMessage.cc
MsgBody = oMessage.Body
Rcvd = oMessage.ReceivedTime
strEntryID = oMessage.EntryID
strStoreID = oMessage.Parent.StoreID
Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)
On Error Resume Next
SndAddr = objCDOMsg.Sender.Address
If Err = &H80070005 Then
Msgbox "The Outlook E-mail and CDO Security Patches are " & _
"apparently installed on this machine. " & _
"You must response Yes to the prompt about " & _
"accessing e-mail addresses if you want to " & _
"get the From address.", vbExclamation, _
"GetFromAddress"
End If
On Error GoTo 0
Range("A1") = "From"
If SndAddr Like "*@*" Then
Range("B1") = SndName & " (" & SndAddr & ")"
Else
Range("B1") = SndName
End If
Range("A2") = "To"
Range("B2") = ToName
Range("A3") = "CC"
Range("B3") = CCName
Range("A4") = "Subject"
If Subj = "" Then Subj = " "
Range("B4") = Subj
Range("A5") = "Received"
Range("B5") = Rcvd
Range("B5").HorizontalAlignment = xlLeft
Range("A6") = "Attachments"
Rows(6).RowHeight = 47.25
Range("A7") = "Body"
Range("B1:K1,B2:K2,B3:K3,B4:K4,B5:K5").MergeCells = True
ProcessBody Range("B7"), MsgBody
Set AtchCell = Range("C6")
For Each Atch In oMessage.Attachments
If Atch.Type = 1 Then
AtchName = Atch.FileName
Atch.SaveAsFile "C:\DEL-ME-" & Atch.FileName
With ActiveSheet.OLEObjects.add(FileName:="C:\DEL-ME-" & Atch.FileName, displayasicon:=True, _
Link:=False, Left:=AtchCell.Left, Top:=AtchCell.Top, Width:=AtchCell.Width, Height:=AtchCell.Height)
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = AtchCell.Height
.ShapeRange.Width = AtchCell.Width
End With
AtchCell.Offset(0, -1) = AtchName & ":"
AtchCell.Offset(0, -1).HorizontalAlignment = xlRight
AtchCell.Offset(0, -1).WrapText = True
Set AtchCell = AtchCell.Offset(0, 2)
On Error Resume Next
Workbooks("DEL-ME-" & Atch.FileName).Close False
Kill "C:\DEL-ME-" & Atch.FileName
On Error GoTo 0
End If
Next
End If
Rcvd = Format([B5], "YYYYMMDD") & "-" & Format([B5], "hhmmss") & "-" & Left(Subj, 15)
Rcvd = Replace(Rcvd, Chr(58), "")
Rcvd = Replace(Rcvd, Chr(92), "")
Rcvd = Replace(Rcvd, Chr(47), "")
Rcvd = Replace(Rcvd, Chr(63), "")
Rcvd = Replace(Rcvd, Chr(42), "")
Rcvd = Replace(Rcvd, Chr(91), "")
Rcvd = Replace(Rcvd, Chr(93), "")
ActiveSheet.Name = Rcvd
Range("A1").Select
Range("A6").Columns.AutoFit
ActiveSheet.PageSetup.CenterHeader = Subj
ActiveSheet.PageSetup.LeftMargin = Application.InchesToPoints(0.25)
ActiveSheet.PageSetup.RightMargin = Application.InchesToPoints(0.25)
ActiveSheet.PageSetup.TopMargin = Application.InchesToPoints(0.5)
ActiveSheet.PageSetup.BottomMargin = Application.InchesToPoints(0.25)
ActiveSheet.PageSetup.HeaderMargin = Application.InchesToPoints(0.25)
Next oMessage
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Sheets(1).Select
ExitImportFromOutlook:
Set oOutlook = Nothing
Set oMessage = Nothing
Set oSelection = Nothing
Set objCDOMsg = Nothing
objSession.Logoff
Set objSession = Nothing
Application.ScreenUpdating = True
End Sub

Function ProcessBody(startRg As Range, mBody As String)
Dim WhereAt As Long, delim As String
delim = vbCrLf
mBody = Replace(mBody, Chr(9), "")
Do While mBody Like "*" & delim & "*"
WhereAt = InStr(1, mBody, delim)
Range(startRg, startRg.Offset(0, 9)).Merge
Range(startRg, startRg.Offset(0, 9)).WrapText = True
If WhereAt > 1 Then
startRg = Left(mBody, WhereAt - 1)
AutoFitMC startRg
End If
mBody = Mid(mBody, WhereAt + Len(delim))
Set startRg = startRg.Offset(1, 0)
Loop
startRg = mBody
Range(startRg, startRg.Offset(0, 9)).Merge
AutoFitMC startRg
End Function

Sub AutoFitMC(rgg As Range)
'Created by Brad Yundt, taken from http://www.experts-exchange.com/Q_21101227.html
Dim MergedWidth As Double, MergedChars As Double, ReqdHeight As Double, colWidth As Double
Dim cel As Range, celTemp As Range, col As Range, rg As Range, rw As Range
Set rg = rgg.Cells(1, 1)
If rg.MergeCells Then
With rg.MergeArea
If .WrapText = True Then
ActiveSheet.Columns(1).Insert
Set cel = .Cells(1, 1)
colWidth = cel.EntireColumn.Width
For Each col In .Columns
MergedWidth = col.Width + MergedWidth
MergedChars = col.ColumnWidth + MergedChars
Next col
.MergeCells = False
With ActiveSheet.Columns(1)
.ColumnWidth = MergedChars
.ColumnWidth = MergedChars * MergedWidth / .Width + 0.05
End With
Set celTemp = Cells(cel.Row, 1)
cel.Copy
celTemp.PasteSpecial xlPasteValues
celTemp.PasteSpecial xlPasteFormats
celTemp.EntireRow.AutoFit
.MergeCells = True
ReqdHeight = celTemp.EntireRow.Height
.RowHeight = Application.Max(ReqdHeight / .Rows.Count + 0.49, 12.75)
Columns(1).Delete
rg.Select
If ReqdHeight >= 409.5 Then Msgbox "Warning! Text is truncated because maximum merged cell height is 409.5 points"
End If
End With
End If
End Sub

mvidas
10-13-2004, 06:50 AM
Hi, a couple quick followups :)

I just tested this on a selection of 145 messages, took about 3 minutes (long, but somewhat understandable considering what it's doing). I'm gonna add a progress bar once i end up making this into an add-in. I'm also going to displayalerts=false for the attachment section as when it adds .xls attachments it opens them, and a couple of the ones i just tested had external links and had the prompt on opening.

I also tested changing the selection in outlook while it's running, doesn't seem to be an issue (as the messages are contained in oSelection). That's good, i was a little worried about that.

mvidas
10-13-2004, 07:51 AM
I still can't get past the popup for external links!
Even when adding

Application.DisplayAlerts = False
ActiveWorkbook.UpdateRemoteReferences = False
to the code before the oleobjects.add line but still no luck

Does anyone have any ideas? I'm gonna ask a question on EE about this as well, to try and get some more ideas

mvidas
10-13-2004, 08:32 AM
seems like this is becoming somewhat of a personal progress log..
thanks to Geoff's suggestion on EE (which pretty much did the same thing as the macro recorder said)

I manually opened the file beforehand


If right(AtchName, 3) = "xls" Then
Workbooks.Open "C:\DEL-ME-" & AtchName, False
ActiveWindow.Visible = False
End If
With ActiveSheet.OLEObjects.add(FileName:="C:\DEL-ME-" & AtchName, DisplayAsIcon:=True, _
Link:=False, Left:=AtchCell.Left, Top:=AtchCell.Top, Width:=AtchCell.Width, Height:=AtchCell.Height)
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = AtchCell.Height
.ShapeRange.Width = AtchCell.Width
End With

testing help/suggestions still wanted!
Thanks
Matt

Zack Barresse
10-13-2004, 01:54 PM
Wow! You should make that a KB entry Matt! :yes

mvidas
10-13-2004, 02:32 PM
I plan on it, once I get it fine tuned. i added a few more error checks in there, switched it up a bit. i still can't get it faster than an average of about 25 messages/minute though

right now im having a hard time getting MD's FindWord kb entry to work with it, its not being cooperative!

did the above work for you? if so, what version did you test it on?

mdmackillop
10-13-2004, 02:43 PM
Hi Matt,
Working with Office 2000

Programme is falling over at the ante-penultimate line

Set objSession = Nothing

Rcvd is being left with an illegal character; apostophe

A line here could be trimmed

Range("A1").Select
Range("A6").Columns.AutoFit

MD

mvidas
10-13-2004, 07:10 PM
Hey MD, I never got the email notification about this message, just came back on vbax and saw this

I looked on my code and its the 4th last line, but then I realized it was 2nd last in the above :) Not sure why its not working for you, you could easily just comment that out.

I'm allowed to use apostrophes in sheetnames, are you? i'll put a checker in there if my version isn't the standard for it.

I have the A1 being selected because Brad's subroutine leaves the active cell on the last auto-fitted row, and depending on the cell, it made my formula bar cover the column headings for the long cells. A1 was only From so it would always be fine, size-wise. I had columns(6).autofit at first, but then realized A6 was always the longest with Attachments.

I have a question about this on ee as well, dealing with the mapi call, as my computer at home doesn't have cdo.dll and it wont work. my newest version of the code is posted there, little bit quicker runtime wise.

Maybe you can help me with the FindText. It works great for all spreadsheets, except on ones created by the above macro! Can you try that and see if it works for you? On the line


Set Cell = .Find( ...

(line 58 in the one from the kb i think) it's not finding Search, even though when I do control-f it finds it easily. i thought it might have been because i was looking for text in a merged cell, but that worked fine in other merged cells.

by the way, i also added an apostrophe before and after Findsheet(counter) in


ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
Address:="", SubAddress:="'" & FindSheet(Counter) & "'!" & FindCell(Counter), _
TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)

also, in the AddSheetCode sub I added apostrophes and thisworkbook.name instead of just PERSONAL.XLS. I can't think of a way to return something like ThisModule.Name so i just have it named as in my file

& "Application.Run (" & Chr(34) & "'" & ThisWorkbook.Name & "'!MDFindText.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
It is a bit long, but I dont really care.

Thanks for testing by the way! I think im going to add a userform for selecting messages, to make the view similar to how it is in outlook, but only with From, Subject, and Received. Once there are 100+ messages in a workbook it does get a bit annoying trying to find a specific one using only 15 characters of a subject :)
Matt

mvidas
10-13-2004, 08:59 PM
I got my CDO thing working now, and now I've got the same problem (excel crashing on the set objsession=nothing line also)
I think I'm done for the day for troubleshooting, I'll try and take a better look tomorrow
Thanks again
Matt

brettdj
10-14-2004, 12:04 AM
Matt,

You have two

Sheets(2).Delete
lines

which presumes that a new workbook has 3 sheets as a default. Mine don't :)

I will keep on testing the Outlook interface tonight. If the CDO reference causes grief then maybe you could use the Outlook Object rather than CDO object.

Cheers

Dave

mdmackillop
10-14-2004, 12:59 AM
Matt,
Excel is crashing wherever I try to get it to stop. eg asking it to show a userform as follows,

Next oMessage
UserForm1.Show False
I've managed to get the "data" out by inserting a SaveCopyAs line before things crash, and I have the same problem with Find Text. I'll have a look at that this evening.
MD

brettdj
10-14-2004, 02:56 AM
Hi Matt,

First of all, good job :)

Another approach for the same outcome would be to use the Outlook and Redemption objects http://www.dimastr.com/redemption/download.htm.

Using Redemption eliminates the security message when the senders details are accessed gathered.

Cheers

Dave



Sub RedemptionMail()
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objSafeMail As Redemption.SafeMailItem
Dim objMsg As Outlook.MailItem
Dim SndName As String, SndAddr As String, ToName As String, CCName As String
Dim Subj As String, Rcvd As String, MsgBody As String, AtchName As String
Set objApp = New Outlook.Application
For Each objItem In objApp.ActiveExplorer.Selection
Set objSafeMail = New Redemption.SafeMailItem
objSafeMail.Item = objItem
With objSafeMail
SndName = .SenderName
SndAddr = .SenderEmailAddress
ToName = .To
CCName = .CC
Subj = .Subject
MsgBody = .Body
Rcvd = .ReceivedTime
End With
Next
Set objMsg = Nothing
Set objItem = Nothing
Set objSafeMail = Nothing
Set objApp = Nothing
End Sub

mvidas
10-14-2004, 05:39 AM
I'm still not getting email notifications for this, I'll have to post in that forum for that issue (it does have Instant email notification for my setting)

Dave- Good point about the number of sheets on a new workbook, I'll change the code to factor that in.
Would I be able to retrieve the sender email with the outlook object instead of the CDO object? I'll be the first to admit I just pieced together a few methods to get this working, I'm sure there are shortcuts to doing what I'm doing.
I saw the thing about redemption when I was trying to figure out how to get the sender address. I didn't want to have to download that and distribute with my add-in; I'd rather it just be standalone, more or less. Was I wrong in thinking I'd have to distribute it to other end-users?

MD- It is an odd issue, that's for sure. Hopefully one that can be resolved!
As far as the FindWord goes, it's not finding anything if I run it from the VBE, but if I run it from excel from the macros window, it works fine! I'm going to see if it works from the toolbar, and if it does I'm just going to hope it works for others as well :)

brettdj
10-14-2004, 06:00 AM
Hi Matt,

The users would need a copy of redemption, maybe you could test for it and run the code that way if the reference was available?

Yes, you could try the Outlook Object



Sub olCode()
Dim objApp As Outlook.Application
Dim objItem As Outlook.MailItem
Dim SndName As String, SndAddr As String, ToName As String, CCName As String
Dim Subj As String, Rcvd As String, MsgBody As String, AtchName As String
Set objApp = New Outlook.Application
For Each objItem In objApp.ActiveExplorer.Selection
If objItem.Class = olMail Then
With objItem
SndName = .SenderName
SndAddr = .SenderEmailAddress
ToName = .To
CCName = .CC
Subj = .Subject
MsgBody = .Body
Rcvd = .ReceivedTime
End With
End If
Next
Set objItem = Nothing
Set objApp = Nothing
End Sub


Cheers

Dave

mvidas
10-14-2004, 08:29 AM
It's possible that perhaps my version of office/outlook doesn't support SenderEmailAddress, I got a runtime error 438 "Object doesn't support this property or method"

I'm also guessing that most of the people within my company that will be using this will have their computer setup the same as mine, without redemption on it.

On an off note, the FindWord macro seems to be working fine right now for me!!

I really appreciate all the help you've been for this, it's been great.
Could I ask you one more favor? Would you mind testing the attached add-in when you get a chance? I've made quite a few enhancements/changes today, and while its working for me I'd just like some confirmation that it would work for you as well.

Thanks
Matt

mdmackillop
10-14-2004, 09:07 AM
Hi Matt,

Another little bug. I have an email where a line of ============ has been used as a punctuation. This is causing a problem on this line "startRg = Left(mBody, WhereAt - 1)" , so that startRg is being set as "="

I've just downloaded your add-in here at work and everything runs! (if I avoid problem emails:mad: )

Two suggestions:
1. the Table of Contents should be "ignored" by the FindWord routine.
2. the dialog default button to delete imported emails should be set to No

On the whole, an impressive piece of work!:)

MD

mvidas
10-14-2004, 09:27 AM
That's odd, I had that problem yesterday and thought I coded a fix!

I just added the line
I
f Left(mBody, 1) = "=" Then mBody = "'" & mBody
before the third last line in the function:

startRg = mBody
and also before

WhereAt = InStr(1, mBody, delim)

I'm going to attach a fixed addin, but figured I'd explain the difference so you don't have to redownload it

Thanks!!

mvidas
10-14-2004, 09:53 AM
I just thought of another enhancement, sorting the table of contents page based on the cell they click
should be pretty easy

mdmackillop
10-14-2004, 10:13 AM
Hi Matt,
I'm getting an error on this line.


Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)

Something to do with the Exchange Server Store. I've added "On error resume next" and the message is still being imported. Funnily enough, if I select that one message only, it comes in without any error. :confused:

I added a couple of suggestions to an earlier message. You may have missed them during the Edit process.
MD

mvidas
10-14-2004, 10:59 AM
I think I did miss those suggestions, I'll add those right away. didnt even think about ignoring the TOC, smart idea!
I never knew how to change the default of the buttons on a msgbox, must have missed that section of the help! Thanks for showing me i could do that!!

As far as the Set objCDOMsg line, I don't know what the issue could be.. all that's used for is to get the sender email address. I moved the on error resume next up one line, so in those cases where its a problem, it just wont put the address in there (chances are extremely unlikely that the end user will NEED the email address for this one, if they truly needed the address hopefully they'll have it in their contacts)

I am having a new issue, it will sound extremely similar to one of your old ones.
I'm trying to add sort event code to a worksheet. Here's the sub I'm using to try it:


Sub AddSortCode()
Dim TOC As String, WB As Workbook, I As Integer, PART1 As String, PART2 As String
Set WB = ActiveWorkbook
PART1 = "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & vbCr & _
" Dim CLL As Range" & vbCr & _
" Set CLL = Cells(Target.Row, Target.Column)" & vbCr & _
" If CLL.Row = 3 And CLL.Column < 5 Then" & vbCr & _
" Application.EnableEvents = False" & vbCr & _
" Application.ScreenUpdating = False" & vbCr & _
" If CLL.Font.Bold = False Then" & vbCr & _
" Range(""A3:D3"").Font.Bold = False" & vbCr & _
" Range(""A3:D3"").Font.Italic = False" & vbCr & _
" Intersect(Rows(""4:65536""), ActiveSheet.UsedRange).Sort key1:=CLL.Offset(1, 0), _" & vbCr & _
" order1:=xlAscending, header:=xlNo, Orientation:=xlTopToBottom" & vbCr & _
" CLL.Font.Bold = True" & vbCr & _
" ElseIf CLL.Font.Italic = False Then" & vbCr
PART2 = " Intersect(Rows(""4:65536""), ActiveSheet.UsedRange).Sort key1:=CLL.Offset(1, 0), _" & vbCr & _
" order1:=xlDescending, header:=xlNo, Orientation:=xlTopToBottom" & vbCr & _
" CLL.Font.Italic = True" & vbCr & _
" Else" & vbCr & _
" Intersect(Rows(""4:65536""), ActiveSheet.UsedRange).Sort key1:=CLL.Offset(1, 0), _" & vbCr & _
" order1:=xlAscending, header:=xlNo, Orientation:=xlTopToBottom" & vbCr & _
" CLL.Font.Italic = False" & vbCr & _
" End If" & vbCr & _
" Range(""A1"").Select" & vbCr & _
" Application.ScreenUpdating = True" & vbCr & _
" Application.EnableEvents = True" & vbCr & _
" End If" & vbCr & _
"End Sub"
For I = 1 To WB.VBProject.VBComponents.Count
If WB.VBProject.VBComponents.Item(I).Name = Sheets("Table of Contents").CodeName Then
WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (PART1 & PART2)
End If
Next
Set WB = Nothing
End Sub

When I step through it, the .AddFromString works, and it does add the code to the worksheet! however, as soon as i press F8 to go past the End If line immediately following it, excel crashes.
Any suggestions? After the troubleshooting you went through originally, I'd think you're an expert now
MV

mvidas
10-14-2004, 11:16 AM
I added an Exit For after it, and it does the same thing. It seems to crash after processing another line of code after the .AddFromString. If I just manually stop the macro after it's been added, its fine
Do you think this warrants a new question?

mvidas
10-14-2004, 11:39 AM
OK, nevermind, I realized if I put "Exit sub" after the .AddFromString then it seems to work without crashing! skips the Set WB=Nothing line, but that's not a huge deal.

I'm attaching the newest, hopefully nearly error-free (aside from the CDO thing I'm having at home, I'll have to try this later when I get back, but it works for what I need now at work)

I'm excited now that I feel that I'm so close

mdmackillop
10-14-2004, 12:28 PM
Well done Matt,
I wan't making any progress with addfromstring. As soon as I F8 on that line, it was falling over, and I was trying every permutation I could think of. I don't see what difference the Exit line makes at that point, but as long as it works ....
MD

mvidas
10-14-2004, 12:52 PM
Does the new one work for you? Maybe it's just my computer that its allowing it.
It isn't done the same way as yours, as I don't need to check for duplicate event codes in that sheet (since the workbook is being created in the macro)

Would you mind just testing it one more time, and seeing if the whole sort thing works? I don't have any verbage on the sheet explaining about the sort, but you just have to click "From", "Received" or "Subject" to sort it. click it a second time to reverse the sort (the heading goes bold if sorted, and bold/italics if sorted in reverse

Once I hear the (hopefully) good word that it works for you (or anyone), im gonna send it around here!

Once again, I really want to thank you and Dave. You two have been a HUGE help!!!

mvidas
10-14-2004, 12:58 PM
oh yeah, one thing i discovered today

Alt-<leftarrow> and alt-<rightarrow> work the same in excel as they do in internet explorer! left arrow goes back to the last page you were on, and right arrow goes forward one (if you've already gone back)

its my second favorite keyboard shortcut ive discovered recently, first being that if you select multiple lines in the vba, then tab and shift-tab will increase/decrease the indent for each selected line

mvidas
10-14-2004, 01:33 PM
Alright im home now and i just tried it and its still bombing out on the "Set oSession=nothing" line.. and when i commented that out it bombed out at the .addfromstring line..
i suppose i could just get rid of the sort portion of it, but i do like that

i'll have to try this on more computers at work tomorrow, see what happens there. i think ive had enough of all this for one day anyways

mdmackillop
10-14-2004, 02:22 PM
Hi Matt,
It works for me.
If it's not too much trouble, how about freezing row 1 on each sheet so that when using FindWord or simply scrolling, the return to contents page is always visible.
Here's a little tweak on the Sort function, it put in an up or down arrow next the text in the "active" column, depending on the sort.
MD


Sub AddSortCode()
Dim WB As Workbook, I As Integer, PART1 As String, PART2 As String, PART3 As String
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3
On Error GoTo 0
Set WB = ActiveWorkbook
PART1

= "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & vbCr & _
" Dim CLL As Range" & vbCr & _
" Set CLL = Cells(Target.Row, Target.Column)" & vbCr & _
" If CLL.Row = 3 And CLL.Column < 5 Then" & vbCr & _
" Application.EnableEvents = False" & vbCr & _
" Application.ScreenUpdating = False" & vbCr & _
" If CLL.Font.Bold = False Then" & vbCr & _
" Range(""A3:D3"").Font.Bold = False" & vbCr & _
" Range(""A3:D3"").Font.Italic = False" & vbCr & _
" Intersect(Rows(""4:65536""), ActiveSheet.UsedRange).Sort key1:=CLL.Offset(1, 0), _" & vbCr & _
" order1:=xlAscending, header:=xlNo, Orientation:=xlTopToBottom" & vbCr & _
" CLL.Font.Bold = True" & vbCr & _
" Arrow CLL.Column()," & """Up""" & vbCr & _
" ElseIf CLL.Font.Italic = False Then" & vbCr
PART2

= " Intersect(Rows(""4:65536""), ActiveSheet.UsedRange).Sort key1:=CLL.Offset(1, 0), _" & vbCr & _
" order1:=xlDescending, header:=xlNo, Orientation:=xlTopToBottom" & vbCr & _
" CLL.Font.Bold = True" & vbCr & _
" Arrow CLL.Column()," & """Dn""" & vbCr & _
" Else" & vbCr & _
" Intersect(Rows(""4:65536""), ActiveSheet.UsedRange).Sort key1:=CLL.Offset(1, 0), _" & vbCr & _
" order1:=xlAscending, header:=xlNo, Orientation:=xlTopToBottom" & vbCr & _
" CLL.Font.Italic = False" & vbCr & _
" End If" & vbCr & _
" Range(""A1"").Select" & vbCr & _
" Application.ScreenUpdating = True" & vbCr & _
" Application.EnableEvents = True" & vbCr & _
" End If" & vbCr & _
"End Sub" & vbCr & vbCr

PART3

= "Sub Arrow(Col, Point)" & vbCr & _
"Dim Cnt$, Arr$" & vbCr & _
"Cells(3, 1).Formula = Left(Cells(3, 1), 4)" & vbCr & _
"Cells(3, 2).Formula = Left(Cells(3, 2), 8)" & vbCr & _
"Cells(3, 3).Formula = Left(Cells(3, 3), 7)" & vbCr & _
"Cells(3, 4).Formula = Left(Cells(3, 4), 10)" & vbCr & vbCr & _
"If Point = ""Up"" Then Arr = Chr(217): Else Arr = Chr(218)" & vbCr & _
"Txt = Cells(3, col).Text" & vbCr & _
"Cnt = Len(Txt)" & vbCr & _
"With ActiveCell" & vbCr & _
" .Formula = Txt & "" "" & Arr" & vbCr & _
" .Characters(Start:=Cnt + 2, Length:=1).Font.Name = ""Wingdings""" & vbCr & _
"End With " & vbCr & _
"End Sub"
For I = 1 To WB.VBProject.VBComponents.Count
If WB.VBProject.VBComponents.Item(I).Name = Sheets("Table of Contents").CodeName Then
WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (PART1 & PART2 & PART3)
Exit For
End If
Next
Set WB = Nothing
End Sub

mdmackillop
10-14-2004, 02:23 PM
Don't ask me where the smilies came from!!!!

Zack Barresse
10-14-2004, 02:24 PM
I won't ask about the smiley's (I inserted the VBA tags), but what about the quotes?

mdmackillop
10-14-2004, 02:27 PM
Quotes are OK, it's a code string for exporting to another module.
Thanks Zack

Zack Barresse
10-14-2004, 02:42 PM
Np. (Where's my frontal pic!!?!! ;) )

mdmackillop
10-14-2004, 02:49 PM
BTW Matt, I get 2 security checks when I start the code.

mvidas
10-14-2004, 03:05 PM
I missed the smilies, so i wont ask.
so whats the deal with your smilies?????
i'll be glad to put that arrow part in the code, its a good idea. i didnt feel like thinking about how to do it, so i just figured i'd just stick with the bold/italics
the freezing of panes for "return to table of contents" is also a good idea. the autofit mergecells thing sometimes puts ########## in the cell, sometimes fits huge text. im still kinda confused about it, but i can always read the cells if need be
what security checks are you getting? enable macros? the vbe extensibility one? or the outlook "accessing email addresses" one?
i get that last one at home, but not at work. must have been part of sp-2 or sr-3

I'll add that other stuff tomorrow, i dont think its even worth it to bother trying to figure out why the code doesnt work on my home pc

Good suggestions!

mdmackillop
10-14-2004, 03:15 PM
Hi Matt,
When I posted without the VBA brackets, the code came up as follows:

" If CLL.Font.Bold = False Then" & vbCr & _
" Range(""A3:D3"").Font.Bold = False" & vbCr & _
" Range(""A3:D3"").Font.Italic = False" & vbCr & _
" Intersect(Rows(""4:65536""), ActiveSheet.UsedRange).Sort

The security warning is re accessing addresses. It opens up twice at the start of the procedure.

mvidas
10-14-2004, 03:18 PM
ohhhh the : D
I was just being sarcastic anways, I assumed Zack added smilies or something after he added the vba tags.
I've got an error checking in there if you say no to allowing excel to view the addresses, nothing I can do really..

Zack Barresse
10-14-2004, 03:24 PM
w/o Code tags:

" Range(""A3:D3"").Font.Bold = False" & vbCr & _
" Range(""A3:D3"").Font.Italic = False" & vbCr & _

w/ Code tags:

" Range(""A3:D3"").Font.Bold = False" & vbCr & _
" Range(""A3:D3"").Font.Italic = False" & vbCr & _

Muwahahahah! Me add de smiles!!! ;)

mdmackillop
10-14-2004, 03:28 PM
Hi Matt,
Trying the latest version at home and I'm crashing again!!!

:mad:

mvidas
10-15-2004, 06:13 AM
OK, made a few changes/upgrades

changed the sort code to allow it to be sorted back/forth (the way you left it MD, it would sort ascending, then descending, but wouldnt go back to ascending as it was still checking for italics)
added a BeforeDoubleClick event to sort page as well, in case a user double clicks the column headings it wont go in Edit mode for A1 (funny how if you double click C3 then it edits A1 because the first click brings it to A1, then beforedoubleclick must just edit the activecell)
spread the "Find Text" button to always fill cells A1:B2
added "Click on the column headings to sort" on sort page
froze panes for "Return to Table of Contents" on the individual message page.
I'm attaching the newest version as well. I'm still having a couple issues overall though

The inability to work on certain machines, seems like its office 2000 SP-3 that is having the trouble
Find text macro doesn't work on long cells that contain only "#######..."
more than 5 attachments to a message looks bad, printing wise at least. i could probably fix this and just have it use another row, but i will probably just leave it be (the standard form looks nicer in my opinion, and how often are there more than 5 attachments on an email?)
The X button on the progress form obviously doesn't work, im trying to decide if its worth it to work a cancel routine in there. The code to un-enable it is too long in my opinion, from what I could find
I thought about grouping rows 2:8 on the individual message tabs, but it doesn't look as nice as I was hoping, so i canned that idea

I'm gonna do my best to distribute this today, hopefully i should be able to test this on a few machines today.
Any further comments/suggestions?
Malcolm and Dave -- HUGE HELP!!!!!
Zack -- Keep on smilin :)

mvidas
10-15-2004, 07:33 AM
Just as an FYI, I made a copy of this that does not retrieve sender email addresses (no CDO.DLL necessary), as I found out a few computers here at work don't have mapi installed
It might be a help to people having problems, and it gets past the outlook security warning (or at least it should, as the warning deals with accessing the address)

mdmackillop
10-15-2004, 09:04 AM
Hi Matt,
The following amendment should split long sentences into manageable 240+ character strings (split at word breaks) and avoid the ############# problem.



Function ProcessBody(startRg As Range, mBody As String)
Dim WhereAt As Long, delim As String
Dim Chk As Long, i As Integer
delim = vbCrLf
mBody = Replace(mBody, Chr(9), "")
Chk = Len(mBody)
i = 0
If Chk > 240 Then
Do Until i + 1 > Chk / 240
i = i + 1
MySplit = InStr(240 * i, mBody, " ")
Chk = Len(mBody)
mBody = Left(mBody, MySplit) & delim & Right(mBody, Chk - MySplit)
Loop
End If
Do While mBody Like "*" & delim & "*"

mvidas
10-15-2004, 10:24 AM
Nice! :) Breaks it up a little funny sometimes though, so i made a slight change, to break it up only if the info to be entered into the cell is greater than 240. It repeats it at the end as well in case the last chunk of text is greater than 240. A lot longer, but here's my amended code:


Function ProcessBody(startRg As Range, mBody As String)
Dim WhereAt As Long, delim As String, mySplit As Long
Dim Chk As Long, i As Integer, tempmBody As String
delim = vbCrLf
mBody = Replace(mBody, Chr(9), "")
Do While mBody Like "*" & delim & "*"
If Left(mBody, 1) = "=" Then mBody = "'" & mBody
WhereAt = InStr(1, mBody, delim)
Range(startRg, startRg.Offset(0, 9)).Merge
Range(startRg, startRg.Offset(0, 9)).WrapText = True
Chk = WhereAt - 1
If Chk > 240 Then
i = 0
tempmBody = Left(mBody, WhereAt - 1)
Do Until i + 1 > Chk / 240
i = i + 1
mySplit = InStr(240 * i, tempmBody, " ")
Chk = Len(tempmBody)
tempmBody = Left(tempmBody, mySplit) & delim & Right(tempmBody, Chk - mySplit)
Loop
mBody = tempmBody & Mid(mBody, WhereAt)
WhereAt = InStr(1, mBody, delim)
End If
If WhereAt > 1 Then
startRg.NumberFormat = "@"
startRg = Left(mBody, WhereAt - 1)
AutoFitMC startRg
End If
mBody = Mid(mBody, WhereAt + Len(delim))
Set startRg = startRg.Offset(1, 0)
Loop
startRg.NumberFormat = "@"
If Left(mBody, 1) = "=" Then mBody = "'" & mBody
Chk = Len(mBody)
If Chk > 240 Then
i = 0
Do Until i + 1 > Chk / 240
i = i + 1
mySplit = InStr(240 * i, mBody, " ")
Chk = Len(mBody)
mBody = Left(mBody, mySplit) & delim & Right(mBody, Chk - mySplit)
Loop
End If
Do While mBody Like "*" & delim & "*"
If Left(mBody, 1) = "=" Then mBody = "'" & mBody
WhereAt = InStr(1, mBody, delim)
Range(startRg, startRg.Offset(0, 9)).Merge
Range(startRg, startRg.Offset(0, 9)).WrapText = True
If WhereAt > 1 Then
startRg.NumberFormat = "@"
startRg = Left(mBody, WhereAt - 1)
AutoFitMC startRg
End If
mBody = Mid(mBody, WhereAt + Len(delim))
Set startRg = startRg.Offset(1, 0)
Loop
startRg = mBody
Range(startRg, startRg.Offset(0, 9)).Merge
AutoFitMC startRg
End Function
Takes a bit longer to run on the long ones, but it does break it up nicely. Thanks again, thats a great addition!

mdmackillop
10-15-2004, 10:45 AM
I was looking into the split a bit further. If you use


If Chk > 240 Then
i = 0
Do Until i + 1 > Chk / 100
i = i + 1
mySplit = InStr(100 * i, mBody, " ")

then it splits the text into single cells (mostly), which looks better.

mvidas
10-15-2004, 11:00 AM
Good point. I just actually changed the 100 to 90, then removed the AutofitMC lines. Not only does it look nice, its MUCH faster

I also added a line at the end of ProcessBody

Range("A2", Cells(startRg.Row, "K")).Interior.ColorIndex = 2

THANKS!

mdmackillop
10-15-2004, 11:04 AM
I was also going to suggest adding

ActiveWindow.DisplayGridlines = False
at the end of the function to "clean things up"

mdmackillop
10-15-2004, 11:20 AM
I tried removing AutoFitMC, but found there was some text not showing eg in a cell with a text length of 163.

mvidas
10-15-2004, 11:31 AM
I changed all 240's to 100 in my function, and did add the gridlines line


Function ProcessBody(startRg As Range, mBody As String)
Dim WhereAt As Long, delim As String, mySplit As Long
Dim Chk As Long, i As Integer, tempmBody As String
delim = vbCrLf
mBody = Replace(mBody, Chr(9), "")
Do While mBody Like "*" & delim & "*"
If Left(mBody, 1) = "=" Then mBody = "'" & mBody
WhereAt = InStr(1, mBody, delim)
Range(startRg, startRg.Offset(0, 9)).Merge
Range(startRg, startRg.Offset(0, 9)).WrapText = True
Chk = WhereAt - 10
If Chk > 100 Then
i = 0
tempmBody = Left(mBody, WhereAt - 1)
Do Until i + 1 > Chk / 100
i = i + 1
mySplit = InStr(100 * i, tempmBody, " ")
Chk = Len(tempmBody)
tempmBody = Left(tempmBody, mySplit) & delim & Right(tempmBody, Chk - mySplit)
Loop
mBody = tempmBody & Mid(mBody, WhereAt)
WhereAt = InStr(1, mBody, delim)
End If
If WhereAt > 1 Then
startRg.NumberFormat = "@"
startRg = Left(mBody, WhereAt - 1)
End If
mBody = Mid(mBody, WhereAt + Len(delim))
Set startRg = startRg.Offset(1, 0)
Loop
startRg.NumberFormat = "@"
If Left(mBody, 1) = "=" Then mBody = "'" & mBody
Chk = Len(mBody)
If Chk > 100 Then
i = 0
Do Until i + 1 > Chk / 100
i = i + 1
mySplit = InStr(100 * i, mBody, " ")
Chk = Len(mBody)
mBody = Left(mBody, mySplit) & delim & Right(mBody, Chk - mySplit)
Loop
End If
Do While mBody Like "*" & delim & "*"
If Left(mBody, 1) = "=" Then mBody = "'" & mBody
WhereAt = InStr(1, mBody, delim)
Range(startRg, startRg.Offset(0, 9)).Merge
Range(startRg, startRg.Offset(0, 9)).WrapText = True
If WhereAt > 1 Then
startRg.NumberFormat = "@"
startRg = Left(mBody, WhereAt - 1)
End If
mBody = Mid(mBody, WhereAt + Len(delim))
Set startRg = startRg.Offset(1, 0)
Loop
startRg = mBody
ActiveWindow.DisplayGridlines = False
Range(startRg, startRg.Offset(0, 9)).Merge
End Function

So quick!

Also, using my "Outlook to Excel no addresses.xla" didn't get rid of both Outlook warnings (one remained), but it didn't bomb out, even with the .AddFromString portion

mdmackillop
10-15-2004, 11:31 AM
A compromise:
If WhereAt > 90 Then AutoFitMC startRg

Not necessary if we go for the 100 character limit. I'll let you decide!;)

mvidas
10-15-2004, 11:41 AM
Kinda neat how when I posted my reply, i saw yours when my screen refreshed, must have been within seconds

mdmackillop
10-15-2004, 12:02 PM
Looks to me to be pretty well complete. :bigdance2



Time for some beer:drunkard:

mvidas
10-15-2004, 12:09 PM
Looks the same to me :) Dave sent me another idea of how to retrieve the email address, and I'm gonna try that on Monday back at work. The fact that the non-cdo version works on my home PC is such a great feeling! I'll post my final version on Monday

I couldn't have done this so well without you, thank you so much! I'd buy you a beer if I were anywhere near you, too bad. Enjoy though!

Thanks again

Zack Barresse
10-15-2004, 12:10 PM
While the celebration is on, is this a good time to ask for frontal pics of you guys?! ;)

mdmackillop
10-15-2004, 12:15 PM
My Paypal account number is ................!

mvidas
10-15-2004, 12:20 PM
I thought MD's avatar was a frontal pic of him? :) Or can't you zoom (CSI style) into the picture of his monitor to retrieve a reflection of his face?

I haven't had a recent digital pic taken of me, I suppose I could grab my camera right here and take one, but wouldn't that ruin the mystery? I don't think a single digital picture exists of me on the internet that you don't need a name/password to view, I'll have to think if I want to change that :)

And that paypal account is non-existant!

Zack Barresse
10-15-2004, 12:59 PM
... And that paypal account is non-existant!

Yeah, I tried it too ...

(LOL!)

brettdj
10-15-2004, 07:56 PM
Matt,

A bit more reserach

SenderEmailAddress is a new property of the Outlook 2003 model, see
here (http://msdn.microsoft.com/library/default.asp?url=/library/en-us/odc_ol2003_ta/html/odc_OLWhatsNew2k3.asp)

That took a while for them to fix :)

Cheers

Dave

mvidas
10-18-2004, 06:29 AM
Hi All,

What a happy day! I'm hoping this is the final version :)

A couple errors fixed:
-If the messages being imported are already in Deleted Items, and you say yes at that prompt, it gave a "cannot move" error. I put a On Error Resume Next / Goto 0 before and after that section. I thought about saying "Delete messages?" if that were the case, but really not worth it IMO.
-If the line being imported were 120 characters, it locked up as it kept repeating in the Do While loop. That can be fixed by fixing the the two lines of:

tempmBody = Left(tempmBody, mySplit) & delim & Right(tempmBody, Chk - mySplit)
to
If mySplit <> 0 Then tempmBody = Left(tempmBody, mySplit) & delim & Right(tempmBody, Chk - mySplit)
within the ProcessBody sub.
Also, minor wording changes were made.

I changed the "Outlook to Excel no addresses" to just plain "Outlook to Excel", and the former "Outlook to Excel" is now "Outlook to Excel with email address"

Dave, the dummy email idea worked for me, but gave a couple coworkers errors. Since I don't really want to spend any more time getting this working, I just decided to leave the whole email address out of the standard version.

Attached is the zip file containing both versions of this.
Hooray!
Matt

mdmackillop
10-18-2004, 11:53 AM
Looks good Matt :yes
Are you posting is as a KB entry?
MD

mvidas
10-18-2004, 12:53 PM
Soon enough I'm sure, a few of my coworkers have found new errors and given me some suggestions for it, so I'm working those into it first. Then I'll have to simplify it a little bit, as I won't be putting the userform in the KB (and one of the new features, "add to existing file", has a checkbox on the userform).
I'm actually trying to catch up on some of my normal work from last week, as I probably spent a bit too long on this and not enough time on my real work :) I'm sure someone else can find a use for this, so I will add it soon.

I can't say it enough, thanks for all your help!