Sample Code 9

Fortran module f90VBGUIUtils with new subroutine GetInputValue (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

contains

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 10