Print a BMP-file using Intel Fortran

Print a BMP-file using Intel Fortran

Hello

I have tried to print a BMP-file on printer using DrawIconEx , without any success.
The source code has the following style.

USE IFWIN
ICON = LoadImage( 0, 'RP.BMP'C, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE )
ires = DrawIconEx( ihDC, 10, 10, ICON, 0, 0, 0, NULL, DI_NORMAL )

The return value from DrawIconEx is zero and nothing is printed.

Does anyone have ideas how to solve this problem?

Hkan

16 posts / 0 new
Last post
For more complete information about compiler optimizations, see our Optimization Notice.

Ok, so where is all the code where you generate a handle to a printer device context (which has to go in place of your 'ihDC')? Is ihDC a handle to a valid device context? Because that is where the 'drawing' takes place.
Where is the code for Initialising a PrintDialog structure? e.g.

!
! Print Dialog stuff...
!
integer*4 :: hDCPrn ! Handle for printer DC.
integer*4 :: cxPage, cyPage ! Size of page printed area.
integer*4 :: cPage ! minimum dimension of page.
real*8 :: pwfract ! Fraction of page width to use for printed image
character*40 :: DocName
type (T_DOCINFO) :: di ! DOCINFO structure.
type (T_PRINTDLG) :: pd ! Print Dialog structure
!***************************************************************************
.....
....
! Initialise PRINTDLG structure.
!
pd.lStructSize = SIZEOF(pd)
pd.hwndOwner = hWnd
pd.Flags = PD_RETURNDC .OR. PD_NOPAGENUMS .OR. &
PD_NOSELECTION .OR. PD_PRINTSETUP
pd.nFromPage = 1 ! not appear.
pd.nToPage = 1
pd.nMinPage = 1
pd.nMaxPage = 1
pd.nCopies = 1
pd.hInstance = NULL
pd.lpfnSetupHook = NULL
pd.lpSetupTemplateName = NULL
pd.lpfnPrintHook = NULL
pd.lpPrintTemplateName = NULL

retlog=PrintDlg(pd)
!
! Get handle to the device context for PRINTDLG Structure.
!
hdcPrn = pd.hDC

ihoriz=GetDeviceCaps(pD%hDc, PHYSICALWIDTH)
ivert=GetDeviceCaps(pD%hDc, PHYSICALHEIGHT)

!***********************************************************************************
!
! Set DocInfo data.
!
DocName = 'Your title here'C
di.cbSize = sizeof(di)
di.lpszDocName = loc(DocName)
di.lpszOutput = NULL
di.lpszDatatype = NULL
di.fwType = NULL
!
! Get size of printable area of page.
!
cxPage = GetDeviceCaps(hdcPrn, HORZRES)
cyPage = GetDeviceCaps(hdcPrn, VERTRES)
!
! select a fraction of the minimum page dimension to
! which the plot will be scaled.., default this to 3/4
pwfract=0.75
cpage=min(cxpage, cypage)*pwfract
!***********************************************************************************
!
! Prepare to plot to the printer.
!
retint = StartDoc(hdcPrn, di)
retint = StartPage(hdcPrn)
!
retint=SetMapMode(hdcPrn, MM_TEXT)
!
retlog=SetViewPortExtEx(hdcPrn,ihoriz, ivert, PXY)
!***********************************************************************************

[add your drawing code here to drawon hdcPrn]
...
retint = EndPage(hDCPrn)
retint = EndDoc(hDCprn)
! Release the printer resources
retlog = DeleteDC(hDCprn)

Thanks for the reply, but I have still problem with DrawIconEx. The attached program gives the following response.

ICON = -1778055127

ires = 0

Any ideas?

/Hkan

program PrintImage

USE gdi32
USE comdlg32
USE IFWIN
CC USE IFQWIN

integer*4 :: hDCPrn ! Handle for printer DC.
integer*4 :: cxPage, cyPage ! Size of page printed area.
integer*4 :: cPage ! minimum dimension of page.
real*8 :: pwfract ! Fraction of page width to use for printed image
character*40 :: DocName
type (T_DOCINFO) :: di ! DOCINFO structure.
type (T_PRINTDLG) :: pd ! Print Dialog structure
!***************************************************************************

! Initialise PRINTDLG structure.

pd.lStructSize = SIZEOF(pd)
pd.hwndOwner = hWnd
pd.Flags = PD_RETURNDC .OR. PD_NOPAGENUMS.OR.PD_NOSELECTION .OR. PD_PRINTSETUP
pd.nFromPage = 1 ! not appear.
pd.nToPage = 1
pd.nMinPage = 1
pd.nMaxPage = 1
pd.nCopies = 1
pd.hInstance = NULL
pd.lpfnSetupHook = NULL
pd.lpSetupTemplateName = NULL
pd.lpfnPrintHook = NULL
pd.lpPrintTemplateName = NULL

retlog=PrintDlg(pd)
!
! Get handle to the device context for PRINTDLG Structure.
!
hdcPrn = pd.hDC

ihoriz=GetDeviceCaps(pD%hDc, PHYSICALWIDTH)
ivert=GetDeviceCaps(pD%hDc, PHYSICALHEIGHT)

