Онлайн кредиты займы Казахстан онлайн кредиты усть-каманеногорск кредиты онлайн алматы взять онлайн займ в Казахстане гта5 играть на компьютере Pole Dance алматы играть онлайн форсаж 8 pokemon go играть вот ссылка гороскоп совместимости любовный гороскоп на 2017 рак девушка сексуальный гороскоп он телец она рыбы гороскопы близнецов любовный одиночные любовный любовный гороскоп гороскоп совместимости совместимость знаков в любви любовный гороскоп для рыб на сегодня и на завтра любовный гороскоп знака водолей гороскоп совместимости парень козерог девушка весы гороскоп совместимость гороскоп на месяц любовный рак основываясь на этих данных гороскоп женщина рыба мужчина весы совместимость гороскоп совместимости смотрите подробнее гороскоп на эту неделю стрелец любовный гороскоп дева любовный на сегодня и завтра гороскоп любви весы на завтра вот ссылка сексуальный гороскоп девы и овна гороскоп на совместимость телец и рыбы рак на сегодня гороскоп любовь гороскоп весы гороскоп совместимости для рыб на 2017 гороскоп семейный и любовный на сегодня гороскоп рак любовный совместимость по гороскопу женщина телец мужчина рак совместимость гороскоп секс гороскоп совместимости гороскоп телец мужчина женщина скорпион совместимость гороскоп любовный гороскоп любовный узнать больше перейти гороскоп совместимости любовный гороскоп двух львов гороскоп на неделю телец любовный гороскоп стрелец женщина и весы мужчина совместимость в браке гороскоп совместимости весы жен овен муж гороскоп совместимости сексуальный гороскоп совместимости гороскоп сегодня совместимость гороскопу источник статьи гороскоп козы ссылка на страницу гороскоп весы и лев любовный гороскоп совместимость совместимость по гороскопу рыба и дева гороскоп для женщины рак на сегодня любовь читать больше гороскоп пифагора совместимости знаков зодиака совместимость овен и лев по гороскопу подробнее на этой странице гороскоп гороскоп сексуальный любовный гороскоп ссылка совместимость свиньи и петуха по восточному гороскопу гороскоп совместимости гороскоп совместимости гороскоп на совместимость женщина телец любовный гороскоп гороскоп дева совместимость гороскопов лев скорпион гороскоп гороскоп гороскоп совместимости рыба тигр любовный гороскоп женщина козерог 2017 любовный гороскоп козерог на сегодня женщина любовный гороскоп для девы на сегодня и завтра гороскоп стрелец гороскоп на тельца на совместимость гороскоп на сегодня дева на оракул любовный гороскоп совместимости по знакам зодиака овен и водолей
Rambler's Top100
Российский фонд помощи
Навигация
Главная
MS ACCESS
VB
ASP
PHP
Наши друзья
Поиск
Форум
Лента новостей
Новый сайт

Online
Сейчас на сайте находятся:
1 гость
Рассылки Subscribe.Ru
Работа с MS Access
Подписаться письмом
Реклама на сайте
 
Работа с OpenOffice.org Calc из VBA Печать E-mail
Автор osmor   
08.02.2008 г.
Оглавление
Работа с OpenOffice.org Calc из VBA
Страница 2
В статье приведен код демонстрируюйщий некоторые основные приемы работы с OpenOffice.org Calc из MS ACCESS или другого приложения MS Office.
Представлены следующие операции:
  • Создание новой книги OpenOffice.org Calc
  • Открытие существующей книги OpenOffice.org Calc
  • Создание нового листа в книге OpenOffice.org Calc
  • Запись данных в ячейку
  • Запись формулы в ячейку
  • Запись функции в ячейку
  • Получение ссылки на ячейку или диапазон ячеек по индексу
  • Получение ссылки на ячейку или диапазон ячеек по имени
  • Форматирование ячейки или диапазона ячеек 3-мя разными способами
  • Создание и использование стилей
  • Рисование рамки ячейки или диапазона ячеек
  • Добавление/удаление строки/столбца
  • Изменение имени листа
  • Удаление листа
  • Вывод списка всех листов
  • Сохранение файла в формате OpenOffice.org Calc
  • Сохранение файла в формате PDF


