Import from Outlook to Excel

[mvidas]

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]

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]

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]

I was also going to suggest adding

ActiveWindow.DisplayGridlines = False

at the end of the function to "clean things up"

[mdmackillop]

I tried removing AutoFitMC, but found there was some text not showing eg in a cell with a text length of 163.

[mvidas]

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]

A compromise:
[VBA] If WhereAt > 90 Then AutoFitMC startRg[/VBA]

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

[mvidas]

Kinda neat how when I posted my reply, i saw yours when my screen refreshed, must have been within seconds

[mdmackillop]

Looks to me to be pretty well complete.



Time for some beer

[mvidas]

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]

While the celebration is on, is this a good time to ask for frontal pics of you guys?!

[mdmackillop]

My Paypal account number is ................!

[mvidas]

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]

... And that paypal account is non-existant!

Yeah, I tried it too ...

(LOL!)

[brettdj]

Matt,

A bit more reserach

SenderEmailAddress is a new property of the Outlook 2003 model, see
here

That took a while for them to fix

Cheers

Dave

[mvidas]

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:

[vba] tempmBody = Left(tempmBody, mySplit) & delim & Right(tempmBody, Chk - mySplit)[/vba]
to
[vba] If mySplit <> 0 Then tempmBody = Left(tempmBody, mySplit) & delim & Right(tempmBody, Chk - mySplit)[/vba]
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]

Looks good Matt
Are you posting is as a KB entry?
MD

[mvidas]

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!