Print a BMP-file using Intel Fortran

[H_2]

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

[anthonyrichards]

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)

[H_2]

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

[JVanB]

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:
[bash]!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 [/bash]
The output was:
[bash] 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[/bash]
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.

[JVanB]

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.

[bash]!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 [/bash]

[H_2]

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

[JVanB]

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.

[Steven_L_Intel1]

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.

[JVanB]

Another workaround would be to create an ISO_C_BINDING.f90 file

[bash]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 [/bash]
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.

[Steven_L_Intel1]

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.

[JVanB]

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:

[bash]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 [/bash]
In both gfortran and ifort it prints "sizeof(a) = 23.". By this technique, all functions may be named marklar.

[Steven_L_Intel1]

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.

[IanH]

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

[Steven_L_Intel1]

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.

[JVanB]

[bash]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 [/bash]
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

[Steven_L_Intel1]

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.