program main
use dfwin
use dfcom
use dfauto
use surfer
integer, parameter :: k_obj = int_ptr_kind()
integer(k_obj) app, docs, plot, shapes, status, ptr, str
common app, docs, plot, shapes, status, str
call cominitialize(status)
call initobjects()
call comcreateobject("Surfer.Application", app, status)
call checkstatus(" Unable to create Surfer object")
status = autosetproperty(app, "Visible", .true.)
! ptr = iaddr(docs)
status = $IApplication_GetDocuments(app, docs)
call checkstatus(" Unable to get documents object")
plot = $IDocuments_Add(docs, srfDocPlot, status)
call checkstatus(" Unable to create a new Surfer document")
shapes = $IPlotDocument_GetShapes(plot, status)
call checkstatus(" Unable to get Shapes interface")
! str = StringToBSTR("c:\\program files\\golden software\\surfer 10\\samples\\helens2.grd")
rmap = $IShapes_AddReliefMap(shapes, "c:\\program files\\golden software\\surfer 10\\samples\\helens2.grd"C, status)
call checkstatus("Unable to add relief map object")
call freeobjects()
call comuninitialize()
end program
INTEGER(INT_PTR_KIND()) FUNCTION StringToBSTR(string)
USE OLEAUT32
USE IFNLS
CHARACTER*(*), INTENT(IN) :: string
INTEGER(INT_PTR_KIND()) bstr
INTEGER*4 length
INTEGER*2, ALLOCATABLE :: unistr(:)
! First call to MBConvertMBToUnicode determines the length to allocate
ALLOCATE (unistr(0))
length = MBConvertMBToUnicode(string, unistr)
DEALLOCATE (unistr)
! Special case for all spaces
IF (length < 0) THEN
ALLOCATE (unistr(2))
unistr(1) = #20 ! Single space
unistr(2) = 0 ! Null terminate
ELSE
! Second call to MBConvertMBToUnicode does the conversion
ALLOCATE (unistr(length+1))
length = MBConvertMBToUnicode(string, unistr)
unistr(length+1) = 0 ! Null terminate
END IF
bstr = SysAllocString(unistr)
DEALLOCATE (unistr)
StringToBSTR = bstr
END FUNCTION StringToBSTR
subroutine initobjects()
use dfwin
use dfcom
use dfauto
use surfer
integer, parameter :: k_obj = int_ptr_kind()
integer(k_obj) app, docs, plot, shapes, rmap, status, str
common app, docs, plot, shapes, rmap, status, str
app = 0
docs = 0
plot = 0
shapes = 0
rmap = 0
str = 0
end subroutine
subroutine freeobjects()
use dfwin
use dfcom
use dfauto
use surfer
integer, parameter :: k_obj = int_ptr_kind()
integer(k_obj) app, docs, plot, shapes, rmap, status, str
common app, docs, plot, shapes, rmap, status, str
if (str /= 0) call SysFreeString(str)
if (rmap /= 0) status = comreleaseobject(rmap)
if (shapes /= 0) status = comreleaseobject(shapes)
if (plot /= 0) status = comreleaseobject(plot)
if (docs /= 0) status = comreleaseobject(docs)
if (app /= 0) status = comreleaseobject(app)
end subroutine
subroutine checkstatus(message)
use dfwin
use dfcom
use dfauto
use surfer
integer, parameter :: k_obj = int_ptr_kind()
character(*) message
integer(k_obj) status
common status
if (status >= 0) then
return
end if
write (*, '(A, "; OLE error status = 0x", Z8.8, "; Aborting")') trim(message), status
call freeobjects()
call sleepqq(5000)
call exit(-1)
end subroutine
|
