Re: Экспорт из Lotus в Word или Exel

2017-04-27T10:57:49Z

Выгрузка в таблицу Exel из всех документов базы Лотуса.

Sub Click(Source As Button)
    Dim session As New NotesSession
    Dim db As NotesDatabase
    Set db = session.CurrentDatabase
    Dim MUdb As NotesDataBase
    Set MUdb = session.Getdatabase("Br/inf", "....ficeork\...hiv.nsf")
    Dim dc As NotesDocumentCollection
    Dim formula As String
    Dim row As Double
    Dim doc As NotesDocument
    Dim item As NotesItem
    formula$ = { (Form = "Register" & !@IsResponseDoc) & (@IsNotMember("3":"4":"5";CurStatusCreatReorgLiquidIzmen) ) & IsArhivDoc=1 }
    Print formula$
    Set dc=MUdb.Search(formula$,Nothing,0) 
    Print "Найдено: " & dc.count
    Set xl=CreateObject("Excel.Application")
' Создадим книгу Excel
    Set xlWbk=xl.Workbooks.Add    
    'Вывод названия выгрузки 
    xlWbk.ActiveSheet.Cells(2, 1).RowHeight=30
    xlWbk.ActiveSheet.Range("A2").HorizontalAlignment = -4108
    xlWbk.ActiveSheet.Cells(2, 1)="Действующие юридические лица" 
    xlWbk.ActiveSheet.Range("A2:H2").Merge
    numberrow%=1
    row=5
    xlWbk.ActiveSheet.Cells(5, 1)="№ п/п"
    xlWbk.ActiveSheet.Cells(5, 1).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 1).Font.Bold=True 
    
    xlWbk.ActiveSheet.Cells(5, 2)="Полное наименование"
    xlWbk.ActiveSheet.Cells(5, 2).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 2).Font.Bold=True 
    
    xlWbk.ActiveSheet.Cells(5, 3)="Город"
    xlWbk.ActiveSheet.Cells(5, 3).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 3).Font.Bold=True
    
    xlWbk.ActiveSheet.Cells(5, 4)="Улица"
    xlWbk.ActiveSheet.Cells(5, 4).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 4).Font.Bold=True
    
    xlWbk.ActiveSheet.Cells(5, 5)="Дом"
    xlWbk.ActiveSheet.Cells(5, 5).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 5).Font.Bold=True
    
    xlWbk.ActiveSheet.Cells(5, 6)="Квартира/комната/кабинет"
    xlWbk.ActiveSheet.Cells(5, 6).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 6).Font.Bold=True
    
    xlWbk.ActiveSheet.Cells(5, 7)="Телефон"
    xlWbk.ActiveSheet.Cells(5, 7).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 7).Font.Bold=True
    
    xlWbk.ActiveSheet.Cells(5, 8)="Руководитель"
    xlWbk.ActiveSheet.Cells(5, 8).Borders.LineStyle = 1
    xlWbk.ActiveSheet.Cells(5, 8).Font.Bold=True 
    
    'Ширина столбцов и установка флага переноса по словам в ячейке
    xlWbk.ActiveSheet.columns(2).ColumnWidth=25
    xlWbk.ActiveSheet.Cells(row, 2).WrapText = True
    xlWbk.ActiveSheet.columns(3).ColumnWidth=25
    xlWbk.ActiveSheet.Cells(row, 3).WrapText = True
    xlWbk.ActiveSheet.columns(4).ColumnWidth=25
    xlWbk.ActiveSheet.Cells(row, 4).WrapText = True
    xlWbk.ActiveSheet.columns(5).ColumnWidth=10
    xlWbk.ActiveSheet.Cells(row, 5).WrapText = True
    xlWbk.ActiveSheet.columns(6).ColumnWidth=10
    xlWbk.ActiveSheet.Cells(row, 6).WrapText = True
    xlWbk.ActiveSheet.columns(7).ColumnWidth=20
    xlWbk.ActiveSheet.Cells(row, 7).WrapText = True
    xlWbk.ActiveSheet.columns(8).ColumnWidth=65
    xlWbk.ActiveSheet.Cells(row, 8).WrapText = True    
    
    
'выравнивание по верху, типа xlTop
    xlWbk.ActiveSheet.Cells(row, 1).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 2).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 3).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 4).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 5).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 6).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 7).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 8).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 9).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 10).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 11).VerticalAlignment = -4160
    xlWbk.ActiveSheet.Cells(row, 12).VerticalAlignment = -4160
    
    row=6
    
    
    For i=1 To dc.count
        Set doc = dc.GetNthDocument(i)    
        
'        Номер п/п
        xlWbk.ActiveSheet.Cells(row, 1).NumberFormat="@"
        xlWbk.ActiveSheet.Cells(row, 1)=numberrow%
