Automating Outlook via Excel with VBA 1

[Slovardzen]

Hello everyone!

I'm new to VBA programming and I was requested here at work to automate Outlook app with exportation of all data from a Workbook at Excel.

I'm trying a method, a VBA to be more specific, to transfer all my data from a Workbook on Excel to the calendar on Outlook so that I can share with all my coleagues without needing to share the file itself. It is not an appointment, it doesn't have a starting nor ending hour or date so that it is just a very clever way to all members to see what will be happening in the next weeks or months.

I've searched for something likely to what I'm needing but I didn't find much help on it. I've tried the following to see how the solution could apply on my problem:

http://www.eng-tips.com/viewthread.cfm?qid=161689

I did the activation on the references list to Outlook App, but it still returns an error 1004, with a Range at userdate line error. I've done some research also on the web and on e-books but I still can't figure it out. Any guidance here would be very pleasant.

 

[MintJulep]

Outlook calendar works with appointments.

Appointments have start and end times and dates.

There is no way to put a thing that doesn't have start and end times and dates into an Outlook calendar.

 

[IRstuff]

What about Sharepoint?

http://en.wikipedia.org/wiki/Sharepoint

TTFN

FAQ731-376
Chinese prisoner wins Nobel Peace Prize

 

[Slovardzen]

Thank you for the answers, MintJulep and IRstuff.

Actually, I really need to do export data from WorkSheets specially to Outlook. It is easier (in our case) to the employees to access and use the information.

I will write the code I've been working with down. I know there might be some errors but I'm trying my best to correct them, trying new ways and sources. Anything that is wrong or you guys think there is a better way of doing it, please, feel free to telling me to change or correct it.

Private Sub Definindo_Variáveis()

    'Dimensionando as variáveis como aplicações no Outlook
    Dim olApp As New Outlook.Application
    Dim olApt As AppointmentItem
    Dim olNs As Namespace
    'Dimensionando as variáveis a serem utilizadas do Excel
    Dim i, j As Integer
    Dim subject As String
    Dim Data As Date
    
    'Definindo as variáveis para utilização no Excel
    i = RowIndex
    j = ColumnIndex
                
        'A rotina descreve o procedimento para abrir o Outlook e mostrar o calendário, mesmo que ele não esteja aberto
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application") 'Se estiver aberto, não precisa criar nada
        
            'Se caso o Outlook estiver fechado, retornará erro, fazendo com que rode a rotina descrita a seguir, abrindo o Outlook
            If Err.Number = 429 Then
             Set olApp = CreateObject("Outlook.Application") 'Se estiver fechado, necessitará criar objeto para abrí-lo
            End If
             
        'Esta rotina habilita o acesso à mensagens e ao armazenamento do conteúdo das mesmas, de objetos compatíveis com o Outlook
        'Referência: [URL unfurl="true"]http://www.microsoft.com/download/en/details.aspx?DisplayLang=en&id=1004[/URL]
        On Error GoTo 0
        Set olNs = olApp.GetNamespace("MAPI")
        
        'Se a aplicação não retornar nada, esta rotina criará uma e, neste caso, indica o caminho para acessar a pasta default
        'Se retornar, apenas indicará o que acessar, neste caso, a pasta default
        If olApp.ActiveExplorer Is Nothing Then
            'Por default, a pasta de acesso à aplicação é a pasta onde encontra-se MAPI
            olApp.Explorers.Add(olNs.GetDefaultFolder(9), 0).Activate
        Else
            Set olApp.ActiveExplorer.CurrentFolder = olNs.GetDefaultFolder(9)
            '9 é o número que define o default
            olApp.ActiveExplorer.Display
        End If
        
        'Cria um compromisso no Outlook
        Set olApt = olApp.CreateItem(olAppointmentItem)
        
    'Inicia a série de argumentos que identificam as células assunto e data para o Outlook
    With olApt
        If i = 1 Then
            Do
            .Start = Cells(i, j).Value
            Data = Cells(i, j).Value
            j = j + 1
            Loop Until j = 10
        Else
            For i = 2 To 10
            Do
            j = 1
            .subject = Cells(i, j).Value
            subject = Cells(i, j).Value
            j = j + 1
            Loop Until j = 10
            Next
        End If
    End With

        'Se não identificar .Start, o default do programa considerará a data atual
        .Start = Data
        .End = Data
        .AllDayEvent = True
        .Body = ""
        .subject = subject
        .Location = ""
        .BusyStatus = olFree
        .ReminderSet = False
        .Save
        
    'Liberação da memória
    Set olApp = Nothing
    Set olApt = Nothing
    Set olNs = Nothing
    Set Data = Nothing
    Set subject = Nothing
    Set i = Nothing
    Set j = Nothing
    