!***********************************************************************************
!
! Set DocInfo data.
!
DocName = 'Your title here'C
di.cbSize = sizeof(di)
di.lpszDocName = loc(DocName)
di.lpszOutput = NULL
di.lpszDatatype = NULL
di.fwType = NULL
!
! Get size of printable area of page.
!
cxPage = GetDeviceCaps(hdcPrn, HORZRES)
cyPage = GetDeviceCaps(hdcPrn, VERTRES)
!
! select a fraction of the minimum page dimension to
! which the plot will be scaled.., default this to 3/4
pwfract=0.75
cpage=min(cxpage, cypage)*pwfract
!***********************************************************************************
!
! Prepare to plot to the printer.
!
retint = StartDoc(hdcPrn, di)
retint = StartPage(hdcPrn)
!
retint=SetMapMode(hdcPrn, MM_TEXT)
!
retlog=SetViewPortExtEx(hdcPrn,ihoriz, ivert, NULL)

!***********************************************************************************

ICON = LoadImage( NULL, 'HELLO.BMP'C, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE )
write(*,*) ' ICON = ',ICON

ires = DrawIconEx( hdcPrn, 10, 10, ICON, 0, 0, 0, NULL, DI_NORMAL )
write(*,*) ' ires = ',ires

retint = EndPage(hDCPrn)
retint = EndDoc(hDCprn)
! Release the printer resources
retlog = DeleteDC(hDCprn)

end

I tried converting your code to gfortran because you had some declarations that were not 64-bit safe and also an assumption throughout of initialization to zero. It should still compile in ifort, however:

!DEC$ IF(.FALSE.)

module gdi32

   use ISO_C_BINDING

   implicit none

   private

   public GetDeviceCaps

   interface

      function GetDeviceCaps(hdc, nIndex) bind(C,name='GetDeviceCaps')

         import

         implicit none

!gcc$ attributes STDCALL :: GetDeviceCaps

         integer(C_INT) GetDeviceCaps

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: nIndex

      end function GetDeviceCaps

   end interface

   integer(C_INT), parameter, public :: PHYSICALWIDTH = 110

   integer(C_INT), parameter, public :: PHYSICALHEIGHT = 111

   integer(C_INT), parameter, public :: HORZRES = 8

   integer(C_INT), parameter, public :: VERTRES = 10

   type, public, bind(C) :: T_DOCINFO

      integer(C_INT) cbSize

      type(C_PTR) lpszDocName

      type(C_PTR) lpszOutput

      type(C_PTR) lpszDatatype

      integer(C_INT32_T) fwType

   end type T_DOCINFO

   public StartDoc

   interface

      function StartDoc(hdc, lpdi) bind(C,name='StartDocA')

         import

         implicit none

!gcc$ attributes stdcall :: StartDoc

         integer(C_INT) StartDoc

         integer(C_INTPTR_T), value :: hdc

         type(T_DOCINFO) lpdi

      end function StartDoc

   end interface

   public StartPage

   interface

      function StartPage(HDC) bind(C,name='StartPage')

         import

         implicit none

!gcc$ attributes stdcall :: StartPage

         integer(C_INT) StartPage

         integer(C_INTPTR_T), value :: HDC

      end function StartPage

   end interface

   public SetMapMode

   interface

      function SetMapMode(hdc, fnMapMode) bind(C,name='SetMapMode')

         import

         implicit none

!gcc& attributes stdcall :: SetMapMode

         integer(C_INT) SetMapMode

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: fnMapMode

      end function SetMapMode

   end interface

   integer(C_INT), parameter, public :: MM_TEXT = 1

   type, public, bind(C) :: T_SIZE

      integer(C_LONG) cx

      integer(C_LONG) cy

   end type T_SIZE

   public SetViewportExtEx

   interface

      function SetViewportExtEx(hdc, nXExtent, nYExtent, &

         lpSize) bind(C,name='SetViewportExtEx')

         import

         implicit none

!gcc$ attributes stdcall :: SetViewportExtEx

         integer(C_INT) SetViewportExtEx

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: nXExtent

         integer(C_INT), value :: nYExtent

         type(T_SIZE) lpSize

      end function SetViewportExtEx

   end interface

   public EndPage

   interface

      function EndPage(hdc) bind(C,name='EndPage')

         import

         implicit none

!gcc$ attributes stdcall :: EndPage

         integer(C_INT) EndPage

         integer(C_INTPTR_T), value :: hdc

      end function EndPage

   end interface

   public EndDoc

   interface

      function EndDoc(hdc) bind(C,name='EndDoc')

         import

         implicit none

!gcc$ attributes stdcall :: EndDoc

         integer(C_INT) EndDoc

         integer(C_INTPTR_T), value :: hdc

      end function EndDoc

   end interface

   public DeleteDC

   interface

      function DeleteDC(hdc) bind(C,name='DeleteDC')

         import

         implicit none

!gcc$ attributes stdcall :: DeleteDC

         integer(C_INT) DeleteDC

         integer(C_INTPTR_T), value :: hdc

      end function DeleteDC

   end interface

   public DeleteObject

   interface

      function DeleteObject(hObject) bind(C,name='DeleteObject')

         import

         implicit none

!gcc$ attributes stdcall :: DeleteObject

         integer(C_INT) DeleteObject

         integer(C_INTPTR_T), value :: hObject

      end function DeleteObject

   end interface

end module gdi32
module IFWIN

   use ISO_C_BINDING

   implicit none

   private

   public LoadImage

   interface

      function LoadImage(hinst, lpszName, uType, &

         cxDesired, cyDesired, fuLoad) bind(C,name='LoadImageA')

         import

         implicit none

