Sample Code 15

Fortran module f90VBGUIUtils with new function CmainEventsHandler (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

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 16