Thread: outlook 2007 automation

Originally Posted by jaslake

Hi Nutty

I've been on many journeys in my 70 years...I know they can be long and tortuous. I also know that moving targets are hard to hit. Only you can decide what you want. Define your final product...we can then offer solutions.

Do you know your target? If so, please show us; we'll help you to write the code. If the target changes from day to day, you'll lose me.

Hey john I found a code you posted in 2009 for excel - outlook contact update ...and it ran as

Option Explicit
Sub OutlookContacts()
    Dim Arr As Variant
    Dim i As Integer
    Dim rng As Range
    Dim fCell As Range
    Dim LR As Long
    Sheets("OutlookContacts").Activate
    Sheets("OutlookContacts").Cells.ClearContents
    Sheets("Sheet2").Columns("A:N").Copy Destination:=Sheets("OutlookContacts").Range("A1")
    With Sheets("OutlookContacts")
        LR = .Range("B" & .Rows.Count).End(xlUp).Row
        .Range("A" & LR & ":A" & LR + 4).EntireRow.Delete
        .Columns("D:D").EntireColumn.Delete
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        .Columns("F:G").EntireColumn.Insert
        .Range("E1").Value = "City"
        .Range("F1").Value = "State"
        .Range("G1").Value = "Zip"
        .Columns("G:G").NumberFormat = "@"
        Set rng = .Range("E2:E" & LR)
        With rng
            For Each fCell In rng
                Arr = Split(fCell.Value, "  ")
                For i = LBound(Arr) To UBound(Arr)
                    fCell.Offset(0, i) = LTrim(Arr(i))
                Next i
            Next fCell
        End With
    End With
    Call CreateEmailRows
    Call DistList
End Sub
 
 
Public Sub CreateEmailRows()
    Dim rng As Range
    Dim LR As Long
    Dim Ctr As Long
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Set rng = ActiveSheet.Range("J2:J" & LR)
    For Ctr = LR To 2 Step -1
        If Not Range("J" & Ctr).Value = "" Then
            Range("J" & Ctr + 1).EntireRow.Insert
            Range("J" & Ctr).EntireRow.Copy Destination:=Range("J" & Ctr).Offset(1, -9)
            Range("J" & Ctr).Select
            Range("J" & Ctr).Offset(1, -1).Value = Range("J" & Ctr).Value
            Range("J" & Ctr).ClearContents
            Range("J" & Ctr).Offset(1, 0).ClearContents
            Range("J" & Ctr).Offset(0, -7).Value = Range("J" & Ctr).Offset(0, -7).Value & " (1)"
            Range("J" & Ctr).Offset(1, -7).Value = Range("J" & Ctr).Offset(1, -7).Value & " (2)"
        End If
    Next Ctr
End Sub
'Option Explicit
Dim appOutlook As Outlook.Application
Dim objNameSpace As Outlook.Namespace
Dim objContactFolder As Outlook.MAPIFolder
Dim myDistList As Outlook.DistListItem
Dim myMailItem As Outlook.MailItem
Dim olFolder As Object
Dim myContacts As Outlook.Folder
Dim myFolder As Outlook.MAPIFolder
Sub DistList()
    Call OpenOutlook
    Set appOutlook = New Outlook.Application
    Set objNameSpace = appOutlook.GetNamespace("MAPI")
    Set objContactFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    Set myMailItem = appOutlook.CreateItem(olMailItem)
    Set myRecipients = myMailItem.Recipients
    Set myDistList = appOutlook.CreateItem(olDistributionListItem)
    Sheet6.Activate
    Set myFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    On Error Resume Next
    Set myFolder = myFolder.Folders("Glens Residents")
    myFolder.Delete
    On Error GoTo 0
    Set myFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    Set objNameSpace = appOutlook.GetNamespace("MAPI")
    Set olFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    olFolder.Folders.Add ("Glens Residents")
    Set olFolder = myFolder.Folders("Glens Residents")
    olFolder.ShowAsOutlookAB = True
    Set olContacts = olFolder.Items.Add
    For i = 2 To Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set olContacts = olFolder.Items.Add
        With olContacts
            .CompanyName = Range("A" & i).Value
            .LastName = Range("C" & i).Value
            .FirstName = Range("B" & i).Value
            .HomeAddressStreet = Range("K" & i).Value
            .HomeAddressCity = Range("L" & i).Value
            .HomeAddressState = Range("M" & i).Value
            .HomeAddressPostalCode = Range("N" & i).Value
            .Email2Address = Range("J" & i).Value
            .BusinessTelephoneNumber = Range("O" & i).Value
            .Email1Address = Range("I" & i).Value
            .OtherAddressStreet = Range("D" & i).Value
            .OtherAddressCity = Range("E" & i).Value
            .OtherAddressState = Range("F" & i).Value
            .OtherAddressPostalCode = Range("G" & i).Value
            .OtherTelephoneNumber = Range("H" & i).Value
            .Save
        End With
        If Not Range("I" & i).Value = "" Then
            myRecipients.Add olContacts.FullName
        End If
    Next
    Call ChangeEmailDisplayName
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.DLName = "Glens Residents EMail List"
    myDistList.Save
'        'Used for debugging only
'        For j = 1 To myDistList.MemberCount
'        Next j
'        MsgBox "Count is " & myDistList.MemberCount
    Call MoveItems