!gcc$ attributes stdcall :: LoadImage

         integer(C_INTPTR_T) LoadImage

         integer(C_INTPTR_T), value :: hinst

         character(kind=C_CHAR) :: lpszName(*)

         integer(C_INT), value :: uType

         integer(C_INT), value :: cxDesired

         integer(C_INT), value :: cyDesired

         integer(C_INT), value :: fuLoad

      end function LoadImage

   end interface

   integer(C_INT), parameter, public :: IMAGE_BITMAP = 0

   integer(C_INT), parameter, public :: LR_LOADFROMFILE = int(Z'00000010',C_INT)

   public DrawIconEx

   interface

      function DrawIconEx(hdc, xLeft, yTop, hIcon, cxWidth, &

         cyWidth, istepIfAniCur, hbrFlickerFreeDraw, &

         diFlags) bind(C, name='DrawIconEx')

         import

         implicit none

!gcc& attributes stdcall :: DrawIconEx

         integer(C_INT) DrawIconEx

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: xLeft

         integer(C_INT), value :: yTop

         integer(C_INTPTR_T), value :: hIcon

         integer(C_INT), value :: cxWidth

         integer(C_INT), value :: cyWidth

         integer(C_INT), value :: istepIfAniCur

         integer(C_INTPTR_T), value :: hbrFlickerFreeDraw

         integer(C_INT), value :: diFlags

      end function DrawIconEx

   end interface

   integer(C_INT), parameter, public :: DI_IMAGE = int(Z'0002',C_INT)

   integer(C_INT), parameter, public :: DI_NORMAL = int(Z'0003',C_INT)

   integer(C_INT), parameter, public :: DI_DEFAULTSIZE = int(Z'0008',C_INT)

   public GetLastError

   interface

      function GetLastError() bind(C,name='GetLastError')

         import

         implicit none

!gcc$ attributes STDCALL :: GetLastError

         integer(C_INT32_T) GetLastError

      end function GetLastError

   end interface

   type, public, bind(C) :: T_POINT

      integer(C_LONG) x

      integer(C_LONG) y

   end type T_POINT

   public MoveToEx

   interface

      function MoveToEx(hdc, X, Y, lpPoint) bind(C,name='MoveToEx')

         import

         implicit none

!gcc$ attributes stdcall :: MoveToEx

         integer(C_INT) MoveToEx

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: X

         integer(C_INT), value :: Y

         type(T_POINT) lpPoint

      end function MoveToEx

   end interface

   public LineTo

   interface

      function LineTo(hdc, X, Y) bind(C,name='LineTo')

         import

         implicit none

!gcc$ attributes stdcall :: LineTo

         integer(C_INT) LineTo

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: X

         integer(C_INT), value :: Y

      end function LineTo

   end interface

end module IFWIN
module comdlg32

   use ISO_C_BINDING

   implicit none

   private

   type, public, bind(C) :: T_PRINTDLG

      integer(C_INT32_T) lStructSize

      integer(C_INTPTR_T) hwndOwner

      integer(C_INTPTR_T) hDevMode

      integer(C_INTPTR_T) hDevNames

      integer(C_INTPTR_T) hDC

      integer(C_INT32_T) Flags

      integer(C_INT16_T) nFromPage

      integer(C_INT16_T) nToPage

      integer(C_INT16_T) nMinPage

      integer(C_INT16_T) nMaxPage

      integer(C_INT16_T) nCopies

      integer(C_INTPTR_T) hInstance

      integer(C_INTPTR_T) lCustData

      type(C_FUNPTR) lpfnPrintHook

      type(C_FUNPTR) lpfnSetupHook

      type(C_PTR) lpPrintTemplateName

      type(C_PTR) lpSetupTemplateName

      integer(C_INTPTR_T) hPrintTemplate

      integer(C_INTPTR_T) hSetupTemplate

   end type T_PRINTDLG

   public PrintDlg

   interface

      function PrintDlg(lppd) bind(C,name='PrintDlgA')

         import

         implicit none

!gcc$ attributes STDCALL :: PrintDlg

         integer(C_INT) PrintDlg

         type(T_PRINTDLG) lppd

      end function PrintDlg

   end interface

   integer(C_INT32_T), parameter, public :: PD_RETURNDC = int(Z'00000100',C_INT32_T)

   integer(C_INT32_T), parameter, public :: PD_NOPAGENUMS = int(Z'00000002',C_INT32_T)

   integer(C_INT32_T), parameter, public :: PD_NOSELECTION = int(Z'00000004',C_INT32_T)

   integer(C_INT32_T), parameter, public :: PD_PRINTSETUP = int(Z'00000040',C_INT32_T)

end module comdlg32
!DEC$ ENDIF

program PrintImage

   use ISO_C_BINDING
   USE gdi32

   USE comdlg32

   USE IFWIN

!CC       USE IFQWIN
   implicit none

   integer(C_INT) retlog

   integer(C_INT) retint

   integer(C_INT) ires

   integer(C_INTPTR_T) :: hDCPrn       ! Handle for printer DC.

   integer(C_INT) ihoriz, ivert

   character(40,C_CHAR), target ::    DocName

   integer(C_INT)     ::    cxPage,     cyPage  ! Size of page printed area.

   integer(C_INT)     ::    cPage      ! minimum dimension of page.

   real(C_DOUBLE)     ::    pwfract    ! Fraction of page width to use for printed image

   type(T_DOCINFO)     ::    di        ! DOCINFO structure.

   type(T_PRINTDLG)    ::    pd        ! Print Dialog structure

   type(T_SIZE) :: ps

   type(T_POINT) :: pt

   integer(C_INTPTR_T) ICON

