CODEWITHSUNDEEP
excelvbaoutlook
TechGeek
TechGeek

Reputation: 2212

Excel Shows Junk Characters

I have written a script in outlook to export Selected Email to excel.

Can anybody help me to configure Excel or what change might be required in my code so that it doesn't show Junk Characters like below screenshot?

enter image description here

In one PC it shows correctly but not in other.

Following is my code:

Const ExcelPath = "c:\outlook\outlook_emails.xlsx"

Sub Export_To_Excel()
    Dim oMail As Outlook.MailItem
    Set oMail = GetCurrentItem

    If oMail Is Nothing Then
        MsgBox "No or Invalid Item selected", vbCritical
        Exit Sub
    End If

    On Error GoTo Err_H

    ' Get Email Info
    Email = GetSmtpAddress(oMail)
    Body = Replace(oMail.Body, Chr(9), vbCrLf)
    Subject = Replace(oMail.Subject, Chr(9), vbCrLf)

    ' Export to Excel
    Set oExcel = CreateObject("Excel.Application")
    Set oWB = oExcel.Workbooks.Open(ExcelPath)
    Set oWS = oWB.Sheets(1)
    LastRow = oWS.Cells(oWS.Rows.Count, "A").End(-4162).Row + 1
    oWS.Cells(LastRow, "A") = Format(LastRow - 1, "###")
    oWS.Cells(LastRow, "B") = Email
    oWS.Cells(LastRow, "D") = Body
    oWS.Cells(LastRow, "C") = Subject
    oWS.Cells.RowHeight = 17
    oWS.UsedRange.Font.Name = "Calibri"
    oWS.UsedRange.Font.Size = 8
    oWB.Close True
    Set oExcel = Nothing: Set oWS = Nothing: Set oWB = Nothing

    MsgBox "Successfully exported Email Info exported to Excel", vbInformation
    Exit Sub

Err_H:
    MsgBox Err.Description, vbCritical, "Something Went Wrong"
    Set oExcel = Nothing: Set oWS = Nothing: Set oWB = Nothing
End Sub

Private Function GetCurrentItem() As Outlook.MailItem
    Dim objApp As Outlook.Application
    Set objApp = Application

    On Error GoTo Err_H
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)

        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem

        Case Else
            Set GetCurrentItem = Nothing
    End Select
    Exit Function

Err_H:
    Set GetCurrentItem = Nothing
End Function

Private Function GetSmtpAddress(ByVal item As Outlook.MailItem) As String
    Dim sAddress As String
    Dim recip As Outlook.Recipient
    Dim exUser As Outlook.ExchangeUser
    Dim oOutlook As Outlook.Application
    Dim oNS As Outlook.NameSpace

    Set oOutlook = New Outlook.Application
    Set oNS = oOutlook.GetNamespace("MAPI")
    If UCase$(item.SenderEmailType) = "EX" Then
        Set recip = oNS.CreateRecipient(item.SenderEmailAddress)
        Set exUser = recip.AddressEntry.GetExchangeUser()
        sAddress = exUser.PrimarySmtpAddress
    Else
        sAddress = item.SenderEmailAddress
    End If
    GetSmtpAddress = sAddress
    Set oNS = Nothing
    Set oOutlook = Nothing
End Function

Link to a bigger Image: https://drive.google.com/file/d/0Bwjl0SErKySTMmkwZ21zOXhJSEU/edit?usp=sharing

Upvotes: 1

Views: 1190

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149315

You cells have the special character Chr(160). Try this

Option Explicit

Sub Sample()
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        .Columns(4).Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End With
End Sub

Or in outlook, after this line oWS.Cells(LastRow, "D") = Body

Add this line

oWS.Cells(LastRow, "D").Replace What:=Chr(160), Replacement:="", LookAt:=2, _
SearchOrder:=1, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Upvotes: 1

Related Questions