современный фортран , Бортеньев. О. В. Бартеньев Современный Фортран
 Скачать 2.24 Mb.
|
|
399 О. В. Бартеньев. Современный ФОРТРАН integer(2), dimension(:), intent(out) :: unicodestr integer(4), intent(in), optional :: flags end function MBConvertMBToUnicode integer(4) function MBConvertUnicodeToMB(unicodestr, mbstr, flags) !dec$ attributes default :: MBConvertUnicodeToMB integer(2), dimension(:), intent(in) :: unicodestr character(*), intent(out) :: mbstr integer(4), optional, intent(in) :: flags end function MBConvertUnicodeToMB end interface contains ! Процедуры преобразования строки Фортрана в строку BSTR и обратно; ! заимствованы из файла dfcom.f90 integer(4) function ConvertStringToBSTR(string) character(*), intent(in) :: string integer(4) bstr, length integer(2), allocatable :: unistr(:) ! Строке UNICODE ! Первый вызов MBConvertMBToUnicode определяет длину строки string allocate(unistr(0)) length = MBConvertMBToUnicode(string, unistr) deallocate(unistr) if(length < 0) then ! Специальный случай всех пробелов allocate(unistr(2)) unistr(1) = #20 ! Один пробел unistr(2) = 0 ! Нуль-символ else ! Второй вызов MBConvertMBToUnicode выполняет преобразование allocate(unistr(length + 1)) length = MBConvertMBToUnicode(string, unistr) unistr(length + 1) = 0 ! Завершаем строку нуль-символом end if bstr = SysAllocString(unistr) ! Размещаем BSTR-строку deallocate(unistr) ConvertStringToBSTR = bstr ! Возвращаем результат end function ConvertStringToBSTR integer(4) function ConvertBSTRToString(bstr, string) integer(4), intent(in) :: bstr character(*), intent(out) :: string integer(4) length length = SysStringLen(bstr) ConvertBSTRToString = Convert(bstr, length, string) contains integer(4) function Convert(bstr, length, string) integer(4), intent(in) :: bstr, length character(*), intent(out) :: string integer(2) :: unistr(length) 400 12. Конструктор модулей для объектов ActiveX pointer(p, unistr) p = bstr Convert = MBConvertUnicodeToMB(unistr, string) end function Convert end function ConvertBSTRToString end module mycom module adobjs implicit none ! Указатели на объекты integer(4) :: excelapp, workbooks, workbook, worksheets, worksheet, range, charts, chart integer(4) :: cells(12) integer(4) :: categoryAxis, valueAxis integer(4) :: bstr1, bstr2, bstr3 contains subroutine initobjects( ) ! Задает начальные значения переменных integer(4) i excelapp = 0; workbooks = 0; workbook = 0; worksheets = 0; worksheet = 0 range = 0; charts = 0; chart = 0; categoryAxis = 0; valueAxis = 0; cells = 0 bstr1 = 0; bstr2 = 0; bstr3 = 0 end subroutine initobjects subroutine releaseobjects( ) ! Освобождает созданные объекты use mycom ! Вместо use dfcom integer(4) status, i if(range /= 0) status = COMReleaseObject(range) if(chart /= 0) status = COMReleaseObject(chart) if(charts /= 0) status = COMReleaseObject(charts) if(worksheets /= 0) status = COMReleaseObject(worksheet) if(worksheet /= 0) status = COMReleaseObject(worksheet) if(workbook /= 0) status = COMReleaseObject(workbook) if(workbooks /= 0) status = COMReleaseObject(workbooks) do i =1, 12 if(cells(i) /= 0) status = COMReleaseObject(cells(i)) end do if(categoryAxis /= 0) status = COMReleaseObject(categoryAxis) if(valueAxis /= 0) status = COMReleaseObject(valueAxis) if(excelapp /= 0) status = COMReleaseObject(excelapp) if(bstr1 /= 0) call SysFreeString(bstr1) if(bstr2 /= 0) call SysFreeString(bstr2) if(bstr3 /= 0) call SysFreeString(bstr3) end subroutine releaseobjects end module adobjs program ExcelSample ! Взамен ссылок на модули DFCOM, DFCOMTY и EXCEL97B use mycom use adobjs use excel97b 401 О. В. Бартеньев. Современный ФОРТРАН implicit none integer(4) status, loopCount, roll, maxScale, i, die(2) character(32) :: fname real(4) rnd(2) integer(2) :: cellCounts(12) ! Массив, отображаемый в виде диаграммы type(variant) :: vbstr1, vbstr2, vbstr3, vint print *, 'Enter Excel file name' read *, fname call initobjects( ) ! Инициализация объектов cellCounts = 0 ! Инициализация массива call COMInitialize(status) ! Инициализируем COM и создаем объект Excel call COMCreateObject("Excel.Application.8", excelapp, status) if(excelapp == 0) stop 'Unable to create Excel object; Aborting' call $Application_SetVisible(excelapp, .true.) ! Последовательность операций: ! получить указатель на объект "Рабочая книга"; ! открыть файл fname и создать экземпляр объекта "Рабочая книга"; ! получить указатель на объект "Рабочий лист"; ! задать диапазон заполняемых ячеек таблицы; ! заполнить ячейки из выбранного диапазона значениями массива cellCounts; ! задать отображаемый на диаграмме диапазон ячеек таблицы; ! получить указатель на объект "Диаграмма" и сформировать этот объект; ! задать параметры диаграммы и вызвать построитель диаграмм; ! задать параметры осей диаграммы; ! задать максимальную координату на оси значений ! сформировать отображаемый массив cellCounts; ! Передать данные в Excel и отобразить их на диаграмме ! Псевдокод: ! workbooks = excelapp.GetWorkbooks( ) ! workbook = workbooks.Open(spreadsheet) ! worksheet = workbook.GetActiveSheet ! range = worksheet.GetRange("A1", "L1") ! range.Select( ) ! charts = workbook.GetCharts( ) ! chart = charts.Add( ) 402 12. Конструктор модулей для объектов ActiveX ! chart.ChartWizard(gallery=chartType, title=title, categoryTitle=title, valueTitle=title) ! valueAxis = chart.Axes(type = xlValue, axisGroup = xlPrimary) ! valueAxis.MaximumScale(loopcount / 5) ! Аналогичный код на Фортране: ! Получаем указатель на объект-набор"Рабочая книга" - workbooks workbooks = $Application_GetWorkbooks(excelapp, $status = status) call Check_Status(status, "Unable to get workbooks object") ! Создаем workbook - экземпляр объекта workbooks ! Открываем заданный файл. Указываем в качестве параметра имя XLS-файла workbook = Workbooks_Open(workbooks, fname, $status = status) call Check_Status(status, "Unable to get Workbook object; see if the file path is correct") ! Получаем worksheet - указатель на объект "Рабочий лист" worksheet = $Workbook_GetActiveSheet(workbook, status) call Check_Status(status, "Unable to get Worksheet object") call VariantInit(vbstr1) ! Создаем новую диаграмму call VariantInit(vbstr2) vbstr1%vt = vt_bstr; bstr1 = ConvertStringToBSTR("A1"); vbstr1%vu%ptr_val = bstr1 vbstr2%vt = vt_bstr; bstr2 = ConvertStringToBSTR("L1"); vbstr2%vu%ptr_val = bstr2 ! Задаем диапазон заполняемых ячеек таблицы Excel - от A1 до L1 range = $Worksheet_GetRange(worksheet, vbstr1, vbstr2, status) call Check_Status(status, "Unable to get range object") status = VariantClear(vbstr1); bstr1 = 0 status = VariantClear(vbstr2); bstr2 = 0 ! Заполняем ячейки из выбранного диапазона значениями массива cellCounts status = AUTOSetProperty(range, "Value", cellCounts) ! Выбираем отображаемый на диаграмме диапазон ячеек call Range_Select(range, status) ! Получаем указатель на объект "Диаграмма" charts = $Workbook_GetCharts(workbook, $status = status) call Check_Status(status, " Unable to get charts object") chart = Charts_Add(charts, $status = status) call Check_Status(status, " Unable to add chart object") ! Вызываем построитель диаграмм. Псевдокод: ! chart.ChartWizard(gallery=chartType, title=title, categoryTitle=title, valueTitle=title) call VariantInit(vint) ! Код Фортрана ! Вид гистограммы - объемные вертикальные столбцы vint%vt = vt_i4; vint%vu%long_val = 11 call VariantInit(vbstr1) ! Инициализация варианта vbstr1%vt = vt_bstr ! Тип хранимого значения 403 О. В. Бартеньев. Современный ФОРТРАН bstr1 = ConvertStringToBSTR("Гистограмма cellCounts"); vbstr1%vu%ptr_val = bstr1 call VariantInit(vbstr2); vbstr2%vt = vt_bstr bstr2 = ConvertStringToBSTR("Столбец"); vbstr2%vu%ptr_val = bstr2 call VariantInit(vbstr3); vbstr3%vt = vt_bstr bstr3 = ConvertStringToBSTR("Значение"); vbstr3%vu%ptr_val = bstr3 call $Chart_ChartWizard(chart, & Gallery = vint, & ! Вид диаграммы Title = vbstr1, & ! Заголовок диаграммы CategoryTitle = vbstr2, & ! Заголовок горизонтальной оси ValueTitle = vbstr3, & ! Заголовок вертикальной оси $status = status) call Check_Status(status, "Unable to invoke ChartWizard") status = VariantClear(vbstr1); bstr1 = 0 ! Очищаем варианты status = VariantClear(vbstr2); bstr2 = 0 status = VariantClear(vbstr3); bstr3 = 0 call VariantInit(vint) ! Устанавливаем свойства осей диаграммы vint%vt = vt_i4; vint%vu%long_val = xlValue valueAxis = $Chart_Axes(chart, vint, xlPrimary, $status = status) call Check_Status(status, "Unable to get axis object") loopcount = 1000 ! Число вызовов датчика случайных чисел maxScale = loopcount / 5 ! Максимальная величина на оси значений status = AUTOSetProperty(valueAxis, "MaximumScale", maxScale) call Check_Status(status, "Unable to set axis MaximumScale") call random_seed( ) ! Затравка датчика случайных чисел do i = 1, loopcount ! Формируем отображаемый массив call random_number(rnd) ! Генерируем два случайных числа die = nint((rnd * 6) + 0.5) roll = sum(die) cellCounts(roll) = cellCounts(roll) + 1 end do ! Отображаем данные массива cellCounts в таблице Excel и на диаграмме status = AUTOSetProperty(range, "Value", cellCounts) call Check_Status(status, "Unable to set range value") call releaseobjects( ) ! Освобождаем объекты call COMUninitialize( ) end program ExcelSample subroutine Check_Status(olestatus, errorMsg) use adobjs integer(4) :: olestatus character(*) :: errorMsg if(olestatus >= 0) return call releaseobjects( ) ! Освобождаем объекты write(*, '(a, "; OLE error status = 0x", z8.8, "; Aborting")') trim(errorMsg), olestatus stop end subroutine Check_Status ! Результат приведен на рис. 12.6 404 12. Конструктор модулей для объектов ActiveX Рис. 12.6. Отображение массива cellCounts на диаграмме Excel Замечания: 1. Если после запуска приложения были сохранены изменения в файле histo.xls, то его нужно будет восстановить в исходном виде, например списав с CD, содержащем поставку CVF. 2. Все вызываемые из программы ExcelSample процедуры инициализации и задания свойств объектов сосредоточены в модуле EXCEL97B, который сформирован из полученного при помощи КМ модуля EXEL97A. module excel97b use mycomty use mycom implicit none ! Объявления констант взяты из файла excel97a.f90 type(guid), parameter :: CLSID_Global = & guid(#00020812, #0000, #0000, & char('c0'x)//char('00'x)//char('00'x)//char('00'x)// & char('00'x)//char('00'x)//char('00'x)//char('46'x)) type(guid), parameter :: CLSID_Worksheet = & guid(#00020820, #0000, #0000, & char('c0'x)//char('00'x)//char('00'x)//char('00'x)// & char('00'x)//char('00'x)//char('00'x)//char('46'x)) type(guid), parameter :: CLSID_Chart = & guid(#00020821, #0000, #0000, & 405 О. В. Бартеньев. Современный ФОРТРАН char('c0'x)//char('00'x)//char('00'x)//char('00'x)// & char('00'x)//char('00'x)//char('00'x)//char('46'x)) type(guid), parameter :: CLSID_Application = & guid(#00024500, #0000, #0000, & char('c0'x)//char('00'x)//char('00'x)//char('00'x)// & char('00'x)//char('00'x)//char('00'x)//char('46'x)) ! XlAxisGroup integer, parameter :: xlPrimary = 1, xlSecondary = 2 ! XlAxisType integer, parameter :: xlCategory = 1, xlSeriesAxis = 3, xlValue = 2 contains ! Модульные процедуры ! Все процедуры взяты из файла excel97a.f90 subroutine $Application_SetVisible($object, $arg1, $status) !dec$ attributes dllexport :: $Application_SetVisible !dec$ attributes value :: $object !dec$ attributes reference :: $arg1 !dec$ attributes reference :: $status implicit none integer(4), intent(in) :: $object ! Указатель на объект logical(2), intent(in) :: $arg1 integer(4), intent(out), optional :: $status ! Статус метода integer(4) $$status, invokeargs invokeargs = AUTOAllocateInvokeArgs( ) call AUTOAddArg(invokeargs, 'Visible', $arg1) $$status = AUTOSetPropertyByID($object, 558, invokeargs) if(present($status)) $status = $$status call AUTODeallocateInvokeArgs(invokeargs) end subroutine $Application_SetVisible ! $Application_GetWorkbooks возвращает значение типа POINTER(p, INTEGER(4)) integer(4) function $Application_GetWorkbooks($object, $status) !dec$ attributes dllexport :: $Application_GetWorkbooks !dec$ attributes value :: $object !dec$ attributes reference :: $status implicit none integer(4), intent(in) :: $object ! Указатель на объект integer(4), intent(out), optional :: $status ! Статус метода integer(4) $$status, invokeargs integer(4), volatile :: $return invokeargs = AUTOAllocateInvokeArgs( ) call AUTOAddArg(invokeargs, 'Workbooks', $return, .true., vt_dispatch) $$status = AUTOGetPropertyByID($object, 572, invokeargs) if(present($status)) $status = $$status $Application_GetWorkbooks = $return call AUTODeallocateInvokeArgs(invokeargs) end function $Application_GetWorkbooks 406 12. Конструктор модулей для объектов ActiveX ! Workbooks_Open возвращает значение типа POINTER(p, INTEGER(4)) integer(4) function Workbooks_Open($object, Filename, UpdateLinks, ReadOnly, & Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, & Origin, Delimiter, Editable, Notify, Converter, AddToMru, $status) !dec$ attributes dllexport :: Workbooks_Open !dec$ attributes value :: $object !dec$ attributes reference :: Filename !dec$ attributes reference :: UpdateLinks !dec$ attributes reference :: ReadOnly !dec$ attributes reference :: Format !dec$ attributes reference :: Password !dec$ attributes reference :: WriteResPassword !dec$ attributes reference :: IgnoreReadOnlyRecommended !dec$ attributes reference :: Origin !dec$ attributes reference :: Delimiter !dec$ attributes reference :: Editable !dec$ attributes reference :: Notify !dec$ attributes reference :: Converter !dec$ attributes reference :: AddToMru !dec$ attributes reference :: $status implicit none integer(4), intent(in) :: $object ! Указатель на объект character(*), intent(in) :: Filename ! Имя XLS-файла type(variant), intent(in), optional :: UpdateLinks, ReadOnly, Format, Password, & WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, & Editable, Notify, Converter, AddToMru integer(4), intent(out), optional :: $status ! Статус метода integer(4) $$status, invokeargs integer(4), volatile :: $return invokeargs = AUTOAllocateInvokeArgs( ) ! Константы '$RETURN', '$ARGnn' записываются прописными буквами call AUTOAddArg(invokeargs, '$RETURN', $return, .true., vt_dispatch) call AUTOAddArg(invokeargs, '$ARG1', Filename, .false., vt_bstr) if(present(UpdateLinks)) call AUTOAddArg(invokeargs, '$ARG2', & UpdateLinks, .false.) if(present(ReadOnly)) call AUTOAddArg(invokeargs, '$ARG3', ReadOnly, .false.) if(present(Format)) call AUTOAddArg(invokeargs, '$ARG4', Format, .false.) if(present(Password)) call AUTOAddArg(invokeargs, '$ARG5', Password, .false.) if(present(WriteResPassword)) call AUTOAddArg(invokeargs, '$ARG6', & WriteResPassword, .false.) if(present(IgnoreReadOnlyRecommended)) call AUTOAddArg(invokeargs, '$ARG7', & IgnoreReadOnlyRecommended, .false.) if(present(Origin)) call AUTOAddArg(invokeargs, '$ARG8', Origin, .false.) if(present(Delimiter)) call AUTOAddArg(invokeargs, '$ARG9', Delimiter, .false.) if(present(Editable)) call AUTOAddArg(invokeargs, '$ARG10', Editable, .false.) if(present(Notify)) call AUTOAddArg(invokeargs, '$ARG11', Notify, .false.) if(present(Converter)) call AUTOAddArg(invokeargs, '$ARG12', Converter, .false.) 407 О. В. Бартеньев. Современный ФОРТРАН if(present(AddToMru)) call AUTOAddArg(invokeargs, '$ARG13', AddToMru, .false.) $$status = AUTOinvoke($object, 682, invokeargs) if(present($status)) $status = $$status Workbooks_Open = $return call AUTODeallocateInvokeArgs(invokeargs) end function Workbooks_Open integer(4) function $Workbook_GetActiveSheet($object, $status) !dec$ attributes dllexport :: $Workbook_GetActiveSheet !dec$ attributes value :: $object !dec$ attributes reference :: $status implicit none integer(4), intent(in) :: $object ! Указатель на объект integer(4), intent(out), optional :: $status ! Статус метода integer(4) $$status, invokeargs integer(4), volatile :: $return invokeargs = AUTOAllocateInvokeArgs( ) call AUTOAddArg(invokeargs, 'ActiveSheet', $return, .true., vt_dispatch) $$status = AUTOGetPropertyByID($object, 307, invokeargs) if(present($status)) $status = $$status $Workbook_GetActiveSheet = $return call AUTODeallocateInvokeArgs(invokeargs) end function $Workbook_GetActiveSheet ! $Worksheet_GetRange возвращает переменную типа POINTER(p, INTEGER(4)) integer(4) function $Worksheet_GetRange($object, Cell1, Cell2, $status) !dec$ attributes dllexport :: $Worksheet_GetRange !dec$ attributes value :: $object !dec$ attributes reference :: Cell1 !dec$ attributes reference :: Cell2 !dec$ attributes reference :: $status implicit none integer(4), intent(in) :: $object ! Указатель на объект type(variant), intent(in) :: Cell1 type(variant), intent(in), optional :: Cell2 integer(4), intent(out), optional :: $status ! Статус метода integer(4) $$status, invokeargs integer(4), volatile :: $return invokeargs = AUTOAllocateInvokeArgs( ) ! Первая буква константы 'Range' - прописная call AUTOAddArg(invokeargs, 'Range', $return, .true., vt_dispatch) ! Константы '$ARG1', '$ARG2' записываются прописными буквами call AUTOAddArg(invokeargs, '$ARG1', Cell1, .false.) if(present(Cell2)) call AUTOAddArg(invokeargs, '$ARG2', Cell2, .false.) $$status = AUTOGetPropertyByID($object, 197, invokeargs) if(present($status)) $status = $$status $Worksheet_GetRange = $return call AUTODeallocateInvokeArgs(invokeargs) end function $Worksheet_GetRange |