'Полное наименование
        xlWbk.ActiveSheet.Cells(row, 2)=doc.FullName(0)
'Город
        xlWbk.ActiveSheet.Cells(row, 3)=doc.Atown(0)
'Улица
        xlWbk.ActiveSheet.Cells(row, 4)=doc.Astreet(0)
'Дом
        xlWbk.ActiveSheet.Cells(row, 5).NumberFormat="@"
        xlWbk.ActiveSheet.Cells(row, 5)=doc.Ahouse(0)
'Квартира/комната/кабинет/
        xlWbk.ActiveSheet.Cells(row, 6).NumberFormat="@"
        xlWbk.ActiveSheet.Cells(row, 6)=doc.Aflat(0)
'Телефон
        xlWbk.ActiveSheet.Cells(row, 7).NumberFormat="@"
        xlWbk.ActiveSheet.Cells(row, 7)=doc.Atelephon(0)
' Руководитель    
        If doc.hasitem("Director") Then
            Set item = doc.GetFirstItem("Director")
            xlWbk.ActiveSheet.Cells(row, 8)= item.Text
        Else
            xlWbk.ActiveSheet.Cells(row, 8)= doc.Director(0)
        End If
        
        row = row +1
        numberrow%=numberrow%+1        
    Next
    xl.Visible=True
    
    
End Sub

Экспорт из Lotus в Word или Exel

2015-05-06T05:45:30Z

Передача данных в MS Excel

Переменные для OLE
Dim EObj As Variant
Dim xlsheet As Variant
Dim xl As Variant
Dim Rang As Variant
Dim Cell1 As Variant
Dim Cell2 As Variant

запуск и установка настроек Excel
создаем OLE объект

Set EObj = CreateObject("Excel.Application")
If EObj Is Nothing Then 'проверка на наличие установленного Excel
Messagebox "Не установлен Excel!!!", 0 + 16 , "ошибка"
Exit Sub
End If
If Isnull(EObj) Then 'если не получилось, то выходим
Messagebox "Не удается создать 'книгу'."
Exit Sub
End If
Print ("Запуск Excel Application...")
' Отключаем реакцию Excel на события, чтобы ускорить вывод информации
EObj.Application.EnableEvents=False
Set NewBook = EObj.Workbooks.Add("")
Set xlsheet = EObj.Workbooks(1).Worksheets(1)

'установка полей таблицы
EObj.ActiveSheet.PageSetup.LeftMargin= EObj.Application.InchesToPoints(0.35)
EObj.ActiveSheet.PageSetup.RightMargin= EObj.Application.InchesToPoints(0.35)
EObj.ActiveSheet.PageSetup.TopMargin= EObj.Application.InchesToPoints(0.35)
EObj.ActiveSheet.PageSetup.BottomMargin= EObj.Application.InchesToPoints(0.45)
EObj.ActiveSheet.PageSetup.FooterMargin = EObj.Application.InchesToPoints(0.30)
'установка ориентации страницы
EObj.ActiveSheet.PageSetup.Orientation= Cint(cd.okrug(0))

форматирование таблицы

Set xl=xlsheet.Range(xlsheet.Cells(1,col0),xlsheet.Cells(row1,col1))
xl.font.name="Times New Roman"
xl.WrapText=True 'перенос по словам

'прорисовка всех клеток
'вся таблица
Set xl=xlsheet.Range(xlsheet.Cells(row0,col0),xlsheet.Cells(row1,col1))
xl.borders.LineStyle = 1
xl.borders.Weight = 2
xl.VerticalAlignment=-4160
If cd.okrug(0)="1" Then
xl.font.size=11
Else
xl.font.size=10
End If
For i1=7 To 10
xl.Borders(i1).LineStyle = 1
xl.Borders(i1).Weight = 3
Next

'шапка
Set xl=xlsheet.Range(xlsheet.Cells(row0,col0),xlsheet.Cells(row0,col1))
xl.font.bold=True
xl.HorizontalAlignment=-4108
xl.VerticalAlignment=-4108
xl.Borders(4).LineStyle = 1
xl.Borders(4).Weight = 3

занесение заголовка

xlsheet.Cells(1,1)=SS1
xlsheet.Cells(2,1)=SS2

перенос сформировавшегося массива в Excel

Set Cell1=xlsheet.cells(row0,col0) 'левая верхняя ячейка диаппазона
Set Cell2=xlsheet.cells(row1,col1) 'правая нижняя ячейка диаппазона
Set rang=xlsheet.range(cell1,cell2)
Rang.Value = SumData

EObj.Visible=True
Print ("Отчет готов")

Форум компьютерной помощи — Экспорт из Lotus в Word или Exel

Re: Экспорт из Lotus в Word или Exel

Экспорт из Lotus в Word или Exel