End Sub
 
 
Sub OpenOutlook()
    Dim ol As Outlook.Application
    Dim olNameSpace As Outlook.Namespace
    Dim olContacts As Outlook.MAPIFolder
    'Error 429 occurs with GetObject if Outlook is not running.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then    'Outlook is NOT running.
        Shell ("Outlook")
    Else
        AppActivate objOutlook.ActiveExplorer.Caption
    End If
    Set olNameSpace = ol.GetNamespace("MAPI")
    Set olContacts = olNameSpace.GetDefaultFolder(olFolderContacts)
    olContacts.Display
End Sub
 
 
Sub MoveItems()
    Dim myNameSpace As Outlook.Namespace
    Dim myContacts As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNameSpace = appOutlook.GetNamespace("MAPI")
    Set myContacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myItems = myContacts.Items
    Set myDestFolder = myContacts.Folders(olFolder.Name)
    Set myItem = myItems.Find("[name] = 'Glens Residents EMail List'")
    While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
    Wend
End Sub
 
 
Public Sub ChangeEmailDisplayName()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim obj As Object
    Dim strFileAs As String
    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactsFolder.Items
    Set objContactsFolder = objContactsFolder.Folders("Glens Residents")
    Set objItems = objContactsFolder.Items
    For Each obj In objItems
        'Test for contact and not distribution list
        If obj.Class = olContact Then
            Set objContact = obj
            With objContact
                'Lastname, Firstname format
                strFileAs = .LastNameAndFirstName
                .Email1DisplayName = strFileAs
                .Save
            End With
        End If
        Err.Clear
    Next
    Set objOL = Nothing
    Set objNS = Nothing
    Set obj = Nothing
    Set objContact = Nothing
    Set objItems = Nothing
    Set objContactsFolder = Nothing

do you have a worksheet l that can explain what this code does ...
I have to automate the contacts list in order to run along with the codes we all have been working on ..please advise

Hello J,

http://www.excelforum.com/outlook-pr...h-mapping.html

I also have a new problem ...Attached is the excel sheet and it is a statement of account ,i.e bills i have to receive and bills I have to pay ..Now I need your help in setting off the invoices against each other in a best possible way ..Rule invoices should look to knock off with each other and return a value = 0 ,if not possible they should return the next closest value ..The main aim is to clean the mess (invoices) more the better ...John I have two 3 assignments where I need your help ...is it possible for you to devote some time ...Details are :

1/ Comparision Of two Excel sheets
2/ Formating the outcome in a specific way to deliver a summary report ..
Regards

Not sure if this is the same issue from when this first started but i have 2 codes here.

the first is for your default email program (i'm using thunderbird)

 Private Declare Function ShellExecute _
   Lib "Shell32.dll" _
     Alias "ShellExecuteA" _
       (ByVal hWnd As Long, _
        ByVal lpOperation As String, _
        ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, _
        ByVal nShowCmd As Long) As Long
Sub EMAILME()
Dim Btn As Excel.Button
  Dim Message As String
  Dim NewLine As String
  Dim R As Long
  Dim RetVal As Long
  Dim Subj As String
  Dim URL As String

    NewLine = "%0D%0A"
    
    Subj = "SUBJECT LINE"
    
    Message = "TYPE THE BODY HERE YOU CAN REFERENCE CELLS FOR THIS."
            
     'Send the email
      URL = "MailTo:" & "EMAIL GOES HERE" & "?subject=" & Subj & "&body=" & Message
      RetVal = ShellExecute(0&, "open", URL, Chr$(0), Chr$(0), vbHide)
                    
   'Did Connection Fail? Errors are from 0 to 32
    If RetVal <= 32 Then
       Select Case RetVal
         Case 2     'SE_ERR_FNF
           Msg = "File not found"
         Case 3      'SE_ERR_PNF
           Msg = "Path not found"
         Case 5      'SE_ERR_ACCESSDENIED
           Msg = "Access denied"
         Case 8      'SE_ERR_OOM
           Msg = "Out of memory"
         Case 32     'SE_ERR_DLLNOTFOUND
           Msg = "DLL not found"
         Case 26     'SE_ERR_SHARE
           Msg = "A sharing violation occurred"
         Case 27     'SE_ERR_ASSOCINCOMPLETE
           Msg = "Incomplete or invalid file association"
         Case 28     'SE_ERR_DDETIMEOUT
           Msg = "DDE Time out"
         Case 29     'SE_ERR_DDEFAIL
           Msg = "DDE transaction failed"
         Case 30     'SE_ERR_DDEBUSY
           Msg = "DDE busy"
         Case 31     'SE_ERR_NOASSOC
           Msg = "Default Email not configured"
         Case 11     'ERROR_BAD_FORMAT
           Msg = "Invalid EXE file or error in EXE image"
         Case Else
           Msg = "Unknown error"
       End Select
       
      Msg = "Unable to Send Email to... " & vbCrLf & "'" & MailTo & "'" & vbCrLf _
          & vbCrLf & "Error Number " & CStr(RetVal) & vbCrLf _
          & Msg
      MsgBox Msg, vbExclamation + vbOKOnly
    End If
    End Sub

the second is for outlook only although i have not tested it.

Option Explicit


Sub EmailOrderForm()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    On Error Resume Next
    On Error GoTo 0
 
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = "emails here"
        .CC = ""
        .BCC = ""
        .Subject = "subject goes here"
        .HTMLBody = "body goes here"
        .Display
    End With
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub