Sample Code 17

contents index previous next

Sample Code 17

Fortran module f90VBGUIUtils with new subroutines CreateExcelChart (new code in the module is indicated in red)

module f90VBGUIUtils

!load f90VB modules

use f90VBDefs

use f90VBBStrings

use f90VBVariants

use f90VBAutomation

implicit none

type(VARIANT):: CInput

integer::UpperValue=10

type(VARIANT)::CMain

logical::QuitApplication

contains

subroutine CreateExcelChart(CMain, iRet)

!arguments

type(VARIANT),intent(in)::CMain

integer(HRESULT_KIND),intent(out)::iRet

!Variants containing main objects

type(VARIANT)::Excel, WorkBook, Chart, Range

!Variants used to store temporal objects and collections

type(VARIANT)::VarTmp, XLabel, YLabel

integer::i

character(len=20)::RangeStr

!If excel is already running, then get an interface

!to the running instance

Excel = GetActiveOleObject('Excel.Application',iRet)

if (iRet.ne.S_OK) then

!no instances of excel are running, create one

Excel = CreateOleObject('Excel.Application', iRet)

if (iRet.ne.S_OK) then

iRet=-2

goto 1000

endif

!Add a new workbook by calling Workbooks.Add method

WorkBook=ExecMethod(Excel,'Workbooks.Add')

!Add headings to the first two columns

!Get heading from MSFlexGrid in CMain

XLabel = PropertyGet(CMain,'fgTable.TextMatrix', &

VariantCreate(VT_I4,0),VariantCreate(VT_I4,0))

!Write heading to cell A1 in spreadsheet

call PropertyPut(WorkBook,'ActiveSheet.Cells', XLabel, &

VariantCreate(VT_I4,1),VariantCreate(VT_I4,1))

!Get heading from MSFlexGrid in CMain

YLabel = PropertyGet(CMain,'fgTable.TextMatrix', &

VariantCreate(VT_I4,0),VariantCreate(VT_I4,1))

!Write heading to cell B1 in spreadsheet

call PropertyPut(WorkBook,'ActiveSheet.Cells', YLabel, &

VariantCreate(VT_I4,1),VariantCreate(VT_I4,2))

!Add all the computed values

do i=1, VariantToInteger(PropertyGet(CMain,'fgTable.Rows'))-1

!Get Value from MSFlexGrid

VarTmp = PropertyGet(CMain,'fgTable.TextMatrix', &

VariantCreate(VT_I4,i),VariantCreate(VT_I4,0))

!Convert Value into a real

call VariantChangeType(VarTmp,VarTmp,VT_R8)

call PropertyPut(WorkBook,'ActiveSheet.Cells', VarTmp, &

VariantCreate(VT_I4,i+1),VariantCreate(VT_I4,1))

!Get log(Value) or Factorial(Value) from MSFlexGrid

VarTmp = PropertyGet(CMain,'fgTable.TextMatrix', &

VariantCreate(VT_I4,i),VariantCreate(VT_I4,1))

!Convert Value into a real

call VariantChangeType(VarTmp,VarTmp,VT_R8)

call PropertyPut(WorkBook,'ActiveSheet.Cells', VarTmp, &

VariantCreate(VT_I4,i+1),VariantCreate(VT_I4,2))

enddo

!Create a range with the cells we have just entered

write(RangeStr,'(a4,i3.3)') 'A1:B',i

VarTmp = VariantCreate(VT_BSTR,trim(RangeStr))

Range = PropertyGet(Excel,'Range',VarTmp)

!clean VarTemp's BSTR

call VariantClear(VarTmp)

!add a new chart to the current workbook

Chart=ExecMethod(WorkBook,'Charts.Add')

!Set the type of the chart to xy-line plot (73)

call PropertyPut(Chart,'ChartType', VariantCreate(VT_I4,73))

!Set the range object to be the data for the chart

VarTmp=ExecMethod(Chart,'SetSourceData',Range, VariantCreate(VT_I4,2))

!We don't want to see a legend in this case, so remove it

call PropertyPut(Chart,'HasLegend',VariantCreate(VT_BOOL,.false.))

!Set the title for the chart and its properties

call PropertyPut(Chart,'HasTitle',VariantCreate(VT_BOOL,.true.))

VarTmp = VariantCreate(VT_BSTR,'f90VB Demo Chart')

call PropertyPut(Chart,'ChartTitle.Text',VarTmp)

call PropertyPut(Chart,'ChartTitle.Font.Bold',VariantCreate(VT_BOOL, .true.))

call PropertyPut(Chart,'ChartTitle.Font.Size',VariantCreate(VT_I2, 14))

!clean VarTemp's BSTR

call VariantClear(VarTmp)

!set several other properties of the chart to make it look nicer

