Export email info to Excel - alert msg prob

[Fenrirshowl]

Hi all

I am trying to use VBA to work with Outlook for the first time. Essentially I want to extract information about emails being sent or received so they can be entered into a ad hoc work flow monitoring system. I have managed to export all the info I need to Excel by referring to
thread707-1253839.

My problem is that I get an alert msg from Outlook:
"A program is trying to access e-mail addresses you have stored in Outlook. Do you want to allow this?"
This pops up for each email. There may be 100s of emails to go through so I would like to bypass this

Is there a way to get rid of it, or at least only show it just the once?

Thanks

Fen

 

[SkipVought]

Hi,

Use CDO (Collaboration Data Objects). You must assign the appropriate values for .Item 2 below...

Public Function CdoSend( _
    MailTo As String, _
    MailFrom As String, _
    Subject As String, _
    MessageText As String, _
    Optional CC As String, _
    Optional BCC As String, _
    Optional FileAttachment As String) As Boolean
On Error GoTo CdoSend_Err

' This example use late binding, you don't have to set a reference
' You must be online when you run the sub
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
 
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
 
        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/sendusing")[/URL] = 2
            .Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpserver")[/URL] =[b] "Your.Mail.Server.com"[/b]
            .Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpserverport")[/URL] = 25
            .Update
        End With
 
    With iMsg
        Set .Configuration = iConf
        
        .To = MailTo
        .CC = CC
        .BCC = BCC
        .FROM = MailFrom
        
        .Subject = Subject
        .TextBody = MessageText

        
        If Len(FileAttachment & "") > 0 Then
            
            '## Last make sure the file actually exists and send it!:
            Dim fso
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FileExists(FileAttachment) Then
                .AddAttachment FileAttachment
            Else
                'otherwise return that the send failed and exit function:
                Debug.Print "[CdoSend.Error]=> File attachment path does not exist, quitting..."
                CdoSend = False
                Exit Function
            End If
        
        End If
    
        '## Send zee message! ##
        .sEnd
    
    End With

    Set fso = Nothing
    Set iMsg = Nothing
    Set iConf = Nothing
    
    CdoSend = True

CdoSend_Exit:
    Exit Function
    
CdoSend_Err:
    Debug.Print "[CdoSend.Error(" & Err.Number & ")]=> " & Err.Description
    CdoSend = False
    Resume CdoSend_Exit
End Function

Then use like this...

Sub CDO_Mail()
Dim msg_txt As String, msg_sub As String, msg_to As String, msg_fr as string

msg_txt = "message text "

msg_sub = "message subject"
msg_to = "To List"
msg_fr = "from address"


CdoSend msg_to, msg_fr, msg_sub, msg_txt


End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Fenrirshowl]

Many, many thanks Skip

I will try to get my brain around all that and work it into my current code!

Fen

 

[Fenrirshowl]

Skip

OK, I've never heard of CDOs, but a quick search of the web tells me that it is a way of accessing Outlook data without triggering alerts. All sounds like what I need, so thank you for that pointer.

I think I understand that code. Am I right in thinking that your code sends emails from Excel, based on the string parameters in CDO_Mail?

If so, I don't see how it helps - which is likely my fault for not being clear. Or perhaps it does help, but I am being clueless.

Situation - I am using VBA in excel, to review emails held within a given folder in outlook, to record information about each email in the active excel worksheet.
Every time the code attempts to work with each email I get the above alert msg, which is my only (current) problem.

My current code follows (heavily cribbed from the quoted thread - so many thanks to CMP!):

Sub GetOutlookItems()
On Error GoTo GetOutlookItems_Error

Dim objOutlook As Object
Dim objFolder As Object
Dim objTarget As Object
Dim objItem As Object

Dim wksOutput As Worksheet
Dim rngToSort As Range
Dim lngRow As Long

Set wksOutput = ActiveSheet

lngRow = 1
wksOutput.Cells(lngRow, 1) = "SenderName"
wksOutput.Cells(lngRow, 2) = "Subject"
wksOutput.Cells(lngRow, 3) = "ConversationTopic"
wksOutput.Cells(lngRow, 4) = "ConversationIndex"
wksOutput.Cells(lngRow, 5) = "To"
wksOutput.Cells(lngRow, 6) = "SentOn"
lngRow = 2


Set objOutlook = GetObject(, "Outlook.Application")

Set objFolder = objOutlook.session.Folders([b][i]ParentFolder[/i][/b])

Set objTarget = objFolder.Folders([b][i]Subfolder[/i][/b]).Folders([b][i]Subfolder[/i][/b]).Folders([b][i]Subfolder[/i][/b])

For Each objItem In objTarget.Items
  If objItem.Class = 43 Then 
    With objItem
      wksOutput.Cells(lngRow, 1) = .SenderName
      wksOutput.Cells(lngRow, 2) = .Subject
      wksOutput.Cells(lngRow, 3) = .ConversationTopic
      wksOutput.Cells(lngRow, 4) = GUIDToString(.ConversationIndex)
      wksOutput.Cells(lngRow, 5) = .To
      wksOutput.Cells(lngRow, 6) = .SentOn
    End With
    lngRow = lngRow + 1
  End If
Next objItem


wksOutput.Range("A1:F" & lngRow).Sort Range("B2"), xlAscending, Range("C2"), , xlAscending, , , xlYes
Clean_Up:
Set wksOutput = Nothing
Set objItem = Nothing
Set objTarget = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
Exit Sub
GetOutlookItems_Error:
Debug.Print Err.Number, Err.Description
Resume Clean_Up
End Sub