Option Compare Database
Option Explicit


Public Function Sample_OOO()
'Демонстрирует некоторые приемы работы с OpenOffice.org Calc
'см. комментарии в тексте программы
'Oleg Smorchkov aka osmor специально для www.hiprog.com
'при цитировании ссылка на hiprog.com обязательна
Dim oServiceManager As Object
Dim oDesktop As Object
Dim oCalcDoc As Object
Dim oBook As Object
Dim oSheet As Object
Dim aNoArgs()
Dim oCells  As Object
Dim i As Integer
Dim j As Integer
Dim cUrl As String
On Error GoTo Sample_OOO_Error

'создаем новый ServiceManager
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set oCalcDoc = oServiceManager.createInstance("com.sun.star.frame.Desktop")
' создаем новую книгу OpenOffice.org Calc
Set oBook = oCalcDoc.loadComponentFromURL("private:factory/scalc", "_blank", 0, aNoArgs())
'получаем ссылку на первый лист новой книги
Set oSheet = oBook.getSheets().getByIndex(0)
'заполняем первые 10 ячеек первых 10 строк случайными числами от 1 до 1000
' обращение к ячейке происходит по индексу, нумерация с 0
' т.е. чтобы получить ячейку в первом столбце первой строки пишем oSheet.getCellByPosition(0,0)
'кроме того в getCellByPosition первый аргумент столбец, второй строка (в Excel наоборот)
For i = 0 To 9
    For j = 0 To 9
        Call oSheet.getCellByPosition(i, j).SetFormula(Int(1000 * Rnd + 1))
    Next
Next

'Заполняем 11-й столбец (K) формулой вычисляющую сумму ячейки из 9- и 10-й  (I и J) колонок
'за минусом ячейки из 7-й (G) колонки для каждой строки
' т.е. для первой строки формула будет "=(I1+ J1)-G1"
'поскольку поддержка ссылок типа R1C1 включена не во все сборки OOo
'используем строковые имена ячеек собирая их "вручную". Не забывая
'что нумерация ячеек в программе идет с 0, а в формулах с 1
'Это не всегда удобно, т.к. "буквы" столбцов заданы в тексте программы
'и в данном случаем приведено просто как возможный вариант
j = 10
For i = 0 To 9
    Call oSheet.getCellByPosition(j, i).SetFormula("=(I" & i + 1 & "+ J" & i + 1 & ")-G" & i + 1)
Next
'Заполняем 12-й столбец такой же формулой как и 11-й
'но адреса ячеек получив вспомогательной функцией CellRangeAddressString
'возвращающей строковое представления адреса ячейки
' в этом случае если в последующем эта формула будет в другом столбце
' программу переписывать не придется
j = 11
For i = 0 To 9
    Call oSheet.getCellByPosition(j, i).SetFormula("=(" & CellRangeAddressString(oSheet.getCellByPosition(j - 3, i)) & "+ " & CellRangeAddressString(oSheet.getCellByPosition(j - 2, i)) & ")-" & CellRangeAddressString(oSheet.getCellByPosition(j - 5, i)))
Next

'Заполняем 11-ю строку формулой вычисляющую суммы по колонкам
j = 10
For i = 0 To 11
    Call oSheet.getCellByPosition(i, j).SetFormula("=SUM(" & CellRangeAddressString(oSheet.getCellRangeByPosition(i, 0, i, j - 1)) & ")")
Next