!***************************************************************************
! Initialise PRINTDLG structure.
   pd = T_PRINTDLG( &

      lStructSize = C_SIZEOF(pd), &

      hwndOwner = 0, &

      hDevMode = 0, &

      hDevNames = 0, &

      hDC = 0, &

      Flags = iany([PD_RETURNDC,PD_NOPAGENUMS, &

         PD_NOSELECTION,PD_PRINTSETUP]), &

      nFromPage = 1, &

      nToPage = 1, &

      nMinPage = 1, &

      nMaxPage = 1, &

      nCopies = 1, &

      hInstance = 0, &

      lCustData = 0, &

      lpfnPrintHook = C_NULL_FUNPTR, &

      lpfnSetupHook = C_NULL_FUNPTR, &

      lpPrintTemplateName = C_NULL_PTR, &

      lpSetupTemplateName = C_NULL_PTR, &

      hPrintTemplate = 0, &

      hSetupTemplate = 0)
   retlog=PrintDlg(pd)

write(*,*) 'retlog=',retlog

!

! Get handle to the device context for PRINTDLG Structure.

!

   hdcPrn = pd%hDC

write(*,*) 'hdcPrn=',hdcPrn
   ihoriz=GetDeviceCaps(pD%hDc, PHYSICALWIDTH)

write(*,*) 'ihoriz=',ihoriz

   ivert=GetDeviceCaps(pD%hDc, PHYSICALHEIGHT)

write(*,*) 'ivert=',ivert
!***********************************************************************************

!

! Set DocInfo data.

!

   DocName         = 'Your title here'//achar(0)

   di = T_DOCINFO( &

      cbSize       = C_SIZEOF(di), &

      lpszDocName  = C_LOC(DocName(1:1)), &

      lpszOutput   = C_NULL_PTR, &

      lpszDatatype = C_NULL_PTR, &

      fwType       = 0)

!

! Get size of printable area of page.

!

   cxPage = GetDeviceCaps(hdcPrn, HORZRES)

write(*,*) 'cxpage=',cxpage

   cyPage = GetDeviceCaps(hdcPrn, VERTRES)

write(*,*) 'cypage=',cypage

!

! select a fraction of the minimum page dimension to

! which the plot will be scaled.., default this to 3/4

   pwfract=0.75

   cpage=min(cxpage, cypage)*pwfract

write(*,*) 'cpage=',cpage

!***********************************************************************************

!

! Prepare to plot to the printer.

!

   retint  = StartDoc(hdcPrn, di)

write(*,*) 'retint=',retint

   retint  = StartPage(hdcPrn)

write(*,*) 'retint=',retint

!

   retint=SetMapMode(hdcPrn, MM_TEXT)

write(*,*) 'retint=',retint

!

! Should be ignored because MapMode = MM_TEXT

   retlog=SetViewPortExtEx(hdcPrn,ihoriz, ivert, ps)

