[AP] Export attachments to excel sheet

Sub Click(Source As Button)
    Dim ws As New NotesUIWorkspace
    Dim uiView As NotesUIView
    Dim doc As NotesDocument
    Dim docCol As NotesDocumentCollection

    Set uiView = ws.CurrentView
    Set docCol = uiView.Documents

    Set doc = docCol.GetFirstDocument
    Dim xlApp As Variant
    Dim xlsheet As Variant
    Dim rtitem As Variant
    Dim Ol As Variant
    maxcols= 2
    Set xlApp = CreateObject("Excel.Application")
    xlApp.StatusBar = "Creating WorkSheet. Please be patient..."
    xlApp.Visible = True
    xlApp.Workbooks.Add
    xlApp.ReferenceStyle = 2
    rows = 1
    cols = 1
    Set xlsheet = xlApp.Workbooks(1).Worksheets(1)

    xlsheet.Cells(rows,1).Value = "Created By"
    xlsheet.Cells(rows,2).Value = "File/Attachment"
    cols=1
    rows=2
    While Not doc Is Nothing

        xlsheet.Cells(rows,1).Value = doc.CreatedBy(0)
        Set rtitem = doc.GetFirstItem("FileUpload")
        If ( rtitem.Type = RICHTEXT ) Then
            Forall o In rtitem.EmbeddedObjects
                If ( o.Type = EMBED_ATTACHMENT ) Then
                    Call o.ExtractFile ( "d:\temp\" & Cstr(doc.FileName(0)) )
                End If
            End Forall
            xlsheet.Cells(rows,2).select

        '   xlsheet.Cells(rows,2).OLEObjects.Add Cstr(doc.FileName(0)),  "d:\temp\" & Cstr(doc.FileName(0)), , True, , , Cstr(doc.FileName(0))      
            'Set Ol = xlApp.OLEObjects.Add(Cstr(doc.FileName(0)),  "d:\temp\" & Cstr(doc.FileName(0)), True, False)
            xlsheet.OLEObjects.Add( "", "d:\temp\" & Cstr(doc.FileName(0)), False, False).Select


        End If

        Set doc = docCol.GetNextDocument(doc)
        rows=rows+1
        cols=1
    Wend
    xlApp.Rows("1:1").Select
    xlApp.Selection.Font.Bold = True
    xlApp.Selection.Font.Underline = True
    xlApp.Range(xlsheet.Cells(1,1), xlsheet.Cells(rows,maxcols)).Select
    xlApp.Selection.Font.Name = "Arial"
    xlApp.Selection.Font.Size = 8
    xlApp.Selection.Columns.AutoFit
    With xlApp.Worksheets(1)
        .PageSetup.Orientation = 2
        .PageSetup.centerheader = "Report - Confidential"
        .Pagesetup.RightFooter = "Page &P" & Chr$(13) & "Date: &D"
        .Pagesetup.CenterFooter = ""
    End With
    xlApp.ReferenceStyle = 1
    xlApp.Range("A1").Select
    xlApp.StatusBar = "Importing Data from Lotus Notes Application was Completed."
End Sub