'------------------------------------------------------------
'покраска ячейки F6 с использованием MakePropertyValue
'------------------------------------------------------------
    Dim prop(1) As Object
    Dim disp As Object
    Set disp = CreateUnoService("com.sun.star.frame.DispatchHelper")
    'переход к форматируемой ячейки
    Set prop(0) = MakePropertyValue("ToPoint", "$f$6")
    Call disp.executeDispatch(oCalcDoc, ".uno:GoToCell", "", 0, prop)
    'цвет фона
    Set prop(0) = MakePropertyValue("BackgroundPattern.BackColor", 14426880)
    Call disp.executeDispatch(oCalcDoc, ".uno:BackgroundPattern", "", 0, prop)
    'жирный шрифт
    Set prop(0) = MakePropertyValue("Bold", True)
    Call disp.executeDispatch(oCalcDoc, ".uno:Bold", "", 0, prop)
    'цвет шрифта
    Set prop(0) = MakePropertyValue("Color", 7012500)
    Call disp.executeDispatch(oCalcDoc, ".uno:Color", "", 0, prop)
    'Курсив
    Set prop(0) = MakePropertyValue("Italic", True)
    Call disp.executeDispatch(oCalcDoc, ".uno:Italic", "", 0, prop)
    Set disp = Nothing


'------------------------------------------------------------
' форматирование ячейки "D5" используя свойство ячейки
' ссылку на ячейку получаем по имени методом getCellRangeByName
'------------------------------------------------------------
Set oCells = oSheet.getCellRangeByName("D5")
With oCells
    .CellBackColor = RGB(0, 255, 0)  'цвет фона
    .CharColor = RGB(255, 0, 0) 'Цвет текста
    .CharWeight = 150 'Толщина шрифта
    .IsTextWrapped = True ' Переносить по словам
End With

'-------------------------------------------------------------
'форматирование ячейки  "E3" с использованием стиля
'стиль можно использовать несколько раз для разных ячеек
'ссылку на ячейку получаем по индексу
'-------------------------------------------------------------
    Dim oMyStyle As Object
    Set oCells = oSheet.getCellByPosition(4, 2)

    Set oMyStyle = oBook.createInstance("com.sun.star.style.CellStyle")
    Call oBook.getStyleFamilies().getByName("CellStyles").insertByName("osmorStyle", oMyStyle)
    oMyStyle.CellBackColor = RGB(255, 220, 220) ' цвет фона
    oMyStyle.IsCellBackgroundTransparent = False
    oMyStyle.CharColor = RGB(0, 0, 200) ' цвет  шрифта
    oMyStyle.CharWeight = 150 ' толщина шрифта
    oCells.CellStyle = "osmorStyle" ' применяем стиль к выбранной ячейке
    Set oMyStyle = Nothing
'-------------------------------------------------------------
'применение созданного выше стиля "osmorStyle" для форматирования
'диапазона ячеек "K1:L10"
'ссылку на диапазона получаем по имени методом getCellRangeByName
'-------------------------------------------------------------
 Set oCells = oSheet.getCellRangeByName("K1:L11")
 oCells.CellStyle = "osmorStyle" ' применяем стиль к выбранному диапазону

'-------------------------------------------------------------
'применение созданного выше стиля "osmorStyle" для форматирования
'диапазона ячеек "A11:L11"
'сслыку на диапазона получаем получаем по номерам строк и столбцов методом getCellRangeByPosition
'-------------------------------------------------------------
 Set oCells = oSheet.getCellRangeByPosition(0, 10, 11, 10)
 oCells.CellStyle = "osmorStyle" ' применяем стиль к выбранному диапазону

'-------------------------------------------------------------
'Рисуем рамку для всех ячеек диапазона "A11:L11"
' используем вспомогательную функцию MakeCellBorderLine
'-------------------------------------------------------------
'левая рамка будет из двух линий
Set oCells.LeftBorder = MakeCellBorderLine(RGB(255, 100, 100), 75, 75, 50)
Set oCells.RightBorder = MakeCellBorderLine(RGB(255, 100, 100), 0, 75, 0)
Set oCells.TopBorder = MakeCellBorderLine(RGB(255, 100, 100), 0, 75, 0)
Set oCells.BottomBorder = MakeCellBorderLine(RGB(255, 100, 100), 0, 75, 0)

'вставляем одну строку перед первой строкой (строка с индексом 0)
'первый аргумент индекс вставляемой строки, второй - количество строк
Call oSheet.Rows.insertByIndex(0, 1)