write(*,*) 'retlog=',retlog
!***********************************************************************************
   ICON = LoadImage(0_C_INTPTR_T, 'HELLO.BMP'//achar(0), IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)

   write(*,*) ' ICON = ',ICON

   write(*,'(a,z0)') ' ICON = ',ICON
!   ires = DrawIconEx(hdcPrn, 10, 10, ICON, 0, 0, 0, 0_C_INTPTR_T, DI_NORMAL)

!   ires = DrawIconEx(hdcPrn, 10, 10, ICON, 0, 0, 0, 0_C_INTPTR_T, DI_IMAGE)

   ires = DrawIconEx(hdcPrn, 10, 10, ICON, 0, 0, 0, 0_C_INTPTR_T, iany([DI_DEFAULTSIZE,DI_NORMAL]))

   write(*,*) ' ires = ',ires

   ires = GetLastError()

   write(*,*) ' ires = ',ires

   ires = DeleteObject(ICON)

   write(*,*) ' ires = ',ires
   ires = MoveToEx(hdcPrn, cPage, cPage, pt)

   write(*,*) ' ires = ',ires

   ires = LineTo(hdcPrn, 0, 0)

   write(*,*) ' ires = ',ires
   retint = EndPage(hDCPrn)

write(*,*) 'retint=',retint

   retint = EndDoc(hDCprn)

write(*,*) 'retint=',retint

! Release the printer resources

   retlog = DeleteDC(hDCprn)

write(*,*) 'retlog=',retlog
end program PrintImage


The output was:
 retlog=           1

 hdcPrn=             35721141

 ihoriz=        5100

 ivert=        6600

 cxpage=        4900

 cypage=        6400

 cpage=        3675

 retint=          16

 retint=           1

 retint=           1

 retlog=           1

  ICON =           -2080043277

 ICON = FFFFFFFF84050EF3

  ires =            0

  ires =         1402

  ires =            1

  ires =            1

  ires =            1

 retint=           1

 retint=           1

 retlog=           1

The MoveToEx/LineTo sequence succeeded in printing out a diagonal line, but I still got a 1402 (ERROR_INVALID_CURSOR_HANDLE) from DrawIconEx. So at least the hdcPrn is working correctly, but I can't tell you why DrawIconEx fails.

OK, I copied an example from Petzold and got the bitmap to print. It comes out really tiny so maybe StretchBlt would have been more appropriate, but at least it isn't the white page of death.

!DEC$ IF(.FALSE.)

module gdi32

   use ISO_C_BINDING

   implicit none

   private

   public GetDeviceCaps

   interface

      function GetDeviceCaps(hdc, nIndex) bind(C,name='GetDeviceCaps')

         import

         implicit none

!gcc$ attributes STDCALL :: GetDeviceCaps

         integer(C_INT) GetDeviceCaps

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: nIndex

      end function GetDeviceCaps

   end interface

   integer(C_INT), parameter, public :: PHYSICALWIDTH = 110

   integer(C_INT), parameter, public :: PHYSICALHEIGHT = 111

   integer(C_INT), parameter, public :: HORZRES = 8

   integer(C_INT), parameter, public :: VERTRES = 10

   type, public, bind(C) :: T_DOCINFO

      integer(C_INT) cbSize

      type(C_PTR) lpszDocName

      type(C_PTR) lpszOutput

      type(C_PTR) lpszDatatype

      integer(C_INT32_T) fwType

   end type T_DOCINFO

   public StartDoc

   interface

      function StartDoc(hdc, lpdi) bind(C,name='StartDocA')

         import

         implicit none

!gcc$ attributes stdcall :: StartDoc

         integer(C_INT) StartDoc

         integer(C_INTPTR_T), value :: hdc

         type(T_DOCINFO) lpdi

      end function StartDoc

   end interface

   public StartPage

   interface

      function StartPage(HDC) bind(C,name='StartPage')

         import

         implicit none

!gcc$ attributes stdcall :: StartPage

         integer(C_INT) StartPage

         integer(C_INTPTR_T), value :: HDC

      end function StartPage

   end interface

   public SetMapMode

   interface

      function SetMapMode(hdc, fnMapMode) bind(C,name='SetMapMode')

         import

         implicit none

!gcc& attributes stdcall :: SetMapMode

         integer(C_INT) SetMapMode

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: fnMapMode

      end function SetMapMode

   end interface

   integer(C_INT), parameter, public :: MM_TEXT = 1

   type, public, bind(C) :: T_SIZE

      integer(C_LONG) cx

      integer(C_LONG) cy

   end type T_SIZE

   public SetViewportExtEx

   interface

      function SetViewportExtEx(hdc, nXExtent, nYExtent, &

         lpSize) bind(C,name='SetViewportExtEx')

         import

         implicit none

!gcc$ attributes stdcall :: SetViewportExtEx

         integer(C_INT) SetViewportExtEx

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: nXExtent

         integer(C_INT), value :: nYExtent

         type(T_SIZE) lpSize

      end function SetViewportExtEx

   end interface

   public EndPage

   interface

      function EndPage(hdc) bind(C,name='EndPage')

         import

         implicit none

!gcc$ attributes stdcall :: EndPage

         integer(C_INT) EndPage

         integer(C_INTPTR_T), value :: hdc

      end function EndPage

   end interface

   public EndDoc

   interface

      function EndDoc(hdc) bind(C,name='EndDoc')

         import

         implicit none

!gcc$ attributes stdcall :: EndDoc

         integer(C_INT) EndDoc

         integer(C_INTPTR_T), value :: hdc

      end function EndDoc

   end interface

   public DeleteDC

   interface

      function DeleteDC(hdc) bind(C,name='DeleteDC')

         import

         implicit none

!gcc$ attributes stdcall :: DeleteDC

         integer(C_INT) DeleteDC

         integer(C_INTPTR_T), value :: hdc

      end function DeleteDC

   end interface

   public DeleteObject

   interface

      function DeleteObject(hObject) bind(C,name='DeleteObject')

         import

         implicit none

!gcc$ attributes stdcall :: DeleteObject

         integer(C_INT) DeleteObject

         integer(C_INTPTR_T), value :: hObject

      end function DeleteObject

   end interface

   type, public, bind(C) :: T_BITMAP

      integer(C_LONG) bmType

      integer(C_LONG) bmWidth

      integer(C_LONG) bmHeight

      integer(C_LONG) bmWidthBytes

      integer(C_INT16_T) bmPlanes

      integer(C_INT16_T) bmBitsPixel

      type(C_PTR) bmBits

   end type T_BITMAP

   public GetObject

   interface

      function GetObject(hgdiobj, cbBuffer, lpvObject) bind(C,name='GetObjectA')

         import

         implicit none

!gcc$ attributes stdcall :: GetObject

         integer(C_INT) GetObject

         integer(C_INTPTR_T), value :: hgdiobj

         integer(C_INT), value :: cbBuffer

         type(C_PTR), value :: lpvObject

      end function GetObject

   end interface

   public CreateCompatibleDC

   interface

      function CreateCompatibleDC(hdc) bind(C,name='CreateCompatibleDC')

         import

         implicit none

!gcc$ attributes stdcall :: CreateCompatibleDC

         integer(C_INTPTR_T) CreateCompatibleDC

         integer(C_INTPTR_T), value :: hdc

      end function CreateCompatibleDC

   end interface

   public SelectObject

   interface

      function SelectObject(hdc, hgdiobj) bind(C,name='SelectObject')

         import

         implicit none

!gcc$ attributes stdcall :: SelectObject

         integer(C_INTPTR_T) SelectObject

         integer(C_INTPTR_T), value :: hdc

         integer(C_INTPTR_T), value :: hgdiobj

      end function SelectObject

   end interface

   public BitBlt

   interface

      function BitBlt(hdcDest, nXDest, nYDest, nWidth, nHeight, &

         hdcSrc, nXSrc, nYSrc, dwRop) bind(C,name='BitBlt')

         import

         implicit none

!gcc$ attributes stdcall :: BitBlt

         integer(C_INT) BitBlt

         integer(C_INTPTR_T), value :: hdcDest

         integer(C_INT), value :: nXDest

         integer(C_INT), value :: nYDest

         integer(C_INT), value :: nwidth

         integer(C_INT), value :: nHeight

         integer(C_INTPTR_T), value :: hdcSrc

         integer(C_INT), value :: nXSrc

         integer(C_INT), value :: nYSrc

         integer(C_INT32_T), value :: dwRop

      end function BitBlt

   end interface

   integer(C_INT32_T), parameter, public :: SRCCOPY = int(Z'00CC0020',C_INT32_T)

end module gdi32
module IFWIN

   use ISO_C_BINDING

   implicit none

   private

   public LoadImage

   interface

      function LoadImage(hinst, lpszName, uType, &

         cxDesired, cyDesired, fuLoad) bind(C,name='LoadImageA')

         import

         implicit none

!gcc$ attributes stdcall :: LoadImage

         integer(C_INTPTR_T) LoadImage

         integer(C_INTPTR_T), value :: hinst

         character(kind=C_CHAR) :: lpszName(*)

         integer(C_INT), value :: uType

         integer(C_INT), value :: cxDesired

         integer(C_INT), value :: cyDesired

         integer(C_INT), value :: fuLoad

      end function LoadImage

   end interface

   integer(C_INT), parameter, public :: IMAGE_BITMAP = 0

   integer(C_INT), parameter, public :: LR_CREATEDIBSECTION = int(Z'00002000',C_INT)

   integer(C_INT), parameter, public :: LR_LOADFROMFILE = int(Z'00000010',C_INT)

   public DrawIconEx

   interface

      function DrawIconEx(hdc, xLeft, yTop, hIcon, cxWidth, &

         cyWidth, istepIfAniCur, hbrFlickerFreeDraw, &

         diFlags) bind(C, name='DrawIconEx')

         import

         implicit none

!gcc& attributes stdcall :: DrawIconEx

         integer(C_INT) DrawIconEx

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: xLeft

         integer(C_INT), value :: yTop

         integer(C_INTPTR_T), value :: hIcon

         integer(C_INT), value :: cxWidth

         integer(C_INT), value :: cyWidth

         integer(C_INT), value :: istepIfAniCur

         integer(C_INTPTR_T), value :: hbrFlickerFreeDraw

         integer(C_INT), value :: diFlags

      end function DrawIconEx

   end interface

   integer(C_INT), parameter, public :: DI_IMAGE = int(Z'0002',C_INT)

   integer(C_INT), parameter, public :: DI_NORMAL = int(Z'0003',C_INT)

   integer(C_INT), parameter, public :: DI_DEFAULTSIZE = int(Z'0008',C_INT)

   public GetLastError

   interface

      function GetLastError() bind(C,name='GetLastError')

         import

         implicit none

!gcc$ attributes STDCALL :: GetLastError

         integer(C_INT32_T) GetLastError

      end function GetLastError

   end interface

   type, public, bind(C) :: T_POINT

      integer(C_LONG) x

      integer(C_LONG) y

   end type T_POINT

   public MoveToEx

   interface

      function MoveToEx(hdc, X, Y, lpPoint) bind(C,name='MoveToEx')

         import

         implicit none

!gcc$ attributes stdcall :: MoveToEx

         integer(C_INT) MoveToEx

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: X

         integer(C_INT), value :: Y

         type(T_POINT) lpPoint

      end function MoveToEx

   end interface

   public LineTo

   interface

      function LineTo(hdc, X, Y) bind(C,name='LineTo')

         import

         implicit none

!gcc$ attributes stdcall :: LineTo

         integer(C_INT) LineTo

         integer(C_INTPTR_T), value :: hdc

         integer(C_INT), value :: X

         integer(C_INT), value :: Y

      end function LineTo

   end interface

end module IFWIN
module comdlg32

   use ISO_C_BINDING

   implicit none

   private

   type, public, bind(C) :: T_PRINTDLG

      integer(C_INT32_T) lStructSize

      integer(C_INTPTR_T) hwndOwner

      integer(C_INTPTR_T) hDevMode

      integer(C_INTPTR_T) hDevNames

      integer(C_INTPTR_T) hDC

      integer(C_INT32_T) Flags

      integer(C_INT16_T) nFromPage

      integer(C_INT16_T) nToPage

      integer(C_INT16_T) nMinPage

      integer(C_INT16_T) nMaxPage

      integer(C_INT16_T) nCopies

      integer(C_INTPTR_T) hInstance

      integer(C_INTPTR_T) lCustData

      type(C_FUNPTR) lpfnPrintHook

      type(C_FUNPTR) lpfnSetupHook

      type(C_PTR) lpPrintTemplateName

      type(C_PTR) lpSetupTemplateName

      integer(C_INTPTR_T) hPrintTemplate

      integer(C_INTPTR_T) hSetupTemplate

   end type T_PRINTDLG

   public PrintDlg

   interface

      function PrintDlg(lppd) bind(C,name='PrintDlgA')

         import

         implicit none

!gcc$ attributes STDCALL :: PrintDlg

         integer(C_INT) PrintDlg

         type(T_PRINTDLG) lppd

      end function PrintDlg

   end interface

   integer(C_INT32_T), parameter, public :: PD_RETURNDC = int(Z'00000100',C_INT32_T)

   integer(C_INT32_T), parameter, public :: PD_NOPAGENUMS = int(Z'00000002',C_INT32_T)

   integer(C_INT32_T), parameter, public :: PD_NOSELECTION = int(Z'00000004',C_INT32_T)

   integer(C_INT32_T), parameter, public :: PD_PRINTSETUP = int(Z'00000040',C_INT32_T)

end module comdlg32
!DEC$ ENDIF

program PrintImage

   use ISO_C_BINDING
   USE gdi32

   USE comdlg32

   USE IFWIN

!CC       USE IFQWIN
   implicit none

   integer(C_INT) retlog

   integer(C_INT) retint

   integer(C_INT) ires

   integer(C_INTPTR_T) :: hDCPrn       ! Handle for printer DC.

   integer(C_INT) ihoriz, ivert

   character(40,C_CHAR), target ::    DocName

   integer(C_INT)     ::    cxPage,     cyPage  ! Size of page printed area.

   integer(C_INT)     ::    cPage      ! minimum dimension of page.

   real(C_DOUBLE)     ::    pwfract    ! Fraction of page width to use for printed image

   type(T_DOCINFO)     ::    di        ! DOCINFO structure.

   type(T_PRINTDLG)    ::    pd        ! Print Dialog structure

   type(T_SIZE) :: ps

   type(T_POINT) :: pt

   integer(C_INTPTR_T) ICON

   type(T_BITMAP), target :: bmp

   integer(C_INTPTR_T) hdcMem

   integer(C_INTPTR_T) old_hgdi

!***************************************************************************
! Initialise PRINTDLG structure.
   pd = T_PRINTDLG( &

      lStructSize = C_SIZEOF(pd), &

      hwndOwner = 0, &

      hDevMode = 0, &

      hDevNames = 0, &

      hDC = 0, &

      Flags = iany([PD_RETURNDC,PD_NOPAGENUMS, &

         PD_NOSELECTION,PD_PRINTSETUP]), &

      nFromPage = 1, &

      nToPage = 1, &

      nMinPage = 1, &

      nMaxPage = 1, &

      nCopies = 1, &

      hInstance = 0, &

      lCustData = 0, &

      lpfnPrintHook = C_NULL_FUNPTR, &

      lpfnSetupHook = C_NULL_FUNPTR, &

      lpPrintTemplateName = C_NULL_PTR, &

      lpSetupTemplateName = C_NULL_PTR, &

      hPrintTemplate = 0, &

      hSetupTemplate = 0)
   retlog=PrintDlg(pd)

write(*,*) 'retlog=',retlog

!

! Get handle to the device context for PRINTDLG Structure.

!

   hdcPrn = pd%hDC

write(*,*) 'hdcPrn=',hdcPrn
   ihoriz=GetDeviceCaps(pD%hDc, PHYSICALWIDTH)

write(*,*) 'ihoriz=',ihoriz

   ivert=GetDeviceCaps(pD%hDc, PHYSICALHEIGHT)

write(*,*) 'ivert=',ivert
!***********************************************************************************

!

! Set DocInfo data.

!

   DocName         = 'Your title here'//achar(0)

   di = T_DOCINFO( &

      cbSize       = C_SIZEOF(di), &

      lpszDocName  = C_LOC(DocName(1:1)), &

      lpszOutput   = C_NULL_PTR, &

      lpszDatatype = C_NULL_PTR, &

      fwType       = 0)

!

! Get size of printable area of page.

!

   cxPage = GetDeviceCaps(hdcPrn, HORZRES)

write(*,*) 'cxpage=',cxpage

   cyPage = GetDeviceCaps(hdcPrn, VERTRES)

write(*,*) 'cypage=',cypage

!

! select a fraction of the minimum page dimension to

! which the plot will be scaled.., default this to 3/4

   pwfract=0.75

   cpage=min(cxpage, cypage)*pwfract

write(*,*) 'cpage=',cpage

!***********************************************************************************

!

! Prepare to plot to the printer.

!

   retint  = StartDoc(hdcPrn, di)

write(*,*) 'retint=',retint

   retint  = StartPage(hdcPrn)

write(*,*) 'retint=',retint

!

   retint=SetMapMode(hdcPrn, MM_TEXT)

write(*,*) 'retint=',retint

!

! Should be ignored because MapMode = MM_TEXT

   retlog=SetViewPortExtEx(hdcPrn,ihoriz, ivert, ps)

write(*,*) 'retlog=',retlog
!***********************************************************************************
   ICON = LoadImage(0_C_INTPTR_T, 'HELLO.BMP'//achar(0), IMAGE_BITMAP, 0, 0, &

      iany([LR_LOADFROMFILE,LR_CREATEDIBSECTION]))

   write(*,*) ' ICON = ',ICON

   write(*,'(a,z0)') ' ICON = ',ICON
   ires = GetObject(ICON, int(C_SIZEOF(bmp),C_INT), C_LOC(bmp))

   write(*,*) ' ires = ',ires

   hdcMem = CreateCompatibleDC(hdcPrn)

   write(*,*) 'hdcMem=',hdcMem

   old_hgdi = SelectObject(hdcMem, ICON)

   write(*,*) 'old_hgdi=',old_hgdi

   ires = BitBlt(hdcPrn, 0, 0, bmp%bmWIdth, bmp%bmHeight, hdcMem, 0, 0, SRCCOPY)

   write(*,*) ' ires = ',ires

   ires = DeleteObject(hdcMem)

   write(*,*) ' ires = ',ires
!   ires = DrawIconEx(hdcPrn, 10, 10, ICON, 0, 0, 0, 0_C_INTPTR_T, DI_NORMAL)

!   ires = DrawIconEx(hdcPrn, 10, 10, ICON, 0, 0, 0, 0_C_INTPTR_T, DI_IMAGE)

!   ires = DrawIconEx(hdcPrn, 10, 10, ICON, 0, 0, 0, 0_C_INTPTR_T, iany([DI_DEFAULTSIZE,DI_NORMAL]))

!   write(*,*) ' ires = ',ires

!   ires = GetLastError()

!   write(*,*) ' ires = ',ires

   ires = DeleteObject(ICON)

   write(*,*) ' ires = ',ires
   ires = MoveToEx(hdcPrn, cPage, cPage, pt)

   write(*,*) ' ires = ',ires

   ires = LineTo(hdcPrn, 0, 0)

   write(*,*) ' ires = ',ires
   retint = EndPage(hDCPrn)

write(*,*) 'retint=',retint

   retint = EndDoc(hDCprn)

write(*,*) 'retint=',retint

! Release the printer resources

   retlog = DeleteDC(hDCprn)

write(*,*) 'retlog=',retlog
end program PrintImage

Very interesting, but I had problems with compilation. What do you use as compiling options? I tried with

IFORT /4L132 /libs:qwin printimage3.f90 /traceback

Then I get the message

printimage3.f90(276): error #6404: This name does not have a type, and must have

an explicit type. [C_SIZEOF]

lStructSize = C_SIZEOF(pd), &

/Hkan

I am surprised by that error. The interface to C_SIZEOF should have been made explicit by the line

use ISO_C_BINDING

Maybe ifort doesn't define the T_PRINTDLG structure to have the BIND(C) attribute? Then C_SIZEOF wouldn't work on pd except as an extension. I compiled in gfortran via

gfortran draw.f90 -lgdi32 -lcomdlg32 -odraw

If you have a 64-bit system you should be able to remove the two !DEC$ lines and compile my code with ifort. Otherwise leave them in there and try changing C_SIZEOF to SIZEOF and recompile.

None of the Win32 API declarations use BIND(C), but that doesn't matter because C_SIZEOF wouldn't care. But the problem is that C_SIZEOF is a F2008 feature not yet in Intel Fortran. Use the extension SIZEOF as a workaround.

Retired 12/31/2016

Another workaround would be to create an ISO_C_BINDING.f90 file

module ISO_C_BINDING_EXT

   intrinsic SIZEOF

end module ISO_C_BINDING_EXT
module ISO_C_BINDING

   use, intrinsic :: ISO_C_BINDING

   use ISO_C_BINDING_EXT, C_SIZEOF=>SIZEOF

end module ISO_C_BINDING


The advantage being that you could leave code that had lots of usage of C_SIZEOF unchanged as long asifort looked for the ISO_C_BINDING.mod file it generated from the above code rather than its intrinsic version. When ifort catches up you can just delete the non-intrinsic ISO_C_BINDING.mod file.

Interesting idea, but it won't work the way you have it. You cannot write your own ISO_C_BINDING that USEs the intrinsic module. And there's no way to use renaming to map a different name onto an intrinsic. Unfortunately, the "size of" concept is one that does not lend itself to being added by user code.

Retired 12/31/2016

Why not? Works fine in gfortran. I thought the point of "use, intrinsic ::" vs. "use ::" was that it allows the compiler to distinguish between the intrinsic module supplied by the compiler and any user-defined module with the same name. Consider this example:

module old_stuff

   contains

   function marklar(x)

      real x

      real marklar

      marklar = 3*x+2

   end function marklar

end module old_stuff
module new_stuff

   use old_stuff, sizeof=>marklar

end module new_stuff
program test

   use new_stuff

   real a
   a = 7

   write(*,'(a,f0.0)') 'sizeof(a) = ', sizeof(a)

end program test


In both gfortran and ifort it prints "sizeof(a) = 23.". By this technique, all functions may be named marklar.

Your latest program does something very different than your proposal - it does not rename an intrinsic. Show me how you would turn this code into something that does what C_SIZEOF does.

Retired 12/31/2016

FWIW - a post on c.l.f on renaming of intrinsics: http://groups.google.com/group/comp.lang.fortran/msg/6ca00d004e385e77.

intrinsics /= module intrinsics

The big problem here is that the compiler has to treat C_SIZEOF as essentially the same as the SIZEOF extension intrinsic, which includes allowing that in initialization expressions, and allowing most anything with compile-time known size as the argument. The way we currently implement intrinsic modules such as ISO_C_BINDING does not provide a hook for that. We know we have to create such a hook and pretty much know how we're going to do it.

Retired 12/31/2016

module old_stuff

   intrinsic sizeof

end module old_stuff
module new_stuff

   use old_stuff, marklar=>sizeof

end module new_stuff
program test

   use new_stuff

   integer k(2)

   integer, parameter :: m = marklar(k)

   integer(m) x
   write(*,*) huge(x)

end program test


In program test, marklar is used in an initialization expression just as we might have used C_SIZEOF. gfortran doesn't like it because it doesn't allow SIZEOF in initialization expressions, but ifort prints out

9223372036854775807

That's very interesting - I would not have guessed that would work. I modified your program to print out m, as otherwise it doesn't demonstrate what is needed, and it worked. Thanks.

Retired 12/31/2016

Leave a Comment

Please sign in to add a comment. Not a member? Join today