Function GUIDToString(GUID As Variant) As String
Dim arrByte() As Byte
Dim intOrdinal As Integer
arrByte = GUID
For intOrdinal = 0 To UBound(arrByte)
  GUIDToString = GUIDToString & Hex$(arrByte(intOrdinal))
Next intOrdinal
End Function

The subfolder I chose within Outlook has 63 msgs in it, so I had to click "Yes" to the alert 63 times.

As mentioned, your point about CDOs would appear to be aiming me in the right direction, though I am concerned that it appears (from the web search) to not be part of the standard build of Outlook (so I may have trouble using it at work). However, those problems aside...

In order to use CDOs, I presume my current code is worthless?
Or can it be easily adapted to work with CDO objects?
If so, would it simply be the inclusion of a line after

Set objOutlook= GetObject(, "Outlook.Application")

as some sort of

Set objCDO= objOutlook.CDO 'A wild stab in the dark!!
Set objFolder = objCDO.session.Folders(parentfolder)
......

or am I way off base? (Apologies for my lack of knowledge on this subject!)

Many thanks in advance

Fen

 

[PHV]

Do a Google search for outlook object model guard

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[SkipVought]

You're going to have to "play" with the CD objects. Maybe do some research to find out what objects are available.

You might start using the Watch Window to discover what some of these objects are. faq707-4594.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Fenrirshowl]

Cheers guys, much appreciated.

Fen

 

[SkipVought]

this may be a helpful link...

http://social.msdn.microsoft.com/Forums/en-US/vbgeneral/thread/9bd26d6c-e231-496d-b56e-47a112d838b2

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Fenrirshowl]

Many thanks Skip - I've got some homework to do!

Fen

 

[Fenrirshowl]

After 3 days of playing with VBA and reading through CDO website pages I cannot find any way of stopping the alert from triggering while attempting to access the .sender property of the mailitem being reviewed.

I think it is because this could be used by viruses to obtain mailing lists / start mail attacks etc. Obviously these viruses exist and are beyond my understanding because I cannot see how they do it!

Cheers anyway

Fen

 

[PHV]

Did you search for outlook object model guard ?

 

[Fenrirshowl]

Hi PHV

I certainly did, but the pages mention
1. the fact that the sender information is protected
2. details the alerts that occur when you try to get that information
3. what errors can occur when you deny access from the alert
rather than how to disable or bypass them. I presume I have not found the right site yet!

If you can suggest a link (or perhaps another key word to concentrate the search) I am more than happy to read through it and try to figure it out (and post my findings of course).

 

[PHV]

You may add clickyes or redemption to your keywords list.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Fenrirshowl]

Thanks PH

clickyes and redemption look like they require downloads which I am trying to avoid due to the "thou shall not download" position of the company I work for.

I have found reference to PR_SENDER_EMAIL_ADDRESS which seems a whole new type of coding (on the CDO side) that seems to also get around the problem.

The search continues but the possibilities look more favourable.

Will post back if I find the answer I am looking for.

 

[Fenrirshowl]

Guys

OK, progress made with the following code to get sender information. It has been cribbed from a website (I have amended the Logon code to avoid the promts, the rest remains the same):

    Private Declare Function HrGetOneProp Lib "mapi32" _
        Alias "HrGetOneProp@12" ( _
            ByVal lpMapiProp As IUnknown, _
            ByVal ulPropTag As Long, _
            ByRef lppProp As Long) As Long

    Private Declare Function MAPIFreeBuffer Lib "mapi32" ( _
            ByVal lppProp As Long) As Long


    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        Destination As Any, Source As Any, ByVal Length As Long)

    Private Declare Function lstrlenA Lib "kernel32.dll" ( _
        ByVal lpString As Long) As Long
        
    Private Type SPropValue
        ulPropTag As Long
        dwAlignPad As Long
        val1 As Long
        val2 As Long
        val3 As Long
    End Type
        
    Private Function LPSTRtoBSTR(ByVal lpsz As Long) As String
        Dim cChars As Long
        cChars = lstrlenA(lpsz)
        LPSTRtoBSTR = String$(cChars, 0)
        CopyMemory ByVal StrPtr(LPSTRtoBSTR), ByVal lpsz, cChars
        LPSTRtoBSTR = Trim(StrConv(LPSTRtoBSTR, vbUnicode))
    End Function

    Private Sub PrintEmail()
        Dim objSesson As Object
        Dim objItem As Object

        Set objsession = CreateObject("MAPI.Session")
        objsession.Logon , , False, False
        Set objItem = objsession.Inbox.Messages.GetFirst

        Dim ptrSProp As Long
        ptrSProp = 0
        If HrGetOneProp(objItem.MAPIOBJECT, &HC1F001E, ptrSProp) = 0 Then
            Dim sprop As SPropValue
            CopyMemory sprop, ByVal ptrSProp, 20
            MsgBox LPSTRtoBSTR(sprop.val1)              
        MAPIFreeBuffer ptrSProp
        End If

        Set objItem = Nothing
        Set objsession = Nothing
    End Sub

It is nearly there (as the sender is in the last bit of the msgbox string) with no alert messages!

BUT the above is completely alien to me. Any assistance on how to get the specific (or more usual) address / sender details would be appreciated.

Fen

 

[Fenrirshowl]

.....I tell a lie.

Changing the email being looked at via "GetLast" gives me the email address of the sender (external).

Using GetFirst I am looking at a co-worker's email address which gives me an odd result.