'Удаляем столбец "B"
'первый аргумент индекс удаляемого столбца, второй - количество столбцов
Call oSheet.Columns.removeByIndex(1, 1)


' переименуем лист, в который мы выводили данные
oSheet.Name = "Новый лист"
' создадим новый лист после текущего
Call oBook.getSheets.InsertNewByName("ЕщеНовыйЛист", findSheetIndex(oBook, oSheet.Name) + 1)
'Выводим в окно Immediate список всех листов книги
ListSheetName oBook
'удаляем 3-й лист (лист с именем "Лист2" и индексом 2)
Call oBook.getSheets.removeByName(oBook.getSheets.getByIndex(2).Name)

'сохраняем созданную книгу в формате
'Электронной таблицы OpenDokument
'в корне диска С: с именем SampleOOo.ods
cUrl = ConvertToUrl("c:\SampleOOo" + ".ods")
Call oBook.storeToURL(cUrl, aNoArgs)
'сохраняем созданную книгу в формате PDF
'в корне диска С: с именем SampleOOo.PDF
cUrl = ConvertToUrl("c:\SampleOOo" + ".pdf")
Set prop(0) = MakePropertyValue("FilterName", "calc_pdf_Export")
Call oBook.storeToURL(cUrl, prop)
'закрываем созданную книгу
Call oBook.Close(False)
'Открываем только что сохраненную книгу
cUrl = ConvertToUrl("c:\SampleOOo" + ".ods")
Set oBook = oCalcDoc.loadComponentFromURL(cUrl, "_blank", 0, aNoArgs())

Set oBook = Nothing
Set oSheet = Nothing
Set oCalcDoc = Nothing
Set oServiceManager = Nothing

On Error GoTo 0
   Exit Function

Sample_OOO_Error:
    Select Case Err.Number
        Case 1001
            MsgBox "Ошибка при сохранении файла, файл занят другим приложением"
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Sample_OOO"
        End Select
End Function


'вспомогательные функции

Public Function CreateUnoService(strServiceName) As Object
'Создание объекта UnoService
Dim oServiceManager As Object
    Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
    Set CreateUnoService = oServiceManager.createInstance(strServiceName)
End Function

Function MakePropertyValue(cName, uValue) As Object
'создание объекта Property и присвоение ему значения
  Dim oPropertyValue As Object
  Dim oSM As Object

  Set oSM = CreateObject("com.sun.star.ServiceManager")
  Set oPropertyValue = oSM.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
  oPropertyValue.Name = cName
  oPropertyValue.Value = uValue

  Set MakePropertyValue = oPropertyValue

End Function


Function MakeCellBorderLine(nColor, nInnerLineWidth, nOuterLineWidth, nLineDistance) _
            As Object
'Функция  создания объекта BorderLine содержащего информацию о линии рамки
'параметры nColor - цвет рамки
'nInnerLineWidth - толщина внутренней линии
' nOuterLineWidth - - толщина внутренней линии
' расстояние между внутренней и внешней линией
  Dim oSM As Object
  Dim oBorderLine As Object
  Set oSM = CreateObject("com.sun.star.ServiceManager")
  Set oBorderLine = oSM.Bridge_GetStruct("com.sun.star.table.BorderLine")
     With oBorderLine
        .Color = nColor
        .InnerLineWidth = nInnerLineWidth
        .OuterLineWidth = nOuterLineWidth
        .LineDistance = nLineDistance
    End With
  Set MakeCellBorderLine = oBorderLine
End Function


Public Sub ListSheetName(oDoc As Object)
'Выводит имена и индексы всех листов книги переданной в качестве параметра
   Dim i As Integer
   On Error GoTo ListSheetName_Error
    For i = 0 To oDoc.Sheets.Count - 1
       Debug.Print "Лист индекс "; i; " называется "; oDoc.Sheets.getByIndex(i).Name
    Next

   On Error GoTo 0
   Exit Sub

ListSheetName_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ListSheetName"
End Sub


