DOS窓経由ではなく window だけで。

左クリックで翌月、右クリックで終了。１枚目に白紙が出ます。

ソース・プログラム

余り考えないで流用したので乱れている。

module m_sub
  use ifwina
  use kernel32
  type :: t_wnd
    integer (HANDLE) :: hWnd
    integer (HANDLE) :: hDC
  end type
  type (t_wnd), save :: wnd
 contains
  integer (LRESULT) function MainWndProc( hWnd, mesg, wParam, lParam ) ! call back procedure
  !DEC$ ATTRIBUTES STDCALL, DECORATE, ALIAS : 'MainWndProc' :: MainWndProc
    implicit none
    integer (HANDLE) , intent(in) :: hWnd
    integer (UINT)   , intent(in) :: mesg
    integer (fwParam), intent(in) :: wParam
    integer (flParam), intent(in) :: lParam
   
    integer (BOOL)    :: iretb
    integer (HANDLE)  :: hBmp, hDC
    type (T_PAINTSTRUCT) :: ps
    type (T_RECT)       :: rc
    
    character (50) :: text = 'unko'C
    MainWndProc = 0
    select case ( mesg )
      case (WM_CREATE)
       hDC      = GetDC(hWnd)
       iretb    = GetClientRect(hWnd, rc)
       hBmp     = CreateCompatibleBitmap(hDC, rc%right - rc%left, rc%bottom - rc%top)
       wnd%hWnd = hWnd
       wnd%hDC  = CreateCompatibleDC(hDC)
       iretb    = SelectObject(wnd%hDC, hBmp)
       iretb    = PatBlt(wnd%hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, WHITENESS)
       iretb    = ReleaseDC(hWnd, hDC)
       iretb    = DeleteObject(hBmp)
       if ( linePrinter() ) then
        iretb = DeleteObject( wnd%hDC )
        call PostQuitMessage( 0 )
       end if
     case (WM_DESTROY, WM_RBUTTONDOWN)
       iretb = DeleteObject( wnd%hDC )
       call PostQuitMessage( 0 )
     case (WM_PAINT)
       hDC    = BeginPaint(    wnd%hWnd, ps )
       iretb  = GetClientRect( wnd%hWnd, rc )
       iretb  = BitBlt(hDC, 0, 0, rc%right  - rc%left, rc%bottom - rc%top, wnd%hDC, 0, 0, SRCCOPY)
       iretb  = EndPaint( wnd%hWnd, ps )
     case (WM_LBUTTONDOWN)
       iretb    = PatBlt(wnd%hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, WHITENESS)
       if ( linePrinter() ) then
        iretb = DeleteObject( wnd%hDC )
        call PostQuitMessage( 0 )
       end if
       iretb = InvalidateRect(wnd%hWnd, NULL, FALSE)
     case default
       MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam )
    end select 
    return
  end function MainWndProc 
  
  subroutine gr_text(ix, iy, txt, icol)
    integer, intent(in) :: ix, iy
    character (len = *), intent(in) :: txt
    integer, intent(in), optional :: icol
    integer (BOOL)   :: iretb
    integer (HANDLE) :: hFont
    if ( present(icol) ) iretb = SetTextColor(wnd%hDC, icol) 
    iretb = SetBkMode(wnd%hDC, TRANSPARENT)
    hFont = CreateFont( 10, 7, 0 , 0 ,FW_DONTCARE , FALSE , FALSE , FALSE ,  &
  			          ANSI_CHARSET , OUT_DEFAULT_PRECIS ,           &
		      	      CLIP_DEFAULT_PRECIS , PROOF_QUALITY ,           &
			          IOR(FIXED_PITCH,  FF_ROMAN) , NULL       		)
    iretb = SelectObject(wnd%hdc , hFont)
    iretb = TextOut(wnd%hDC, ix, iy, txt, LEN_TRIM(txt))
    iretb = SelectObject(wnd%hdc , GetStockObject(SYSTEM_FONT))
    iretb = DeleteObject(hFont)
    return
  end subroutine gr_text

  integer function irgb(ir, ig, ib)
    integer, intent(in) :: ir, ig, ib
    irgb = ir + (ig + (ib * 256)) * 256
    return
  end function irgb
 
  function linePrinter() result(eof)
    logical :: eof
    integer :: ix, iy, ic, kx = 30, ky = 10, kff = 0, kdy = 8
    character(len = 136), save :: text = ''
      eof = .false.
      ix = kx
      iy = ky
      ic = 0
      call gr_text(ix, iy, text, irgb(0, 0, 0) )
      do 
        read(7, '(a)', end = 999) text
        select case(text(1:1))
          case ('0') ! LF
            ix = kx
            iy = iy + 2 * kdy
            text(1:1) = ' '
          case ('1') ! FF
            ic = ic + 1
            ix = kx
            iy = 500 * ic + ky
            text(1:1) = ' '
            if (MOD(ic, 2) == 0) exit
          case ('+') 
            ix = kx
            text(1:1) = ' '
          case default
            iy = iy + kdy
        end select
        call gr_text(ix, iy, text, irgb(0, 0, 0) )
      end do
      return
999 eof = .true. 
    return
  end function linePrinter
  
end module m_sub
!=================================================================
integer (KIND = 4) function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow)
  !DEC$ ATTRIBUTES STDCALL, DECORATE, ALIAS : 'WinMain' :: WinMain
  use m_sub
  use user32
  use ifwinty
  implicit none
  integer (HANDLE), intent(IN) :: hInstance, hPrevInstance
  integer (LPSTR) , intent(IN) :: lpszCmdLine
  integer (SINT)  , intent(IN) :: nCmdShow

  ! Variables
  type (T_WNDCLASS) :: wc
  type (T_MSG)      :: mesg
  integer (HANDLE)  :: hWndMain
  integer (BOOL)    :: iretb
  character (LEN = *), parameter :: ClassName = "Snoopy Calendar"//char(0)

  open(UNIT=7,FILE='SNPCAL.OUT',STATUS='old')
  !  Init   Main window
  WinMain = -1 ! Error code
  wc%lpszClassName = loc( ClassName )
  wc%lpfnWndProc   = loc( MainWndProc )               ! CALLBACK procedure name
  wc%style        = ior( CS_VREDRAW , CS_HREDRAW )
  wc%hInstance     = hInstance
  wc%hIcon        = NULL
  wc%hCursor      = LoadCursor( NULL, IDC_ARROW )
  wc%hbrBackground = ( COLOR_WINDOW + 1 )
  if ( RegisterClass(wc) == 0 ) return

  !Init instance
  WinMain = -2 ! Error code
  hWndMain = CreateWindowEx(  0, ClassName, ClassName,      &
                        int(WS_OVERLAPPEDWINDOW),        &
                        CW_USEDEFAULT, CW_USEDEFAULT,     &
                        1000, 1050,     &
                        0,                             &
                        0,                             &
                        NULL,                           &
                        NULL                              )
  if ( hWndMain == 0 ) return
  iretb = ShowWindow( hWndMain, nCmdShow )
  iretb = UpdateWindow( hWndMain )

  ! Message Loop : Main Loop
  do while ( GetMessage (mesg, NULL, 0, 0) )
   iretb = TranslateMessage( mesg )
   iretb = DispatchMessage( mesg )
  end do

  WinMain = mesg%wParam
  return
end function WinMain