call PropertyPut(Chart,'PlotArea.Fill.Visible',VariantCreate(VT_BOOL,.false.))

VarTmp = ExecMethod(Chart,'Axes', VariantCreate(VT_I2,2), iRet=iRet)

call PropertyPut(VarTmp,'HasTitle',variantCreate(VT_BOOL, .true.), iRet=iRet)

call PropertyPut(VarTmp,'AxisTitle.Text',YLabel, iRet=iRet)

call Release(VarTmp)

VarTmp = ExecMethod(Chart,'Axes', VariantCreate(VT_I2,1), iRet=iRet)

call PropertyPut(VarTmp,'HasTitle',variantCreate(VT_BOOL, .true.))

call PropertyPut(VarTmp,'AxisTitle.Text',XLabel)

call Release(VarTmp)

!Make sure excel is visible

call PropertyPut(Excel,'Visible',VariantCreate(VT_BOOL,.true.))

!Clean up

call VariantClear(XLabel)

call VariantClear(YLabel)

call Release(Range)

call Release(Chart)

call Release(Workbook)

call Release(Excel)

iRet=0

1000 Continue

end subroutine CreateExcelChart

subroutine ComputeLogarithms(CMain,UpperValue)

!arguments

type(VARIANT),intent(in)::CMain

integer,intent(in)::UpperValue

!internal variables

integer::i

real(DOUBLE_KIND)::x

type(VARIANT)::VarStr

!Set the labels on the grid

VarStr = VariantCreate(VT_BSTR,'Value')

call PropertyPut(CMain,'fgTable.TextMatrix',VarStr, &

VariantCreate(VT_I4,0),VariantCreate(VT_I4,0))

call VariantClear(VarStr)

VarStr = VariantCreate(VT_BSTR,'Log(Value)')

call PropertyPut(CMain,'fgTable.TextMatrix',VarStr, &

VariantCreate(VT_I4,0),VariantCreate(VT_I4,1))

call VariantClear(VarStr)

!Reset the number of rows to the number of values computed

call PropertyPut(CMain,'fgTable.rows',VariantCreate(VT_I4,UpperValue+1))

!compute new values and fill the MSFlexGrid in CMain with them

do i=1, UpperValue

x=log(real(i))

!Put the value and the computed logs on the grid

call PropertyPut(CMain,'fgTable.TextMatrix',VariantCreate(VT_I4,i), &

VariantCreate(VT_I4,i),VariantCreate(VT_I4,0))

call PropertyPut(CMain,'fgTable.TextMatrix',VariantCreate(VT_R4,x), &

VariantCreate(VT_I4,i),VariantCreate(VT_I4,1))

enddo

end subroutine ComputeLogarithms

subroutine ComputeFactorials(CMain,UpperValue)

!arguments

type(VARIANT),intent(in)::CMain

integer,intent(in)::UpperValue

!internal variables

integer(LONG_KIND)::i,j

type(VARIANT)::VarStr

!Set the labels on the grid

VarStr = VariantCreate(VT_BSTR,'Value')

call PropertyPut(CMain,'fgTable.TextMatrix',VarStr, &

VariantCreate(VT_I4,0),VariantCreate(VT_I4,0))

call VariantClear(VarStr)

VarStr = VariantCreate(VT_BSTR,'Factorial(Value)')

call PropertyPut(CMain,'fgTable.TextMatrix',VarStr, &

VariantCreate(VT_I4,0),VariantCreate(VT_I4,1))

call VariantClear(VarStr)

!Reset the number of rows to the number of values computed

call PropertyPut(CMain,'fgTable.rows',VariantCreate(VT_I4,UpperValue+1))

!compute new values and fill the MSFlexGrid in CMain with them

j=1

do i=1, UpperValue

j=j*i

!Put the value and the computed logs on the grid

call PropertyPut(CMain,'fgTable.TextMatrix',VariantCreate(VT_I4,i), &

VariantCreate(VT_I4,i),VariantCreate(VT_I4,0))

call PropertyPut(CMain,'fgTable.TextMatrix',VariantCreate(VT_I4,j), &

VariantCreate(VT_I4,i),VariantCreate(VT_I4,1))

enddo

end subroutine ComputeFactorials

function CMainEventsHandler(DispID, nArgs, VarArgList, nNamedArgs, DispIDList)

!procedure arguments

integer(HRESULT_KIND)::CMainEventsHandler

integer(LONG_KIND),intent(in)::DispID

integer(LONG_KIND),intent(in)::nArgs

type(VARIANT),intent(inout)::VarArgList(nArgs)

integer(LONG_KIND),intent(in)::nNamedArgs

integer(LONG_KIND),intent(in)::DispIDList(nNamedArgs)

!Internal definitions

character(len=100),parameter:: DescTextLogs = 'Please enter below the upper &