End Sub

Thanks guys...

 

[MintJulep]

It would be helpful to know what "all of my data from a workbook" is.

However, as I wrote in my first reply, a calendar holds appointment items. Appointment items must have start and end times.

Your code is trying to create appointment items.

You originally stated that "all of my data" does not have start or end times.

 

[Slovardzen]

Hmmm...

All my data would be appointments, events, training and other activities related to all employees of tech support. The main idea is to export these kind of data to the calendar so everyone knows where and what the employees are doing.

I understood what you said about having a beginning and an ending time. My original idea of exporting to show everyone information about the team of employees was to configure all appointment items to be All Day Events. I don`t know if the increments of the loops are correct (I believe they aren`t) but I`ve put a .Start and a .End at the fisrt loop.

The first row of the WorkSheet contains dates in US format. All the rest of the cells in the WorkSheet are those activities I wrote at the beginning of this post. I don`t know if I explained it better this time.

I got stuck in this code, and I`m trying all kind of variations in every part of it. Any guidance would be a great help. Thanks for the help...

 

[MintJulep]

Your logic is wrong.

You are doing this:

Create Appointment
Loop through spreadsheet and change each appointment attribute many times.
save appointment

If it works at all this will create only one appointment with the attributes from the last line of your spreadsheet.

You need to do:

Begin loop through spreadsheet
Create Appointment
Collect each attribute for a single appointment and assign to the appointment item.
Save appointment
Loop to the next appointment's information in the spreadsheet.

 

[MintJulep]

Here is some code to start with. It assumes that your spreadsheet has each "appointment" item in a separate row. Columns are:

A: Start date and time
B: End Date and time
C: All day event (true or false)
D: Body Text
E: Subject Text
F: Location Text
G: Busy status
H: Reminder (True or False)

Option Explicit

    
    Public olNs As Object

Public Sub MakeAppointment(usingApplication As Object, aStart As Date, aEnd As Date, aAllDay As Boolean, aBody As String, aSubject As String, aLocation As String, aBusy As Integer, aRemind As Boolean)
Dim olApp As Object
Dim olApt As Object
Set olApp = usingApplication
Set olApt = olApp.createitem(1)
With olApt
    .Start = aStart
    .End = aEnd
    .alldayevent = aAllDay
    .body = aBody
    .subject = aSubject
    .Location = aLocation
    .busystatus = aBusy
    .reminderset = aRemind
    .Save
End With

End Sub

Public Function ReadyOutlook() As Object

Dim olApp As Object

        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application") 'If Outlook is already running set existing instance as olApp
        
            'if Outlook is not running then creat an instance
            If Err.Number = 429 Then
             Set olApp = CreateObject("Outlook.Application")
            End If
             
        On Error GoTo 0
        Set olNs = olApp.GetNamespace("MAPI")
        
        'Se a aplicação não retornar nada, esta rotina criará uma e, neste caso, indica o caminho para acessar a pasta default
        'Se retornar, apenas indicará o que acessar, neste caso, a pasta default
        If olApp.ActiveExplorer Is Nothing Then
            'Por default, a pasta de acesso à aplicação é a pasta onde encontra-se MAPI
            olApp.Explorers.Add(olNs.GetDefaultFolder(9), 0).Activate
        Else
            Set olApp.ActiveExplorer.CurrentFolder = olNs.GetDefaultFolder(9)
            '9 é o número que define o default
            olApp.ActiveExplorer.Display
        End If
        
        Set ReadyOutlook = olApp
End Function

Public Sub DoStuff()
Dim myxl As Excel.Worksheet
Dim r As Integer

Set myxl = ActiveWorkbook.Sheets(1)

For r = 1 To LastRow(myxl)
Call MakeAppointment(ReadyOutlook, myxl.Cells(r, 1), myxl.Cells(r, 2), myxl.Cells(r, 3), myxl.Cells(r, 4), myxl.Cells(r, 5), myxl.Cells(r, 6), myxl.Cells(r, 7), myxl.Cells(r, 8))
Next r

End Sub

Public Function LastRow(MySheet As Excel.Worksheet) As Integer
LastRow = MySheet.UsedRange.Rows.Count + MySheet.UsedRange.Row - 1
End Function

 

[Slovardzen]

Thank you very much MintJulep. I`ll use the code you posted in the solution, although everytime I have to add some details to it as a challenge, and some more information, but it was a great help for me!!

Thanks again for your time and patience in understanding what I posted. And for correcting the code.