Function findSheetIndex(oDoc As Object, sheetName As StringAs Integer
'возвращает индекс листа книги переданной в качестве параметра по его имени
    Dim i As Integer
    For i = 0 To oDoc.Sheets.Count - 1
       If oDoc.Sheets.getByIndex(i).Name = sheetName Then
            findSheetIndex = i
            Exit Function
        End If
    Next i
    findSheetIndex = -1
End Function


Function CellRangeAddressString(oCellRng As ObjectAs String
'возвращает символьный адрес переданной ячейки или диапазона
    Dim FuncService As Object
    Set FuncService = CreateUnoService("com.sun.star.sheet.FunctionAccess")

    Select Case oCellRng.getImplementationName()
       Case "ScCellObj"
        CellRangeAddressString = FuncService.CallFunction( _
           "ADDRESS", _
        Array(oCellRng.CellAddress.Row + 1, _
              oCellRng.CellAddress.Column + 1))

        Case "ScCellRangeObj"
           CellRangeAddressString = FuncService. _
                 CallFunction("ADDRESS", _
              Array(oCellRng.RangeAddress.StartRow + 1, _
                      oCellRng.RangeAddress.StartColumn + 1))
           CellRangeAddressString = CellRangeAddressString _
                     & ":" & FuncService.CallFunction( _
               "ADDRESS", _
               Array(oCellRng.RangeAddress.EndRow + 1, _
                             oCellRng.RangeAddress.EndColumn + 1))

    End Select

 End Function


Public Function ConvertToUrl(strFile) As String
'конвертирует путь MS Windows в URL (RFC 1738)
    strFile = Replace(strFile, "\", "/")
    strFile = Replace(strFile, ":", "|")
    strFile = Replace(strFile, " ", "%20")
    strFile = "file:///" + strFile
    ConvertToUrl = strFile
End Function

При написании использовались материалы сайта http://www.oooforum.org/
Код тестировался на OpenOffice.org 2.2.1 Pro сборка ООО «Инфра-ресурс» (http://www.i-rs.ru/)


Просмотров: 28612

  Коментарии (15)
 1 Написал(а) час, в 15:46 08.02.2008
Спасибо за статью. 
Сейчас это очень актуальная тема. 
Бум изучать и вникать. 
Может веточку такую запустить ? 
Как Вы думаете?
 2 Написал(а) amba-l, в 13:55 14.02.2008
тогда еще и StarOffice от Sun
 3 Написал(а) Час, в 06:41 16.03.2008
Огромное спасибо автору статьи!!! 
:)
 4 Написал(а) час, в 12:48 06.06.2008
Опен офис почему -то приживается в больших случаях нежели Звёздный.
 5 Написал(а) Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script , в 05:41 03.11.2009
oSheet.getCellByPosition( 0, 0 ) КАК МОЖНО К НЕМУ ПРИСВОИТЬ ЗНАЧЕНИЕ КАКОЙ ЛИБО ПЕРЕМЕННОЙ?? 
ПОМОГИТЕ ПЛИЗ
 6 Написал(а) osmor, в 07:25 03.11.2009
в статье все подробно расписано 
Call oSheet.getCellByPosition(i, j).SetFormula(Переменная)
 7 Написал(а) Тигра, в 14:06 16.11.2009
подскажите пожалуйста как сравнить две ячейки по значениям :?
 8 Написал(а) osmor, в 05:58 17.11.2009
if Sheet.getCellByPosition(1, 1).getValue() = Sheet.getCellByPosition(2, 1).getValue() then
 9 Написал(а) Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script , в 07:16 25.03.2010
подскажите пожалуйста как получить адрес текущей ячейки в открытом файле ODS используя VBA, на OObasic это выглядит так: 
 
oselect = ThisComponent.CurrentSelection 
oColumn = oselect.Columns 
oRow = oselect.Rows
 10 Написал(а) час, в 12:24 26.04.2010
А вон выше написано 
Set oCells = oSheet.getCellRangeByName("K1:L11") 
Это вам не подходит?


 
Реклама на сайте
HiProg.com - Технологии программирования
Rambler's Top100 TopList