CARNET D'ADRESSE OUTLOOK VERS EXCEL (OFFICE 2003) EN VS 2005

Imports Outlook = Microsoft.Office.Interop.Outlook
Imports Excel = Microsoft.Office.Interop.Excel
Imports System.Windows.Forms
Imports System.Drawing

Public Class OutlookAdresses
    Private m_ExcelApp As Excel.Application
    Private m_OutlookApp As Outlook.Application
    Private m_MapiContact As Outlook.MAPIFolder
    Private processes() As Process
    Private procName As String = "Outlook"
    Private m_OutlookRun As Boolean
    Private m_OutlookId As Integer
    Private m_OutlookBefore(), m_OutlookAfter() As Process
    Private m_ExcelBefore(), m_ExcelAfter() As Process
    Private m_ExcelId As Integer
    Private m_WorkBook As Excel.Workbook
    Private m_WorkSheet As Excel.Worksheet
    Private m_NbTxt As Integer = 1
    Private m_rg As Excel.Range

    Private Sub ButLancer_Click(ByVal sender As System.Object, _
                        ByVal e As System.EventArgs) Handles ButLancer.Click
        If m_OutlookApp Is Nothing Then

            Try
                'si Outlook est en cours d'éxécution on utilise son instance
                Me.m_OutlookApp = System.Runtime.InteropServices.Marshal.GetActiveObject("Outloo.Application")
                Me.m_OutlookRun = True
            Catch ex As Exception
                'création d'une instance Outlook et renvoi de son ID de process pour Kill()
                m_OutlookId = CreateInstanceOutlook()
            End Try
            '/ Récupération du répertoire contact de Outlook.
            Me.m_MapiContact = m_OutlookApp.GetNamespace("MAPI"). _
            GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)
        End If
        For Each Ci As Outlook.ContactItem In m_MapiContact.Items
            'Dim ci As Outlook.ContactItem = DirectCast(Contact, Outlook.ContactItem)
            Dim dt As String() = {Ci.FullName, Ci.Email1Address, Ci.HomeTelephoneNumber}
            For i As Integer = 0 To dt.Length - 1
                If IsNothing(dt(i)).ToString Then dt(i) = "/"
            Next
            Me.DataGridView1.Rows.Add(dt)
        Next
        Me.ButExcel.Enabled = True
    End Sub

    Private Sub OutlookAdresses_FormClosed(ByVal sender As Object, _
            ByVal e As System.Windows.Forms.FormClosedEventArgs) Handles Me.FormClosed
        '/ si pas d'instances ouvertes, on quitte
        If (m_ExcelId = 0) And (m_OutlookId = 0) Then Exit Sub
        '/ si des instances Outlook ou Excel ont été crées,on les détruit
        If m_ExcelId Then   'm_ExcelId # 0 / 0=False
            m_ExcelApp = Nothing
            Process.GetProcessById(m_ExcelId).Kill()
        End If
        If m_OutlookId Then     ' m_IdApp # 0 / 0=False
            '/ si Outlook était ouvert, on laisse l'application en fonctionnement
            '/ sinon on détruit l'instance
            If m_OutlookRun Then
                'm_OutlookApp.Quit()
                m_MapiContact = Nothing
                m_OutlookApp = Nothing
            Else
                System.Runtime.InteropServices.Marshal.ReleaseComObject(m_MapiContact)
                System.Runtime.InteropServices.Marshal.ReleaseComObject(m_OutlookApp)
                Process.GetProcessById(m_OutlookId).Kill()
                Exit Sub
            End If
        End If
    End Sub

    Private Sub ButQuit_Click(ByVal sender As System.Object, _
                            ByVal e As System.EventArgs) Handles ButQuit.Click
        Me.Close()
    End Sub

    Function CreateInstanceOutlook() As Integer
        'Détection des instance éventuelles Outlook
        Me.m_OutlookBefore = Process.GetProcessesByName(procName)
        'Instance oulook application
        Me.m_OutlookApp = New Outlook.Application
        'Détection des Instances Outlook
        Me.m_OutlookAfter = Process.GetProcessesByName(procName)
        If m_OutlookBefore.Length = 0 Then
            CreateInstanceOutlook = m_OutlookAfter(0).Id
        Else
            For Each proc As Process In m_OutlookAfter
                For i As Integer = 0 To m_OutlookBefore.Length - 1
                    If Not proc.Id = m_OutlookBefore(i).Id Then
                        CreateInstanceOutlook = proc.Id
                    End If
                Next
            Next
        End If
    End Function
    Function CreateInstanceExcel() As Integer
        Me.m_ExcelBefore = Process.GetProcessesByName("Excel")
        Me.m_ExcelApp = New Excel.Application
        Me.m_ExcelAfter = Process.GetProcessesByName("Excel")
        If m_ExcelBefore.Length = 0 Then
            CreateInstanceExcel = m_ExcelAfter(0).Id
        Else
            For Each proc As Process In Me.m_ExcelAfter
                For i As Integer = 0 To Me.m_ExcelBefore.Length - 1
                    If Not proc.Id = Me.m_ExcelBefore(i).Id Then
                        CreateInstanceExcel = proc.Id
                    End If
                Next
            Next
        End If

    End Function

    Private Sub ButExcel_Click(ByVal sender As System.Object, _
                        ByVal e As System.EventArgs) Handles ButExcel.Click
        '/ test si le fichier Excel a déjà été généré(reclic sur bouton "Vers Excel")
        If m_ExcelId Then
            m_ExcelApp = Nothing
            Process.GetProcessById(m_ExcelId).Kill()
        End If
        If m_ExcelApp Is Nothing Then
            '/creer une instance Excel et renvoi du Process.id
            m_ExcelId = CreateInstanceExcel()
            '/ si pas de fichier, ajout d'un WorkBook et enregistrement.
            Me.m_ExcelApp.DisplayAlerts = False
            Me.m_WorkBook = Me.m_ExcelApp.Workbooks.Add(Type.Missing)
            Me.m_WorkBook.SaveAs("C:\Documents and Settings\" & _
                    Environment.UserName & "\Bureau\Adresses Mails.xls", _
            Type.Missing, Type.Missing, Type.Missing, Type.Missing, Type.Missing, _
            Excel.XlSaveAsAccessMode.xlNoChange, Type.Missing, Type.Missing, _
            Type.Missing, Type.Missing)
        End If

        InitFichierExcel()
        EcrireFichierExcel()
        MsgBox("Le fichier Excel a été placé sur le Bureau" & _
           vbCrLf & "Après lecture supprimer ce fichier")
        Me.m_ExcelApp.Visible = True
        Me.Visible = True

    End Sub
    Private Sub EcrireFichierExcel()
        Me.m_WorkSheet = Me.m_WorkBook.ActiveSheet
        With Me.m_WorkSheet

            For i As Integer = 0 To Me.DataGridView1.RowCount - 1
                .Cells(2 + i, 1).value = Me.DataGridView1.Rows(i).Cells(0).Value.ToString
                .Cells(2 + i, 2).value = Me.DataGridView1.Rows(i).Cells(1).Value.ToString
                .Cells(2 + i, 3).value = Me.DataGridView1.Rows(i).Cells(2).Value.ToString
            Next
        End With
        '/ Suppression du message Excel si le fichier existe déjà /
        Me.m_ExcelApp.DisplayAlerts = False
        '/ on enregistre le fichier sur le bureau /
        Me.m_WorkBook.SaveAs("C:\Documents and Settings\" & _
                    Environment.UserName & "\Bureau\Adresses Mails.xls", _
                    Type.Missing, Type.Missing, Type.Missing, Type.Missing, Type.Missing, _
                    Excel.XlSaveAsAccessMode.xlNoChange, Type.Missing, Type.Missing, _
                    Type.Missing, Type.Missing)
    End Sub