&value for which the logarithms &

&will be computed'

character(len=100),parameter:: DescTextFact = 'Please enter below the upper &

&value for which the factorials &

&will be computed'

integer,parameter::TopLogs = 500

integer,parameter::TopFact = 12

integer(HRESULT_KIND)::iRet,I

logical::OpCanceled

select case (DispID)

case(1) !OnQuit

QuitApplication=.true.

case(2) !OnLogTableClick event

call GetInputValue(CInput, trim(DescTextLogs), TopLogs, &

UpperValue, OpCanceled)

if (.not. OpCanceled) then

call ComputeLogarithms(CMain,UpperValue)

endif

case(3) !OnFactorialTableClick

call GetInputValue(CInput, trim(DescTextFact), TopFact, &

UpperValue, OpCanceled)

if (.not. OpCanceled) then

call ComputeFactorials(CMain,UpperValue)

endif

case(4) !OnAboutBoxClick

call DisplayAboutBox()

case(5) !OnExcelChartClick

call CreateExcelChart(CMain, iRet)

if (iRet.ne.0) then

call DisplayError('Could not find Excel application')

endif

end select

CMainEventsHandler = S_OK

end function CMainEventsHandler

function CMainTestEventsHandler(DispID, nArgs, VarArgList, nNamedArgs, DispIDList)

!procedure arguments

integer(HRESULT_KIND)::CMainTestEventsHandler

integer(LONG_KIND),intent(in)::DispID

integer(LONG_KIND),intent(in)::nArgs

type(VARIANT),intent(inout)::VarArgList(nArgs)

integer(LONG_KIND),intent(in)::nNamedArgs

integer(LONG_KIND),intent(in)::DispIDList(nNamedArgs)

select case (DispID)

case(1) !OnQuit

print *,'Quitting'

QuitApplication=.true.

case(2) !OnLogTableClick event

print *,'Menu Option Logs Table selected'

case(3) !OnFactorialTableClick

print *,'Menu Option Factorials Table selected'

case(4) !OnAboutBoxClick

call DisplayAboutBox()

case(5) !OnExcelChartClick

print *,'Menu Option Excel Chart selected'

end select

CMainTestEventsHandler = S_OK

end function CMainTestEventsHandler

subroutine GetInputValue(CInput, DescText, TopRange, InputValue, OpCanceled)

!procedure arguments

type(VARIANT),intent(in)::CInput

character(len=*),intent(in):: DescText

integer,intent(in)::TopRange

integer,intent(inout)::InputValue

logical,intent(out)::OpCanceled

type(VARIANT)::VarTmp

!set the MaxValue property of the object

call PropertyPut(CInput,'MaxValue',VariantCreate(VT_I4,TopRange))

!Set the default input value

call PropertyPut(CInput,'InputValue',VariantCreate(VT_I4, InputValue))

!Set the description text

VarTmp = VariantCreate(VT_BSTR, DescText)

call PropertyPut(CInput,'DescrText',VarTmp)

!Clear the BString in VarTmp

call VariantClear(VarTmp)

!Show the input window and wait for a user answer

VarTmp = ExecMethod(CInput,'Show')

OpCanceled = VariantToLogical(PropertyGet(CInput,'OpCanceled'))

if (.not. OpCanceled) then

InputValue = VariantToInteger(PropertyGet(CInput,'InputValue'))

endif

end subroutine GetInputValue

subroutine DisplayAboutBox()

!internal variables

type(VARIANT)::CAbout

type(VARIANT)::VarTmp

integer(HRESULT_KIND)::iRet

!Create an instance of the CAbout object

CAbout= CreateOleObject('f90VBGUI.CAbout',iRet)

if (iRet.eq.S_OK) then

!Show the about window

VarTmp = ExecMethod(CAbout,'Show')

!clean up

call Release(CAbout)

call VariantClear(VarTmp)

endif

end subroutine DisplayAboutBox

subroutine DisplayError(ErrorMessage)

!procedure arguments

character(len=*),intent(in)::ErrorMessage

!internal variables

type(VARIANT)::CError, VarErrMsg

type(VARIANT)::VarTmp

integer(HRESULT_KIND)::iRet

!Create an instance of the CError object

CError= CreateOleObject('f90VBGUI.CError',iRet)

if (iRet.eq.S_OK) then

!Set its ErrorMessage property

VarErrMsg = VariantCreate(VT_BSTR,ErrorMessage)

call PropertyPut(CError,'ErrorMessage',VarErrMsg)

!Show the error window

VarTmp = ExecMethod(CError,'Show',VariantCreate(VT_BOOL,.true.))

!clean up

call Release(CError)

call VariantClear(VarErrMsg)

call VariantClear(VarTmp)

endif

end subroutine DisplayError

end module f90VBGUIUtils

Sample Code 18a