#Region "Mise en forme fichier Excel barre de titre et couleur cellules"
    Sub InitFichierExcel()
        Dim rg As String = "A1:C1"
        Me.m_rg = Me.m_WorkBook.ActiveSheet.Range(rg)
        '/ Mise en forme de la ligne de titres
        Dim bord As Excel.XlBordersIndex() = {Excel.XlBordersIndex.xlEdgeBottom, _
        Excel.XlBordersIndex.xlEdgeLeft, Excel.XlBordersIndex.xlEdgeRight, _
        Excel.XlBordersIndex.xlEdgeTop, Excel.XlBordersIndex.xlInsideVertical}
        With m_rg
            For i As Integer = 0 To bord.Length - 1
                With .Borders(bord(i))
                    .LineStyle = Excel.XlLineStyle.xlContinuous
                    .Weight = Excel.XlBorderWeight.xlThick
                    .ColorIndex = 54
                End With
            Next
            .Interior.ColorIndex = 15
            .VerticalAlignment = Excel.XlVAlign.xlVAlignCenter
            .HorizontalAlignment = Excel.XlHAlign.xlHAlignCenter
            .Font.Size = 14
            .Font.ColorIndex = 2
        End With
        Me.m_WorkBook.ActiveSheet.Range("A1").Value = "Nom"
        Me.m_WorkBook.ActiveSheet.columns("A:A").columnwidth = 30
        Me.m_WorkBook.ActiveSheet.Range("B1").Value = "Adresse eMail"
        Me.m_WorkBook.ActiveSheet.columns("B:B").columnwidth = 40
        Me.m_WorkBook.ActiveSheet.Range("C1").Value = "Téléphone"
        Me.m_WorkBook.ActiveSheet.columns("C:C").columnwidth = 20
        '/ Fin de Mise en forme de la ligne de titres
        rg = "A2:C" & Me.DataGridView1.RowCount + 1
        Me.m_rg = Me.m_WorkBook.ActiveSheet.Range(rg)
        For Each c As Object In Me.m_rg.Cells
            For i As Integer = 0 To 2
                With c.borders(bord(i))
                    .LineStyle = Excel.XlLineStyle.xlContinuous
                    .Weight = Excel.XlBorderWeight.xlThin
                    .ColorIndex = 54
                End With
            Next
            c.font.size = 12
        Next
        '/ fond de cellule pour chaque colonne
        Dim nbLig As Integer = Me.DataGridView1.RowCount - 1
        For i As Integer = 0 To nbLig
            With Me.m_rg
                .Cells(1 + i, 1).interior.colorindex = 36
                .Cells(1 + i, 2).interior.colorindex = 35
                .Cells(1 + i, 3).interior.colorindex = 40
            End With
        Next
    End Sub
#End Region

#Region "cette procédure était prévue pour afficher le Nom et l'Adresse eMail"
    '/ dans des TextBox creés dynamiquement."
    Private Sub Buttxt_Click(ByVal sender As System.Object, _
                            ByVal e As System.EventArgs)
        Dim m_decalV As Integer = 30
        Dim Txtnom As New TextBox
        Txtnom.Name = "TextBoxNom" & CType(m_NbTxt, String)
        Txtnom.Location = New Point(50, 50 + m_decalV * m_NbTxt)
        Txtnom.Size = New Size(140, 20)
        Me.Controls.Add(Txtnom)
        Dim TxtMail As New TextBox
        TxtMail.Name = "TextBoxMail" & CType(m_NbTxt, String)
        TxtMail.Location = New Point(200, 50 + m_decalV * m_NbTxt)
        TxtMail.Size = New Size(250, 20)
        Me.Controls.Add(TxtMail)
        m_NbTxt += 1
        Dim T As String = ""
        For Each c As Control In Me.Controls
            If TypeOf c Is TextBox Then
                T += c.Name & vbCrLf
            End If
        Next
        MsgBox(T)
    End Sub
#End Region
End Class

Télécharger le zip