目次 次の項目

1.Windowsプログラムの概略


1. Windowsプログラムの概略

WIN32

 Windowsプログラムが起動されると,まず最初にWindowsシステムからWinMain関数 が呼び出されて実行します。 WinMain関数では,ウィンドウを作成し,Windowsシ ステムから送られてくるメッセージを受け取り,メッセージを処理するウィンドウ・ プロシジャWndProc(名前は任意)を定義します。

 WndProc関数は,WinMain関数から送られてきたメッセージに対応した処理を行います。 メッセージには,Windowsシステムが発信するものや,プログラムで発信するもの, 使用者がキーボードやマウスを操作して発生するメッセージがあります。


目次 次の項目

2.Windowsプログラムの作成


2.1 Windowsプログラムの作成

 Windowsプログラムを作成するには,次の手順に従って行います。

1) Developper StudioのFortran開発環境を起動し,プルダウンメニューの'File'を選択し,'New'を選択します。

2) 図2.1 のようなプロジェクト設定画面になるので,'Fortran Windows Application'を選び,'Project Name'に任意の名前を指定します。

図2.1 新規プロジェクト作成画面

3) プロジェクト・ウィザード・ダイアログでは,プロジェクト・ファイルのディレクトリなど必要なオプションを設定します。
 ソースプログラムを新規に作成するには,ツールバーの'Files'を選択しファイル・ダイアログで'Fortran Free Format Source File' を選択します。Windowsプログラムでは,Fortran90の文法を用いますのでFree Formatを選択し,ファイル修飾子には.f90を付けるようにします。既に存在するプログラムを組み込む場合は次の4)にしたがって登録します。
 その他にアイコンやリソース定義(後に解説します)などを新規に作成する場合もここで設定します。ただし,実際には既存の類似のファイルをコピーして変更する方が容易なのでこれも4)にしたがって設定することになるでしょう。

4) プログラムの実行に必要なその他のソースファイルがあれば'Project'メニューの'Add to Project -> Files...'を選択し設定します。

5) 翻訳・結合は,'Build'メニューで'Build'を選択,又は,SHIFTキー+F8キーを押します。

6) 実行は,'Build'メニューで'Execute XXX.exe'を選択,又はCTRLキー+F5キーを押します。プログラムを修正した場合に,CTRLキー+F5キーを押すと,翻訳・結合を行うか聞いてきますのでENTERキーを押すと,翻訳から処理されます。

2.2 DebugモードとReleaseモード

 Visual Fortranには,DebugモードとReleaseモードの2種類の実行モードがあります。Debugモードでは,実行途中で一時停止し,変数の内容を確認したり するなどの豊富なDebug機能が用意されています。
 Releaseモードは,Debugの完了したプログラムをそのまま保存したり,実際の計算を高速度で実行する場合に用います。ちなみに筆者は常にこのモードで実行するようにしています。
 デフォルトはDebugモードになっており,Releaseモードに変更するには,'Build'メニューの'Set Active Configuration'で設定します。

2.3 Windowsプログラム作成上の注意

 Windowsプログラムの翻訳は,筆者の経験から非常に時間がかかります。翻訳時間を節約するためには以下のようにすることを推奨します。

1) プログラムは複数のモジュールに分割する。
 Developper Studioでは,変更のされていないモジュールは翻訳をパスし,初回のみすべてのモジュールが翻訳されます。 すべてのサブルーチンをモジュールに分割する必要はありませんが,目的別にグループ化するのが適当でしょう。

2) グローバル変数を定義するmodule文は一つの独立したモジュールにする。
 module文で定義した変数は,他のモジュールからも参照されるため,module文を含むモジュールを1ヶ所でも変更すると,それを引用している他のモジュールに変更がなくても再翻訳されます。
 Windowsプログラムでは,ハンドル変数やデバイスコンテキストを定義する変数はグローバル変数にすることが多々あります。そのため,module定義文は必ず用いることになりますので注意してください。

2.4 参考資料

1) Windows95 APIバイブル1 WIN32編 翔泳社
 基本的なWindow操作が書かれたマニュアルで,ほぼこれ1冊あればプログラムすることができます。

2) Windows95 APIバイブル2 コモンコントロール,メッセージ編 翔泳社
 コモンコントロールを用いてファイル名の一覧を表示したりする場合に参考になります。

3) Windows95 APIバイブル3 ODBCマルチメディア編 翔泳社
 oracleやaccessなどのデータベースをアクセスする場合について書かれています。

4) Windows98 APIバイブル シェル,シェルユーティリティ,印刷,IME,追加関数編 翔泳社
 Windows98で追加された関数や,印刷の仕方が詳しく書かれています。

5) msdn online library
 日本語で書かれたオンラインマニュアルです。

6) Compaq Fortran Documentation
 Compaq Visual Fortranに関するサイトです。

7) 猫でもわかるプログラミング
 CによるWindowsプログラミングについて書かれた分かりやすいサイトです。


目次 次の項目

3.ウィンドウの作成


3.1 ウィンドウの作成

 Windowsプログラムは,「1. Windowsプログラムの概略」で紹介したように,WinMain関数とWindProc関数から成っています。取り敢えず図3.1のようなウィンドウを表示するプログラムを作ってみましょう。

図3.1 基本的なウィンドウ

 このウィンドウは,タイトルバーにWINDOW01と表示されただけの背景の黒いウィンドウです。ウィンドウを閉じたり最小化するボタンはついています。

3.2 プログラムの例

!*********************************************************************
!  WinMain
!        2001.09.07  2001.09.07  Y.AKATSUKA
!*********************************************************************
integer function WinMain( hInstance, hPrevInstance, lpszCmdLine, &
                          nCmdShow )
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use dfwina
!
interface
integer function MainWndProc ( hwnd, mesg, wParam, lParam )
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd
type (T_WNDCLASSEXA)  wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC("WINDOW01"C)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = IOR(CS_VREDRAW, CS_HREDRAW)
      wc%hInstance    = hInstance
      wc%hIcon        = 0
      wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
!
   hWnd = CreateWindowEx(0, "WINDOW01"C,         &
                       "WINDOW01"C,              &
                       INT(WS_OVERLAPPEDWINDOW), &
                       CW_USEDEFAULT,            &
                       0,                        &
                       CW_USEDEFAULT,            &
                       0,                        &
                       NULL,                     &
                       NULL,                     &
                       hInstance,                &
                       NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
!
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use dfwina

integer hWnd, mesg, wParam, lParam
   select case (mesg)
   case (WM_CREATE)
   case (WM_DESTROY)
     call PostQuitMessage(0)
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

 では,少しプログラムの解説をしましょう。まず,WinMain関数ですが,Windowsからプログラムが起動されるとWinMain関数が呼び出されます。!DEC$文はコンパイラに与えるディレクティブで,この場合はCと互換のある呼び出しインターフェースでパラメータが領域渡し,別名_WinMain@16で呼び出されることを意味しています。@16というのはパラメータが4つ(16/4=4)あることを示します。

 パラメータで渡されるhInstanceは,Windowsから起動されたアプリケーションを識別するためのインスタンスハンドルです。Windowsでは同じアプリケーションを複数起動することができ,それぞれインスタンスハンドルによって制御します。hPrevInstanceは,同じアプリケーションが既に実行されていないかを調べるのに用います。

 use dfwina 文は,Windows APIのFortranインターフェースを記述したインクルード文を組み込んでいます。この記述を忘れると,Windows APIを使うサブルーチンが未定義になってしまいます。

 次に,interface文 => end interface文ですが,外部サブルーチンや関数のインターフェースを定義するために用います。ここではウィンドウクラスを定義する構造体の中でMainWndProc関数をパラメータを省略して呼び出すために手順を設定しています。

 さて,どんなウィンドウを開くのかをウィンドウクラス定義体に名前を付けて設定し,RegisterClassExというAPI関数でシステムに登録します。 これはhPrevInstance変数の値を調べて,このアプリケーションを初めて実行されるときだけ実行します。
 Visual Fortranが用意しているウィンドウクラス定義体はT_WNDCLASSEXAという名前になっています。type文を用いて構造体にwcという名前を付けています。Windows95 API解説書には,WNDCLASSEXAという名前で記述されていますが,Visual FortranではT_を付けた形で登録されています。

・RegisterClassEx関数
 RegisterClassEx関数は,ウィンドウクラスを登録します。 登録したクラスは,CreateWindowEx関数で用います。

    integer function RegisterClassEx(lpwcx)
     TYPE (T_WNDCLASSEXA)  lpwcx     ! クラスデータ

     戻り値:成功すると,登録されたクラスを識別するアトム(文字列参照テーブルに登録された識別子)が返ります。
   失敗すると,0 が返ります。

・WNDCLASSEXA構造体
 WNDCLASSEXA構造体は,ウィンドウの作成に使用する新しいウィンドウクラスを作成します。

    type T_WNDCLASSEXA
        integer(4) cbSize        ! サイズ
        integer(4) style         ! クラススタイル
        integer(4) lpfnWndProc   ! WndProc関数のポインタ
        integer(4) cbClsExtra    ! ウィンドウクラス構造体の拡張域のバイト数
        integer(4) cbWndExtra    ! ウィンドウインスタンスに割り当てる拡張域のバイト数
        integer(4) hInstance     ! インスタンスのハンドル
        integer(4) hIcon         ! アイコンのハンドル
        integer(4) hCursor       ! デフォルトカーソルのハンドル
        integer(4) hbrBackground ! バックグランドカラーブラシのハンドル
        integer(4) lpszMenuName  ! メニューのハンドル
        integer(4) lpszClassName ! ウィンドウクラスを識別するアトム
        integer(4) hIconSm       ! スモールアイコンのハンドル
    end type T_WNDCLASSEXA

・CreateWindowEx関数
 CreateWindowEx関数は,登録されたウィンドウクラスに基づいてウィンドウを作成します。

    integer function CreateWindowEx (dwExStyle ,lpClassName ,lpWindowName, dwStyle,  &
        X ,Y ,nWidth ,nHeight ,hWndParent  ,hMenu ,hInstance ,lpParam)
    integer         dwExStyle     ! 拡張ウィンドウスタイル
    character*(*)   lpClassName   ! クラス名
    character*(*)   lpWindowName  ! ウィンドウの名前
    integer         dwStyle       ! ウィンドウスタイル
    integer         X             ! 左上隅のX座標
    integer         Y             ! 左上隅のY座標
    integer         nWidth        ! ウィンドウの横幅
    integer         nHeight       ! ウィンドウの高さ
    integer         hWndParent    ! 親ウィンドウハンドル(親を作るときはNULL)
    integer         hMenu         ! メニューハンドル,クラスメニューの時はNULL
    integer         hInstance     ! インスタンスハンドル
    integer         lpParam       ! ウィンドウ作成データのポインタ

    戻り値:成功時はウィンドウハンドル。失敗時はNULL。

 プログラム例では,ウィンドウクラス名にRegisterClassEx関数で指定したのと同じ"WINDOW01"Cを指定しています。
 ウィンドウの名前は,ウィンドウを表示したときにタイトルバーに表示されます。
 ウィンドウスタイルにWS_OVERLAPPEDWINDOWを指定していますが,最大最小化ボタンを有するタイトルバーと境界線をもった標準的なウィンドウを作成します。
 X座標と横幅にCW_USEDEFAULTを指定していますが,位置や幅にこだわらない場合に指定します。
 インスタンスハンドルには,Windowsから渡されたhInstanceを指定します。

 ShowWindow関数は,SW_SHOWNORMALを指定し,作成したウィンドウを通常サイズで可視状態にしています。

 次のdo while文からend do文は,メッセージを処理するループです。Windowsシステムから送られてくる各種のメッセージをここで翻訳してプロシジャに送ります。

   do while( GetMessage (mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage( mesg )
     i = DispatchMessage( mesg )
   end do

 このループは,プロシジャがPostQuitMessage関数を実行し,WM_QUITメッセージをポストするまで繰り返し実行します。


文字定数"***"CのようにCを付けて現すのは,Visual Fortranでは文字列の最後にNULLを付加した文字定数です。


 次は,ウィンドウ・プロシジャですが,WinMain関数から渡されたメッセージを解釈し,必要な処理を行う手続きを記述します。

 ウィンドウ・プロシジャには,hWnd,mesg,wParam,lParamの順にウィンドウハンドル,メッセージ,詳細パラメータが渡されてくるので,メッセージ毎に必要な処理を記述し,コマンドの場合には更にパラメータの内容によって処理内容を細分して記述します。  この例の場合は,ウィンドウが閉じるときに渡ってくるWM_DESTROYメッセージを受け取ると,PostQuitMessage関数を実行するように記述しているだけですが,後のプログラムではもう少しいろいろな処理を行います。
 DefWindowProc関数は,メッセージのデフォルトの処理をWindowsに任せる関数です。


目次 次の項目

4.ビットマップの表示(1)


4.1 ビットマップの表示

 画面にビットマップイメージを表示するには,LoadBitmap関数を用いると簡単にイメージファイルを読み込んで表示することができます。 プログラムを起動したときにイメージ画像を表示したりする場合に便利です。 読み込むイメージ画像はリソースファイルで定義しておきます。 ただし,LoadBitmap関数は,ディスプレイ互換のビットマップを作成します。 従って,プリンタに出力する場合には用いることができません。

 では,次のようなビットマップを表示するプログラムを作ってみましょう。

 プログラムの例

!*********************************************************************
!  WinMain
!        2001.09.07  2001.09.14  Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use dfwina
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="BITMAP01"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0
      wc%hInstance    = hInstance
      wc%hIcon        = 0
      wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   hWnd = CreateWindowEx(0, lpszClassName,    &
                    "BITMAP"C,                &
                    INT(WS_OVERLAPPEDWINDOW), &
                    CW_USEDEFAULT,            &
                    0,                        &
                    CW_USEDEFAULT,            &
                    0,                        &
                    NULL,                     &
                    NULL,                     &
                    hInstance,                &
                    NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use dfwina

integer hWnd, mesg, wParam, lParam
type (T_PAINTSTRUCT) ps
type (T_BITMAP) bmp
integer hInst, hBitmap, hDC, hmdc
logical b
   select case (mesg)
   case (WM_CREATE)
     hInst = GetWindowLong(hWnd, GWL_HINSTANCE)
     hBitmap = LoadBitmap(hInst, LOC("MYBMP"C))
     i = GetObject(hBitmap, SIZEOF(bmp), LOC(bmp))
     ix = bmp%bmWidth
     iy = bmp%bmHeight
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)             ! ==> EndPaint
     hmdc = CreateCompatibleDC(hDC)
     i = SelectObject(hmdc, hBitmap)
     b = BitBlt(hDC,0,0,ix,iy,hmdc,0,0,SRCCOPY)
     b = DeleteDC(hmdc)
     b = EndPaint(hWnd, ps)                 ! <== BeginPaint
   case (WM_DESTROY)
     b = DeleteObject(hBitmap)
     call PostQuitMessage(0)
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

 プログラムの前半部分は第4章のプログラムとほぼ同じです。MainWndProcでは,WM_CREATEメッセージを捕まえたときに,GetWindowLong,LoadBitmap,GetObjectの各関数を実行しています。  GetWindowLong関数でインスタンスハンドルを取得し,LoadBitmap関数では,リソースファイルで定義したBMP形式の画像データを読み込みます。  GetObject関数は,読み込んだBITMAPの情報をT_BITMAP構造体(bmp)に取り込みます。 この例では,画像データのX方向とY方向の長さを取得しています。

 WM_PAINTメッセージは,画面の表示(再表示)が必要になったときに発行されます。 ウィンドウのサイズを変更した場合にも発行されます。  BeginPaint関数は,デバイスコンテキストを割り当てペイント処理を開始します。 デバイスコンテキストというのは,ディスプレイやプリンタなどとデータをやりとりするインターフェースのようなものです。 EndPaint関数は,BeginPaint関数と対で用いられペイント処理の終了を指示します。 この二つの関数の間で具体的な描画操作を実行します。
 実用的なプログラムでは,画面の再表示の度に時間のかかる作画処理を行うと表示時間が遅くなったりします。 そのため,予め仮想デバイス(メモリー)に作画しておいたものをBitBlt関数などを用いて一気に表示するように工夫します。 この操作をブリットといいます。

 CreateCompatibleDC関数は,指定されたデバイス(この場合は表示するディスプレイ)と互換性のあるメモリデバイスコンテキストをメモリ内に作成します。 SelectObject関数は,ビットマップオブジェクトをメモリデバイスコンテキストに対応付け,BitBlt関数でビットマップイメージをデバイス環境にコピーすることで表示を行います。 BitBlt関数の替わりにStretchBlt関数を用いると,画像を拡大したり縮小して表示することができます。

 DeleteDC関数は,先に作成したメモリデバイスコンテキストを削除します。

 WM_DESTROYメッセージは,ウィンドウが閉じるときに発行され,DeleteObject関数で取得したBITMAPを解放しています。

 さて,Windowsプログラムでは,プログラムで使用するビットマップ画像ファイルはソースプログラムとは別にリソーススクリプトファイルに記述します。 リソーススクリプトファイルはソースプログラムと同様に作成し(修飾子は.RC),Developper Studioのワークスペースに登録します。 ここではBITMAPのファイルを定義するだけですので,必要なのはBMP形式の画像ファイルの所在を示す次の一行のみです。

・リソーススクリプトファイルの内容

/////////////////////////////////////////////////////////////////////
//
// Bitmap
//
MYBMP   BITMAP  DISCARDABLE  "C:\\My Documents\\My Pictures\\GIRL.bmp"

Spy++について


 Visual FortranについてくるSpy++というツールを用いると,気に入ったソフトがどういうウィンドウスタイルを採用しているかスパイすることができます。また,マウスなどを操作したときにシステムからどういうメッセージが送られてくるかモニタすることができます。


目次 次の項目

5. ビットマップの表示(2)


5.1 任意のビットマップファイルの表示

 第4章ではリソーススクリプトファイルに定義したビットマップを表示しました。 この章では任意のビットマップファイルを表示する場合について解説します。
 画面にはメニューバーがついて,Fileというメニューをクリックし,Openを選択するとファイル名を入力するコモン・ダイアログを表示します。 次の例はWINDOWSシステムのC:\WINDOWSの中にある"花見.bmp"というビットマップファイルを表示した例です。

図5.1 ビットマップ表示の例

5.2 ビットマップの構造

 プログラムの説明に入る前に,ビットマップファイルの構造について説明しましょう。

 ビットマッブは,DIB(Device Independent Bitmap)といわれるWindows標準フォーマット形式が使われます。  DIB形式のビットマップ・ファイルは,図5.2のような構造になっています。

BITMAPFILEHEADER構造体
BITMAPINFOHEADER構造体
(RGBQUARD構造体)
ビット配列
図5.2ビットマップの構造

・BITMAPFILEHEADER構造体
 BITMAPFILEHEADER構造体は,ファイルの情報が格納されています。

   type  T_BITMAPFILEHEADER
       integer*2   bfType      ! "BM"の2byteの文字
       integer     bfSize      ! ファイルのサイズ
       integer*2   bfReserved1
       integer*2   bfReserved2
       integer     bfOffBits   ! ファイルの先頭からビット配列までのオフセット値
   end type  T_BITMAPFILEHEADER

・BITMAPINFOHEADER構造体
 BITMAPINFOHEADER構造体は,ビットマップの情報が格納されています。

   type  T_BITMAPINFOHEADER
       integer(4)  biSize          ! 構造体の大きさ
       integer(4)  biWidth         ! ビットマップの幅
       integer(4)  biHeight        ! ビットマップの高さ
       integer(2)  biPlanes        ! プレーンの数
       integer(2)  biBitCount      ! ピクセル当たりのビット数 1,4,8,24のいずれか
       integer(4)  biCompression   ! 圧縮方式
       integer(4)  biSizeImage     ! ビットマップのサイズ
       integer(4)  biXPelsPerMeter ! 水平解像度
       integer(4)  biYPelsPerMeter ! 垂直解像度
       integer(4)  biClrUsed       ! 使用している色数
       integer(4)  biClrImportant  ! 使用している重要な色数
   end type  T_BITMAPINFOHEADER

・RGBQUARD構造体
 RGBQUARD構造体は,使用しているカラーテーブルの情報が格納されています。 biBitCountが24のフルカラーのときは存在しません。 通常はbiClrUsedの数だけRGBQUARD構造体が存在します。 biClrUsedが0のときは,2**biBitCountだけRGBQUARD構造体が存在します。

   type  T_RGBQUAD
       byte rgbBlue       ! 青
       byte rgbGreen      ! 緑
       byte rgbRed        ! 赤
       byte rgbReserved
   end type  T_RGBQUAD

・BITMAPINFO構造体
 BITMAPINFO構造体は,BITMAPINFOHEADER構造体とRGBQUAD構造体をまとめたものです。

   type  T_BITMAPINFO
       type (T_BITMAPINFOHEADER) bmiHeader
       type (T_RGBQUAD) bmiColors (1)
   end type  T_BITMAPINFO

・ビット配列
 ビット配列は,ビットマップデータが画像の最終行から先頭行へ逆順に格納されています。 カラーテーブルを用いるときは,カラーテーブルの相対位置の情報で格納されています。

5.3 パレット

 フルカラー以外のビットマップを表示するときは,パレットを使用します。 パレットの設定を怠ると画像の色が正しく表示されません。

・CreatePalette関数
 CreatePalette関数は,論理パレットを作成し,パレットハンドルを取得します。

    integer function CreatePalette(lplgpl)
     type(T_LOGPALETTE)  lplgpl   ! 論理パレットのカラー情報をもつLOGPALETTE構造体

     戻り値:成功時は論理パレットのハンドル。失敗時はNULL。

 LOGPALETTE構造体は,PALETTEENTRY構造体を含んだ次の形をしています。

    type  T_LOGPALETTE
        integer*2 palVersion    ! システムのバージョン(Z'0300')
        integer*2 palNumEntries ! palPalEntry配列のエントリ数
        type (T_PALETTEENTRY) palPalEntry (1)
    end type  T_LOGPALETTE

    type  T_PALETTEENTRY
        byte peRed             ! 赤の輝度
        byte peGreen            ! 緑の輝度
        byte peBlue             ! 青の輝度
        byte peFlags            ! PALETTEENTRYの使用方法フラグ
    end type  T_PALETTEENTRY

・SelectPalette関数
 SelectPalette関数は,論理パレットをデバイスコンテキストに選択します。

    integer function SelectPalette(hdc,hpal,bForceBackground)
     integer hdc,             ! デバイスコンテキストハンドル
     integer hpal,            ! CreatePalette関数で取得したパレットハンドル
     logical bForceBackground ! フォアグラウンドかバックグラウンドモードかの指定

     戻り値:成功時は以前のパレットハンドル。失敗時はNULL。

 bForceBackgroundにFALSEを指定すると,アプリケーションがフォアグラウンドにある時に論理パレットがデバイスパレットにコピーされます。 TRUEを指定すると,論理パレットはすでにシステムパレットに存在する色に最善の形でマップされます。 これらは何れも次のRealizePaletteを実行したときに 実行されます。

・RealizePalette関数
 RealizePalette関数は,SelectPalette関数で選択されている論理パレットをシステムパレットにマップします。

    integer function RealizePalette(hdc)
     integer hdc              ! デバイスコンテキストハンドル

     戻り値:成功時はシステムパレットにマップされたエントリ数。失敗時はGDI_ERROR。

 パレットハンドルは,表示が終わって不要になったらDeleteObject関数で解放します。

5.4 メニューバーを付ける

 任意のビットマップを表示するためには,ビットマップのファイル名を入力できるようにしなければなりません。 ほとんどのアプリケーションプログラムの画面にはメニューバーが付いています。 メニューバーには,ファイル(F),編集(E),表示(V)の順にメニュー項目が並んでいます。 そして,ファイルをクリックすると,新規作成(New),開く(Open),…,終了(Exit)などの詳細メニューが出てきます。 ここでは,ファイル名を入力するだけの図5.3のような簡単なメニューを作ります。


図5.3 メニューバー

 メニューバーを表示するには,前章で出てきたリソ−スファイルにメニューの項目を記述します。 また,LoadMenu関数でメニューハンドルを取得し,CreateWindowEx関数のパラメータに指定します。

・リソースファイルの定義

  /////////////////////////////////////////////////////////////////////////
  // Menu
  //
  MYMENU   MENU  DISCARDABLE
  BEGIN
      POPUP "&File"
      BEGIN
          MENUITEM "&Open...",                 101
          MENUITEM "E&xit",                    109
      END
  END

 ここで、メニューを定義するリソーススクリプトは次の形をしています。

  メニュー名 MENU メモリオプション
  BEGIN
      POPUP     "メニューバーに表示される項目"
      BEGIN
         MENUITEM  "実際に表示されるメニュー項目"  シンポルコード
      END
  END

 メニュー名は,WinMain関数の中でLoadMenu関数のパラメータに指定します。

 メモリオプションの主なものは以下のとおりです。

  PRELOAD     :プログラム起動時にメモリにロード
  DISCARDABLE :不要になったらメモリから廃棄
  FIXED       :メモリ上で固定
  MOVEABLE    :メモリ上で移動可能

 POPUPは,メニューバーに表示するトップレベルのメニュー項目を指定します。 通常[File],[Edit],…,[Help]の順に配置します。 メニュー項目の中で&記号の次の文字は,下線付きで表示され,ALTキーを押しながらそのキーを押すとメニューが選択されたことになる代替キーを表します。

 シンボルコードは,実行時にメニューが選択されたときに発せられるコード番号で,WndProc関数のWM_COMMANDのところでこのコードを捕まえます。 適当な数字(0〜X'7FFF')を定義して用います。

・LoadMenu関数
 LoadMenu関数は,リソースファイルからメニューをロードして,メニューハンドルを返します。 WinMain関数の中でプログラムのメインメニューをロードするのに用います。

    integer function LoadMenu (hInstance,lpMenuName)
     integer hInstance     ! プログラムのインスタンスハンドル
     integer lpMenuName    ! ロードするメニュー名

  戻り値:正常終了するとメニューのハンドル。失敗時はNULL。

 取得したメニューハンドルは,CreateWindowEx関数のhmenuパラメータに指定します。

5.5 ファイル名の入力

 任意のビットマップを表示できるようにするにはファイル名を入力しなければなりません。 下の図は,いろいろなアプリケーション・プログラムのファイル名入力でよく見かけるものです。 これはWindows APIに用意されているファイル名を入力するためのコモン・ダイアログを用いています。

図5.4 ファイル名入力ダイアログ

・GetOpenFileName関数
 GetOpenFileName関数は,ドライブ,ディレクトリ,ファイル名を指定するダイアログ・ボックスを開きます。

  logical(4) function GetOpenFileName (lpofn)
   type(T_OPENFILENAME)  lpofn     ! 初期化するOPENFILENAME構造体

  戻り値:ファイル名を指定し,OKボタンを押した場合は非0。エラーやCANCELボタンを押した場合は0。

 OPENFILENAME構造体は,GetOpenFileName関数やGetSaveFileName関数でファイルをOpenしたりSaveするときに,ダイアログボックスを初期化するための情報を定義したり情報を格納する構造体です。

    type  T_OPENFILENAME
       integer lStructSize       ! 構造体のサイズ
       integer hwndOwner         ! ダイアログを表示するウィンドウハンドル
       integer hInstance         ! インスタンスハンドル
       integer lpstrFilter       ! ファイル名のフィルタ文字列のポインタ
       integer lpstrCustomFilter ! ユーザ定義のファイル名のフィルタ文字列のポインタ
       integer nMaxCustFilter    ! lpstrCustomFilterが指すバッファの文字列(≧40)
       integer nFilterIndex      ! lpstrFilterが指すバッファに格納するインデックス
       integer lpstrFile         ! ファイル名編集コントロールで用いるファイル名が格納される(≧256)
       integer nMaxFile          ! lpstrFileが指すバッファのサイズ
       integer lpstrFileTitle    ! 選択されたファイルのタイトルを受け取るバッファのポインタ
       integer nMaxFileTitle     ! lpstrFileTitleで指定されたバッファにコピーできる最大文字列長
       integer lpstrInitialDir   ! 初期ファイルディレクトリを指定する文字列のポインタ
       integer lpstrTitle        ! ダイアログボックスのタイトルバーに表示する文字列のポインタ
       integer Flags             ! ダイアログ作成フラグ
       integer(2) nFileOffset    ! lpstrFileが指す文字列内でのファイル名位置のオフセット値
       integer(2) nFileExtension ! lpstrFileが指す文字列内でのファイル名拡張子位置のオフセット値
       integer lpstrDefExt       ! デフォルト拡張子が格納されるバッファのポインタ
       integer lCustData         ! lpfnHookで指定されたフック関数に渡すデータ
       integer lpfnHook          ! フック関数のポインタ
       integer lpTemplateName    ! ダイアログテンプレートの代用ダイアログボックスに付ける名前の文字列
    end type  T_OPENFILENAME

・CreateFile関数,ReadFile関数,CloseHandle関数
 これらの関数は,第1部の9. APIを用いたファイル入出力を参照してください。

5.5 プログラムの例

!*********************************************************************
!  WinMain
!        2001.09.07  2001.09.27  Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use dfwin
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="BITMAP02"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0
      wc%hInstance    = hInstance
      wc%hIcon        = 0
      wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   hmenu = LoadMenu(hInstance, LOC("MYMENU"C))
!
   hWnd = CreateWindowEx(0, lpszClassName,    &
                    "BITMAP02"C,              &
                    INT(WS_OVERLAPPEDWINDOW), &
                    CW_USEDEFAULT,            &
                    0,                        &
                    CW_USEDEFAULT,            &
                    0,                        &
                    NULL,                     &
                    hmenu,                    &
                    hInstance,                &
                    NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
!
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use dfwina

integer hWnd, mesg, wParam, lParam

type (T_PAINTSTRUCT) ps
type (T_OPENFILENAME) ofn
type (T_BITMAPFILEHEADER) Bf

type (T_BITMAPINFO) Bi
pointer (pBi, Bi)

type (T_RGBQUAD) rgbq
pointer (prgb, rgbq)

type (T_LOGPALETTE) LogPal
pointer (pLogPal, LogPal)

integer hInst, hDC, hF, hPalette
logical b
character, ALLOCATABLE, SAVE :: Buffer(:)
character  filename*100, Pal*1028
character*80 :: filter = "BMP Files"C//"*.bmp"C
!
   select case (mesg)
   case (WM_CREATE)
     hInst = GetWindowLong(hWnd, GWL_HINSTANCE)
     isize = 0
     hPalette = 0
   case (WM_CLOSE)
     if (isize /= 0) DEALLOCATE(Buffer)
     if (hPalette /= 0) i = DeleteObject(hPalette)
     i = DestroyWindow(hWnd)
   case (WM_DESTROY)
     call PostQuitMessage(0)
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)         ! ==> EndPaint
     if (isize /= 0) then
       if (hPalette /= 0) then
         i = SelectPalette(hDC, hPalette, .FALSE.)
         i = RealizePalette(hDC)
       end if
       i = SetDIBitsToDevice(hDC, 0,0, ix,iy, 0,0, 0,iy, &
           LOC(Buffer)+Bf%bfOffBits-ISZBf, Bi, DIB_RGB_COLORS)
     end if
     b = EndPaint(hWnd, ps)             ! <== BeginPaint
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case (101) ! Open
       if (isize /= 0) then
         DEALLOCATE (Buffer)
         if (hPalette /= 0) i = DeleteObject(hPalette)
         hPalette = 0
         isize = 0
       end if
       filename=""C
       ofn%lStructSize = SIZEOF(ofn)
       ofn%hwndOwner   = hWnd
       ofn%hInstance   = hInst
       ofn%lpstrFilter = LOC(filter)
       ofn%lpstrCustomFilter = NULL
       ofn%nMaxCustFilter = 0
       ofn%nFilterIndex = 1             ! Specifies initial filter value
       ofn%lpstrFile   = LOC(fileName)
       ofn%nMaxFile    = SIZEOF(fileName)
       ofn%nMaxFileTitle = 0
       ofn%lpstrInitialDir = LOC("C:"C) ! (NULL:Windows default directry)
       ofn%lpstrTitle  = LOC(""C)
       ofn%Flags       = OFN_PATHMUSTEXIST
       ofn%lpstrDefExt = LOC("bmp"C)
       ofn%lpfnHook    = NULL
       ofn%lpTemplateName = NULL
       istat = GetOpenFileName(ofn)
       if (istat == 0) then
         i = MessageBox(hWnd, "No file name specified"C, "Open"C, MB_OK)
         MainWndProc = 0
         return
       end if
   !...Open File
       hF = CreateFile(fileName,GENERIC_READ,0,null_security_attributes, &
            OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,NULL)
       if (hF == INVALID_HANDLE_VALUE) then
         i = MessageBox(hWnd, "File Open Error"C, "Open"C, MB_OK)
         MainWndProc = 0
         return
       end if
   !...Read BITMAPFILEHEADER
       ISZBf = SIZEOF(Bf)
       b = ReadFile(hF,LOC(Bf),ISZBf,LOC(iResult),null_overlapped)
   !...Alloc Memory & Read BITMAPINFO and Image Data
       isize = Bf%bfSize - ISZBf
       ALLOCATE (Buffer(isize))
       b = ReadFile(hF,LOC(Buffer),isize,LOC(iResult),null_overlapped)
       pBi = LOC(Buffer)
       ix = Bi%bmiHeader%biWidth
       iy = Bi%bmiHeader%biHeight
   !...if not 24 bits color, do CreatePalette
       if (Bi%bmiHeader%biBitCount /= 24) then
         ic = Bi%bmiHeader%biClrUsed
         if (ic == 0) ic = 2 ** Bi%bmiHeader%biBitCount
         prgb = LOC(Buffer)+SIZEOF(Bi%bmiHeader)
         pLogPal = LOC(Pal)
         LogPal%palVersion = Z"0300"
         LogPal%palNumEntries = ic
         do j=1,ic
           LogPal%palPalEntry(j).peRed  = rgbq%rgbRed
           LogPal%palPalEntry(j).peGreen= rgbq%rgbGreen
           LogPal%palPalEntry(j).peBlue = rgbq%rgbBlue
           LogPal%palPalEntry(j).peFlags= 0
           prgb = prgb + 4
         end do
         hPalette = CreatePalette(LogPal);
       end if
       i = CloseHandle(hF)
       i = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
     case (109)  ! Exit
       i = SendMessage(hWnd, WM_CLOSE, 0, 0)
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

 WinMain関数は,メニューハンドルhmenuを定義し,LoadMenu関数でリソースファイルに定義したメニュー(MYMENU)のハンドルを取得しています。 取得したハンドルは,CreateWindowEx関数のパラメータに指定します。 その他は,Windowの名前をBITMAP02に変更した以外は前章の例と同じです。

 MainWndProc関数は,プログラムの構造を分かり易くするためサブルーチンを多用しない形で書いてあります。 まず,OPENFILENAME構造体,BITMAPFILEHEADER構造体,BITMAPINFO構造体,RGBQUAD構造体,LOGPALETTE構造体を定義しています。 また,ビットマップを読み込むALLOCATABLE属性のバッファ領域,ファイル名を取得する領域,論理パレットを定義する領域,ファイル名のフィルタ,その他の必要な変数を定義しています。

 手続き部は,受け取ったメッセージの内容に従って,以下の処理を行います。

・WM_CREATE
Windowが作られたときに実行する部分で,インスタンスハンドルを取得し,必要な変数の初期化を行います。
・WM_CLOSE
Windowを閉じるときに実行する部分で,確保したバッファの解放,パレットの解放を行い,Windowの破棄を行います。
・WM_DESTROY
戻り値のないPostQuitMessage関数を実行し,WM_QUITメッセージをポストします。
・WM_PAINT
画面表示を行う処理をBeginPaint関数とEndPaint関数の間に記述します。 パレットを用いる画像を表示する場合には,SelectPalette関数とRealizePalette関数を実行し画面がアクティブなときにパレットを有効にします。 読み込んだビットマップ画像があるときには,SetDIBitsToDevice関数を実行し画面に表示します。
・WM_COMMAND
コマンドを処理する部分で,更にここではwParamの下位2バイトを調べ,コマンドのコードによって行う処理を記述します。
(101)はリソースファイルで定義したメニューの'Open'を選択した場合の手続きを記述します。 既にビットマップを読み込んでいる場合には,一旦バッファを解放し,パレットがあれば解放します。 OPENFILENAME構造体に必要な値をセットし,GetOpenFileName関数を実行します。
FlagsにOFN_PATHMUSTEXITを指定していますが,有効なパス及びファイル名しか入力できないようにするフラグです。 GetOpenFileName関数を実行すると図5.4のようなダイアログが表示されファイル名の入力を促します。
CreateFile関数は,ファイルを入力モードでオープンしています。
最初のReadFile関数では,ビットマップファイルのBITMAPFILEHEADERを読み込んで必要なバッファのサイズを計算しています。
FortranのALLOCATE文を実行し,ビットマップデータを読み込むバッファを確保し,BITMAPINFOからイメージデータまでを読み込みます。 BITMAPINFOからは,画像のサイズの情報を取得します。
24ビットのフルカラー以外の画像では,RGBQUADが存在するのでこの情報を基にLOGPALETTE構造体に値をセットし,CreatePalette関数を実行してパレットハンドルを取得します。
CloseHandle関数で,ファイルをクローズします。
InvalidateRect関数を実行し,画面をクリアします。
(109)はメニューの'Exit'を選択した場合で,WM_CLOSEメッセージを発行しWM_CLOSEに処理を依頼します。

Fortran90/95の文法では,C/C++のようにポインタ変数を用いて仮想変数を実領域に割り当てることができません。 Windows APIではBITMAPINFO構造体などのように実態のない構造体を実領域に割り当てて用いる場合が多々あります。
 Visual Fortranでは,これを実現するために整数型ポインタ変数を独自に採用しています。 使用方法は次のようにして用います。

   type (T_BITMAPINFO) Bi
   pointer (pBi, Bi)

   pBi = LOC(Buffer)
   ix = Bi%bmiHeader%biWidth
   iy = Bi%bmiHeader%biHeight
 


目次 次の項目


6.画面のスクロール


6.1 画面のスクロール

 前章のプログラムでは,画像の大きさがウィンドウのサイズより大きい場合には画像の隠れた部分を見ることはでません。 ほとんどの画像表示のできるアプリケーションプログラムではウィンドウをスクロールするスクロールバーがついています。 そこで,前章のプログラムにスクロール機能を追加してみます。

図6.1 画面のスクロール

6.2 スクロールバーを付ける

 スクロールバーを付けるには,SCROLLINFO構造体に値をセットし,SetScrollInfo関数を実行します。 ウィンドウのサイズが変更された場合のクライアント領域のサイズは,GetClientRect関数を実行して取得しておきます。

・SCROLLINFO構造体
 SCROLLINFO構造体は,スクロール情報を格納します。

   type  T_SCROLLINFO
       integer Size       ! 構造体のサイズ
       integer Mask       ! 取得するスクロールバーのパラメータ
       integer Min        ! 最小スクロール位置
       integer Max        ! 最大スクロール位置
       integer Page       ! ページサイズ
       integer Pos        ! つまみ位置
       integer TrackPos   ! スクロール位置の直接指定
   end type  T_SCROLLINFO

 Maskパラメータでは,次の値の1つ又は任意の組み合わせを指定します。

   SIF_ALL              SIF_PAGE,SIF_POS,SIF_RANGE,SIF_TRACKPOSのすべてを設定します。
   SIF_DISABLENOSCROLL  スクロールバーが不要になる場合,スクロールバーを削除しないで無効にします。
   SIF_PAGE             Pageパラメータで,スクロールページのサイズを設定します。
   SIF_POS              Posパラメータで,スクロール位置を設定します。
   SIF_RANGE            MinとMaxパラメータで,スクロール範囲を設定します。
   SIF_TRACKPOS         TrackPosパラメータに,スクロールバーの位置を含むことを設定します。

・SetScrollInfo関数
 SCROLLINFO構造体に値をセットすることで,スクロールできる最小・最大位置,ページサイズ,スクロールボックス(つまみ)の位置などを設定します。

    integer function SetScrollInfo(hWnd,fnBar,lpsi,fRedraw)
     integer   hWnd          ! ウィンドウのハンドル
     integer   fnBar         ! スクロールバーのタイプ
     type(T_SCROLLINFO) lpsi ! SCROLLINFO構造体
     logical(4) fRedraw      ! 再描画フラグ

    fnBar :スクロールバーのタイプを指定します。次の値のいずれかを指定します。
     SB_CTL   スクロールバーコントロールのパラメータを設定します。
     SB_HORZ  水平スクロールバーのパラメータを設定します。
     SB_VERT  垂直スクロールバーのパラメータを設定します。

    fRedraw :スクロールバーに発生した変更結果に応じて,スクロールバーを再描画するか否かを指定します。
     TRUEを指定すると再描画されます。FALSEを指定すると再描画されません。

    戻り値:スクロールバーの現在のスクロール位置が返ります。

・GetClientRect関数
 GetClientRect関数は,ウィンドウのクライアント領域の座標を取得します。

    logical(4) function  GetClientRect (hWnd,lpRect)
     integer        hWnd     ! ウィンドウのハンドル
     type (T_RECT)  lpRect   ! RECT構造体

    戻り値:成功するとTRUE。失敗するとFALSEが返ります。

6.3 画面をスクロールする

 スクロ−ルバーを付けただけでは画面はスクロ−ルしません。 WndProc関数の中で,スクロールバーをクリックしたときのコマンドを処理する手続きを記述します。

・ScrollWindowEx関数
 指定したウィンドウのクライアント領域の内容をスクロールします。

    integer function ScrollWindowEx(hWnd,dx,dy,prcScroll,prcClip,hrgnUpdate,prcUpdate,flags)
     integer         hWnd       ! ウィンドウのハンドル
     integer         dx         ! 水平方向のスクロール量
     integer         dy         ! 垂直方向のスクロール量
     type(T_RECT)    prcScroll  ! クライアント領域
     type(T_RECT)    prcClip    ! クリッピング長方形
     integer         hrgnUpdate ! 更新リージョンのハンドル
     type(T_RECT)    prcUpdate  ! 無効にするべきリージョン
     integer         flags      ! スクロールオプション

    flagsパラメータは,スクロール方法を制御するフラグで,次の値の何れかを指定します。
     SW_ERASE          SW_INVALIDATEフラグと共に指定し,スクロール後無効になった領域を消去します。
     SW_INVALIDATE     スクロール後,hrgnUpdateパラメータが識別する領域を無効にします。
     SW_SCROLLCHILDREN prcScrollパラメータが指す矩形領域と重なる全ての子ウィンドウをスクロールします。
                       dxとdyの各パラメータで指定したピクセル数だけ,子ウィンドウをスクロールします。
     SW_SMOOTHSCROLL   flagsパラメータのHIWORD部分で,スムーズスクロール操作を行う回数を指定します。

    戻り値:関数が成功すると,リージョン情報が返ります。 失敗すると,ERRORが返ります。

 どれだけスクロールさせるかは,スクロールバーの押されたボタン(スクロール矢印,スクロールボックス,スクロールシャフト)によってdx又はdyに値を設定します。

・InvalidateRect関数
 InvalidateRect関数は,再描画が必要なクライアント領域に矩形領域を追加します。
 クライアント領域をクリアして再描画する場合などに用います。

    logical function InvalidateRect(hWnd,lpRec,bErase)
     integer         hWnd    ! ウィンドウのハンドル
     type(T_RECT)    lpRect  ! 矩形領域の座標
     logical(4)      bErase  ! 消去するかどうかの状態

    bErase    更新リージョンを処理するときに,更新リージョン内の背景を消去するかどうかを指定します。
     TRUE を指定すると,BeginPaint関数を呼び出したときに背景が消去されます。
     FALSE を指定すると,背景はそのまま残ります。

   戻り値:成功するとTRUE。失敗するとFALSEが返ります

6.4 グローバル変数領域

 Fortran90から各サブルーチンで共有している変数や配列は,module定義によってグローバル変数(配列)として用いることができます。 旧Fortran77以前では,各サブルーチンから共通に用いる領域はcommon文によって定義していました。 common文は将来的にはmodule定義に統一されるようです。
 Windowsプログラムでは,インスタンスハンドルやウィンドウのクライアント領域の座標など各サブルーチンで共通に用いる変数はグローバル変数にしておくと便利です。

 グローバル変数は,他のプログラムとは独立に,module文からend module文の間に記述します。 グローバル変数を引用しているプログラム・モジュールではuse文をプログラムの先頭に記述することによって引用を宣言します。

 記述例

    module WINCOM
    use dfwina
    type (T_RECT) grect
    integer*4  ghinst, gwx, gwy, ghPos, gvPos
    end module

    integer function MainWndProc(hWnd, mesg, wParam, lParam)
    !DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
    use WINCOM
    .....
    b = GetClientRect(hWnd, grect)

6.5 プログラム例

!*********************************************************************
!  Module definition
!*********************************************************************
module WINCOM
use dfwina
type (T_RECT) grect
integer*4  ghinst, gwx, gwy, ghPos, gvPos
end module

!*********************************************************************
!  WinMain
!        2001.09.07  2001.10.01  Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WINCOM
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="SCROLL"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0
      wc%hInstance    = hInstance
      wc%hIcon        = NULL
      wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   hmenu = LoadMenu(hInstance, LOC("MYMENU"C))
   ghinst = hInstance
!
   hWnd = CreateWindowEx(0, lpszClassName,  &
                  "SCROLL"C,                &
                  INT(WS_OVERLAPPEDWINDOW), &
                  CW_USEDEFAULT,            &
                  0,                        &
                  CW_USEDEFAULT,            &
                  0,                        &
                  NULL,                     &
                  hmenu,                    &
                  hInstance,                &
                  NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
!
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use WINCOM

integer hWnd, mesg, wParam, lParam

type (T_PAINTSTRUCT) ps

integer hInst, hDC
logical b
!
   select case (mesg)
   case (WM_CREATE)
!    hInst = GetWindowLong(hWnd, GWL_HINSTANCE)
   case (WM_CLOSE)
     call BMPCLS(hWnd)
     i = DestroyWindow(hWnd)
   case (WM_DESTROY)
     call PostQuitMessage(0)
   case (WM_SIZE)
     b = GetClientRect(hWnd, grect)
     call SetScrollRanges(hWnd)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)         ! ==> EndPaint
     call BMPDSP(hWnd,hDC)
     b = EndPaint(hWnd, ps)             ! <== BeginPaint
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case (101) ! Open
       call BMPOPN(hWnd)
       call SetScrollRanges(hWnd)
       i = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
     case (109)  ! Exit
       i = SendMessage(hWnd, WM_CLOSE, 0, 0)
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case (WM_VSCROLL)
     call vScrollBar(hWnd, wParam)
   case (WM_HSCROLL)
     call hScrollBar(hWnd, wParam)
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

!*********************************************************************
!*  BMPOPN SUBROUTINE called by Open menu.
!*********************************************************************
subroutine BMPOPN(hWnd)
use WINCOM

integer*4 hWnd, hDC, hF

type (T_OPENFILENAME) ofn
type (T_BITMAPFILEHEADER) Bf

type (T_BITMAPINFO) Bi
pointer (pBi, Bi)

type (T_RGBQUAD) rgbq
pointer (prgb, rgbq)

type (T_LOGPALETTE) LogPal
pointer (pLogPal, LogPal)

character, ALLOCATABLE, SAVE :: Buffer(:)
logical*4  b
character  filename*100, Pal*1028
character*80 :: filter = "BMP Files"C//"*.bmp"C
integer    isize/0/,hpalette/0/
    if (isize /= 0) then
      DEALLOCATE (Buffer)
      if (hPalette /= 0) i = DeleteObject(hPalette)
      hPalette = 0
      isize = 0
    end if
    filename=""C
    ofn%lStructSize = SIZEOF(ofn)
    ofn%hwndOwner   = hWnd
    ofn%hInstance   = ghInst
    ofn%lpstrFilter = LOC(filter)
    ofn%lpstrCustomFilter = NULL
    ofn%nMaxCustFilter = 0
    ofn%nFilterIndex = 1             ! Specifies initial filter value
    ofn%lpstrFile   = LOC(fileName)
    ofn%nMaxFile    = SIZEOF(fileName)
    ofn%nMaxFileTitle = 0
    ofn%lpstrInitialDir = LOC("C:"C) ! (NULL:Windows default directry)
    ofn%lpstrTitle  = LOC(""C)
    ofn%Flags       = OFN_PATHMUSTEXIST
    ofn%lpstrDefExt = LOC("bmp"C)
    ofn%lpfnHook    = NULL
    ofn%lpTemplateName = NULL
    istat = GetOpenFileName(ofn)
    if (istat == 0) then
      i = MessageBox(hWnd, "No file name specified"C, "Open"C, MB_OK)
      return
    end if
    if (isize /= 0) then
      DEALLOCATE (Buffer)
      if (hPalette /= 0) i = DeleteObject(hPalette)
      hPalette = 0
      isize = 0
    end if
!...Open File
    hF = CreateFile(fileName,GENERIC_READ,0,null_security_attributes, &
         OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,NULL)
    if (hF == INVALID_HANDLE_VALUE) then
      i = MessageBox(hWnd, "File Open Error"C, "Open"C, MB_OK)
      return
    end if
!...Read BITMAPFILEHEADER
    ISZBf = SIZEOF(Bf)
    b = ReadFile(hF,LOC(Bf),ISZBf,LOC(iResult),null_overlapped)
!...Alloc Memory, Read BITMAPINFO and Image Data
    isize = Bf%bfSize - ISZBf
    ALLOCATE (Buffer(isize))
    b = ReadFile(hF,LOC(Buffer),isize,LOC(iResult),null_overlapped)
    pBi = LOC(Buffer)
    gwx = Bi%bmiHeader%biWidth
    gwy = Bi%bmiHeader%biHeight
!...if not 24 bits color, do CreatePalette
    if (Bi%bmiHeader%biBitCount /= 24) then
      ic = Bi%bmiHeader%biClrUsed
      if (ic == 0) ic = 2 ** Bi%bmiHeader%biBitCount
      prgb = LOC(Buffer)+SIZEOF(Bi%bmiHeader)
      pLogPal = LOC(Pal)
      LogPal%palVersion = Z"0400"
      LogPal%palNumEntries = ic
      do j=1,ic
        LogPal%palPalEntry(j).peRed  = rgbq%rgbRed
        LogPal%palPalEntry(j).peGreen= rgbq%rgbGreen
        LogPal%palPalEntry(j).peBlue = rgbq%rgbBlue
        LogPal%palPalEntry(j).peFlags= 0
        prgb = prgb + 4
      end do
      hPalette = CreatePalette(LogPal)
    end if
    i = CloseHandle(hF)
    ghPos = 0
    gvPos = 0
    return
!=====================================================================
!   ENTRY BMPDSP  called by WM_PAINT
!=====================================================================
entry BMPDSP(hWnd,hDC)
    if (isize /= 0) then
      if (hPalette /= 0) then
        i = SelectPalette(hDC, hPalette, .FALSE.)
        i = RealizePalette(hDC)
      end if
      i = SetDIBitsToDevice(hDC, -ghPos,-gvPos, gwx,gwy, 0,0, 0,gwy, &
          LOC(Buffer)+Bf%bfOffBits-ISZBf, Bi, DIB_RGB_COLORS)
    end if
    return
!=====================================================================
!   ENTRY CLSBMP  called by WM_DESTROY
!=====================================================================
entry BMPCLS(hWnd)
    if (isize /= 0) DEALLOCATE(Buffer)
    if (hPalette /= 0) i = DeleteObject(hPalette)
    return
end

!*********************************************************************
!*  SetScroolRanges subroutine.
!*********************************************************************
subroutine SetScrollRanges(hWnd)
use WINCOM
type (T_SCROLLINFO) sih, siv
integer*4 hWnd, wParam, dx, dy, RangeX, RangeY
logical b
    gvPos = 0
    siv%Size = SIZEOF(siv)    ! Size of Info structure
    siv%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    siv%Min = 0               ! Minimum scrolling position
    siv%Max = gwy             ! Maximum scrolling position
    siv%Page= grect%bottom - grect%top ! Page scroll size
    siv%Pos = 0               ! Position of the scroll box
    RangeY  = gwy - siv%Page  ! Scrolling range
    i = SetScrollInfo (hWnd, SB_VERT, siv, .TRUE.)
!
    ghPos = 0
    sih%Size = SIZEOF(sih)    ! Size of Info structure
    sih%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    sih%Min = 0               ! Minimum scrolling position
    sih%Max = gwx             ! Maximum scrolling position
    sih%Page = grect%right - grect%left ! Page scroll size
    sih%Pos = 0               ! Position of the scroll box
    RangeX  = gwx - sih%Page  ! Scrolling range
    i = SetScrollInfo (hWnd, SB_HORZ, sih, .TRUE.)
    return
!=====================================================================
!*  vScroolBar Entry subroutine.
!=====================================================================
entry vScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINEUP)
      dy = -5
    case (SB_LINEDOWN)
      dy = 5
    case (SB_PAGEUP)
      dy = -siv%Page
    case (SB_PAGEDOWN)
      dy = siv%Page
    case (SB_THUMBPOSITION)
      dy = HiWord(wParam) - siv%Pos
    case (SB_THUMBTRACK)
      dy = HiWord(wParam) - siv%Pos
    case default
      dy = 0
    end select
    dy = MAX(-siv%Pos, MIN(dy, RangeY - siv%Pos))
    if(dy /= 0) then
      siv%Pos = siv%Pos + dy
      gvPos = siv%Pos
      i = SetScrollInfo(hWnd, SB_VERT, siv, .TRUE.)
      i = ScrollWindowEx(hWnd, 0, -dy, grect, grect, 0, &
                         NULL_RECT, SW_INVALIDATE)
    end if
    return
!=====================================================================
!*  hScrollBar Subroutine Entry.
!=====================================================================
entry hScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINELEFT)
      dx = -10
    case (SB_LINERIGHT)
      dx = 10
    case (SB_PAGELEFT)
      dx = -sih%Page
    case (SB_PAGERIGHT)
      dx = sih%Page
    case (SB_THUMBPOSITION)
      dx = HiWord(wParam) - sih%Pos  ! wParam : pushout position
    case (SB_THUMBTRACK)
      dx = HiWord(wParam) - sih%Pos  ! wParam : tracking position
    case default
      dx = 0
    end select
    dx = MAX(-sih%Pos, MIN(dx, RangeX - sih%Pos))
    if(dx /= 0) then
      sih%Pos = sih%Pos + dx
      ghPos = sih%Pos
      i = SetScrollInfo(hWnd, SB_HORZ, sih, .TRUE.)
      i = ScrollWindowEx(hWnd, -dx, 0, NULL_RECT, grect, 0, &
                        NULL_RECT, SW_INVALIDATE)
    end if
    return
end

 プログラムの先頭部分は,グローバル変数を宣言するmodule定義で,WINCOMという名前を付けています。 クライアント領域の座標,インスタンスハンドル,画像のサイズ,スクロール位置などを定義しています。

 WinMain関数は,システムから渡されたインスタンスハンドルをグローバル変数にコピーしている以外は前章のプログラムとほぼ同じです。 インスタンスハンドルは,BMPOPNサブルーチンのなかでOPENFILENAME構造体のパラメータに指定します。

 MainWndPorc関数では,グローバル変数を引用しているので,use文でWINCOMを指定しています。 PAINTSTRUCT構造体と他の必要な変数の宣言をしています。

 手続き部は,各処理内容ごとにサブルーチン化しましたので,前章のプログラムに比べるとすっきりとしています。 ここでは,受け取ったメッセージの内容に従って,以下の処理を行います。

・WM_CREATE
インスタンスハンドルはWinMain関数の中でグローバル変数にコピーしましたので,ここでは特に何も実行していませんが,後々のために残してあります。
・WM_CLOSE
画像表示の後処理を行う自前のサブルーチンBMPCLSを実行しています。
DestroyWindow関数を実行しWindowの破棄を行います。
・WM_DESTROY
戻り値のないPostQuitMessage関数を実行し,WM_QUITメッセージをポストします。
・WM_SIZE
前章のプログラムにはありませんでしたが,ウィンドウのサイズを変更したときに発せられるメッセージを処理します。
GetClientRect関数を実行し,変更されたクライアントウィンドウの座標値を取得し,グローバル領域のRECT構造体にセットしています。
自前のSetScrollRangesサブルーチンを実行し,スクロールに必要な情報をセットします。 InvalidateRect関数を実行し,クライアントウィンドウを再表示します。
・WM_PAINT
BeginPaint関数とEndPaint関数の間に,画像を表示する自作のBMPDSPサブルーチンを実行しています。 BeginPaint関数で取得したデバイスコンテキストをBMPDSPサブルーチンに渡しています。
・WM_COMMAND
wParamの下位2バイトを調べ,コマンドのコードによって行う処理を記述します。
(101)は,メニューの'Open'を選択した場合の手続きを記述しています。
ビットマップ画像ファイルを選択しオープンを行う自作のBMPOPNサブルーチンを実行しています。
自前のSetScrollRangesサブルーチンを実行し,読み込んだビットマップ画像のサイズを基にスクロール情報をセットします。
ウィンドウの背景をクリアするため,TRUEオプションを指定し,InvalidateRect関数を実行します。 この関数を実行しないと,以前表示していた画像より小さい画像を表示すると前の画像の一部が残ってしまいます。
(109)は,メニューの'Exit'を選択した場合の手続きで,SendMessage関数でWM_CLOSEメッセージを発行しWM_CLOSEの処理を行うように指定します。

 BMPOPNサブルーチンでは,ファイル名入力のダイアログを表示し,ビットマップ画像ファイルを読み込む手続きを記述しています。 内容は前章の解説を参照してください。

 BMPDSPルーチンは,BMPOPNサブルーチンのENTRYで,MainWndProc関数のWM_PAINTメッセージを受け取ったときに呼ばれ,読み込んだ画像データがある場合に画面表示を行います。

 BMPCLSルーチンは,BMPOPNサブルーチンのENTRYで,MainWndProc関数のWM_CLOSEメッセージを受け取ったときに呼ばれ,読み込んだ画像データやカラーパレットがあれば領域やオブジェクトを開放します。

 SetScrollRangesサブルーチンでは,SCROLLINFO構造体にスクロールバーの必要な機能や情報を指定しています。 このプログラムでは,スクロール位置の最小最大値,ページスクロールサイズ,スクロールボタンの位置を設定します。 MASKパラメータにはこれに対応してSIF_POS, SIF_RANGE, SIF_PAGEを指定しています。
 SetScrollInfo関数を実行し,SCROLLINFO構造体に従ってスクロールが必要なときにはスクロールバーの表示を行います。

 vScrollBarルーチンは,SetScrollRangesサブルーチンのENTRYで,垂直方向のスクロール処理を行います。 wParamの下位ワードのコードを調べ,スクロールバーのボタン操作によってスクロールする量をdy変数にセットしています。 スクロールする値が大き過ぎないように dy = MAX(-siv%Pos, MIN(dy, RangeY - siv%Pos))で最大値を計算しています。
 SCROLLINFO構造体にスクロール位置を設定し,画像を表示するSetDIBitsToDevice関数で用いるグローバル変数にも位置情報をコピーしておきます。
 SetScrollInfo関数でスクロールバーを更新します。  ScrollWindowEx関数でクライアント領域をスクロールします。  ここのところの対応がうまくいかないとスクロールが正しく行われません。
 hScrollBarルーチンは,同様に水平方向のスクロール処理を行います。


Windowsプログラムのデバッグ
 Windowsプログラムを作成しているとき,プログラムの途中で変数の値を確認するには,MessageBox関数を使うと便利です。


目次 次の項目

7.アイコンの作成


7.1 専用アイコンの付いたウィンドウ

 今までに作成したプログラムには,ウィンドウの標準アイコンがついていますが,図7.1のように専用のアイコンの付いたウィンドウを作ってみます。

図7.1 アイコンの付いたウィンドウ

7.2 アイコンの作成

 アイコンを作成するには,Developer StudioのFileメニューからNewを選択し,FilesメニューからIcon Fileを選択し,File name,Location等を指定すると,図7.2のようなアイコン作成ウィンドウが表示されます。 同時に表示されるパレットとペンを使って任意のアイコンを作画します。

   

図7.2 アイコン作成画面         図7.3 作成したアイコン画面

7.3 リソーススクリプトファイルの定義

 作成したアイコンは,次のようにリソーススクリプトファイルに登録します。

    /////////////////////////////////////////////////////////////////////////////
    //
    // Icon
    //
    MYICON   ICON     DISCARDABLE  "MYICON.ico"

7.4 アイコンの入力

 リソーススクリプトファイルに定義したアイコンは,ウィンドウクラスを登録するときに,LoadIcon関数又はLoadImage関数を用いてアイコンハンドルを取得し,WNDCLASSEXA構造体のhIconパラメータに指定します。

・LoadImage関数
 LoadImage関数は,指定のファイルから,又はリソーススクリプトファイルから,アイコン,カーソル,ビットマップをロードします。 LoadIcon関数は,この関数に吸収されています。

    integer FUNCTION LoadImage(hinst,lpszName,uType,cxDesired,cyDesired,fuLoad)
     integer(4)    hinst      ! インスタンスハンドル
     character*(*) lpszName   ! ロードするイメージの名前
     integer(4)    uType      ! ロードするイメージのタイプ
     integer(4)    cxDesired  ! 幅
     integer(4)    cyDesired  ! 高さ
     integer(4)    fuLoad     ! イメージのロード方法

     uType には,以下の何れかを指定します。
      IMAGE_BITMAP       ビットマップをロードする。
      IMAGE_CURSOR       カーソルをロードする。
      IMAGE_ICON         アイコンをロードする。
      IMAGE_ENHMETAFILE  拡張メタファイルをロードする。

     fuLoad には,以下の何れかを指定します。
      LR_DEFAULTCOLOR    既定のフラグで何もしません。
      LR_CREATEDIBSECTION uTypeにIMAGE_BITMAPを指定したときDIBセクションビットマップが返ります。
      LR_DEFAULTSIZE     cxDesired,cyDesiredを0にしたとき,カーソル又はアイコンの幅又は高さが使われます。
      LR_LOADFROMFILE    lpszNameで指定するファイルからイメージをロードします。
      LR_LOADMAP3DCOLORS カラーテーブルを検索し,灰色の濃淡を3Dカラーに置き換えます。
      LR_LOADTRANSPARENT イメージのカラー値を取得し,対応するエントリをウィンドウカラーに置き換えます。
      LR_MONOCHROME      イメージをモノクロでロードします。
      LR_SHARED          イメージを2回以上ロードする場合に,同じハンドルを使います。
      LR_VGACOLOR        VGAフルカラー(True Color)を使います。

     戻り値:成功時はロードされたイメージのハンドル。失敗時はNULL。

7.5 プログラム例

!*********************************************************************
!  WinMain
!        2001.09.07  2001.10.04  Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WINCOM
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu, hIcon
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="SCROLL"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0
      wc%hInstance    = hInstance
!     wc%hIcon        = LoadIcon(hInstance, LOC("MYICON"C))
      wc%hIcon        = LoadImage(hInstance,"MYICON"C,IMAGE_ICON,0,0, &
                        LR_DEFAULTCOLOR)
      wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   hmenu = LoadMenu(hInstance, LOC("MYMENU"C))
   ghinst = hInstance
!
   hWnd = CreateWindowEx(0, lpszClassName,  &
                  "ICON"C,                  &
                  INT(WS_OVERLAPPEDWINDOW), &
                  CW_USEDEFAULT,            &
                  0,                        &
                  CW_USEDEFAULT,            &
                  0,                        &
                  NULL,                     &
                  hmenu,                    &
                  hInstance,                &
                  NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
!
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

 WinMain関数では,WNDCLASS構造体のhIconパラメータにLoadImage関数で取得したアイコンのハンドルを設定しています。 リソーススクリプトファイルには,MYICONという名前でアイコンファイルが定義してあります。 Microsoftのオンラインマニュアルによると,LoadIcon関数はLoadImage関数に吸収されるということです。 また,同様にLoadCursor関数もLoadImage関数に吸収されるということですが,Visual Fortranでは属性が異なるため,第2パラメータにMAKEINTRESOURCEマクロを用いることができません。
 その他の部分は,前章のプログラムとほぼ同じなので省略してあります。


目次 次の項目

8.カラー画像の表示


8.1 カラー画像の表示

 これまでの画像表示はビットマップ画像ファイルを読み込んで表示するものでした。 今度は計算した結果をカラー画像として表示するプログラムを作成してみましょう。 図8.1に示したサンプル画像は,フラクタル画像として有名なマンデルブロ集合を色分けして表示したものです。

図8.1 計算出力したカラー画像

8.2 カラーの定義

 COLORREF値は,RGBカラーの値を定義します。 COLORREF値を定義するときは,次のように16進標記します。

integer color
data color/z"00BBGGRR"/

8.3 関連するAPI関数

・SetPixelV関数
 SetPixelV関数は,指定したピクセル座標に指定した色に最も近い色で描画します。

  logical(4) function  SetPixelV(hDC,X,Y,crColor)
     integer hDC     ! デバイスコンテキストのハンドル
     integer X       ! X座標
     integer Y       ! Y座標
     integer crColor ! 新しいピクセルの色

   戻り値:成功するとTRUE。失敗するとFALSEが返ります

・RGB関数
 RGB関数は,赤,緑,青の3色を指定し,COLORREF値を返します。

  integer(4) function RGB(red,green,blue)
     byte   red     ! 赤
     byte   green   ! 緑
     byte   blue    ! 青

   戻り値:RGBカラーのCOLORREF値。

・GetRedValue,GetGreenValue,GetBlueValue関数
 GetRedValue関数は,RGBカラー値から赤の強度を取得します。
 同様にGetGreenValue関数は緑,GetBlueValue関数は青の強度値を取得します。

    byte function GetRedValue(color)
     integer  color   ! RGBカラー値

   戻り値:赤の強度値。

・FillRect関数
 FillRect関数は,指定された矩形領域を指定さたブラシで塗りつぶします。

    integer(4) function FillRect(hDC,lprc,hbr)
     integer hDC       ! handle to DC
     type(T_RECT) lprc ! rectangle
     integer hbr       ! handle to brush

   戻り値:成功すると非0。失敗すると0が返ります。

・GetStockObject関数
 GetStockObject関数は,ストックされたペン,ブラシ,フォント,パレットのハンドルを取得します。

    integer(4) function  GetStockObject(fnObject)
     integer fnObject ! stock object type
      fnObjectには,次の値(一部)が指定できます。
        BLACK_BRUSH  : 黒ブラシ
        WHITE_BRUSH  : 白ブラシ
        BLACK_PEN    : 黒ペン
        WHITE_PEN    : 白ペン
        ANSI_FIXED_FONT : Windows固定ピッチフォント

   戻り値:成功すると要求されたオブジェクトのハンドル。失敗するとNULL。

8.4 プログラム例

!*********************************************************************
!  Windows programming sample Fractal.
!         2001.10.12   2001.10.22    Y.Akatsuka
!*********************************************************************
module WINCOM
use dfwina
type (T_RECT) grect
type (T_POINTS) gpts

integer*4  ghinst, gwx, gwy, ghPos, gvPos, ghWnd, ghDCmem
end module

!*********************************************************************
!  WinMain
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WINCOM
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu, hIcon
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="FRACTAL"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0
      wc%hInstance    = hInstance
      wc%hIcon        = LoadImage(hInstance,"MYICON"C,IMAGE_ICON,0,0, &
                        LR_DEFAULTCOLOR)
      wc%hCursor      = LoadCursor(NULL,IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   ghinst = hInstance
!
   hWnd = CreateWindowEx(0, lpszClassName,  &
                  "FRACTAL"C,               &
                  INT(WS_OVERLAPPEDWINDOW), &
                  CW_USEDEFAULT,            &
                  0,                        &
                  CW_USEDEFAULT,            &
                  0,                        &
                  NULL,                     &
                  NULL,                     &
                  hInstance,                &
                  NULL)
   ghWnd = hWnd
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
!
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use WINCOM

integer hWnd, mesg, wParam, lParam
type (T_PAINTSTRUCT) ps
type (T_BITMAP) bm
integer hInst, hDC, hCursorA, hCursorC, hCursorW, hBmBuffer
logical b
!
   select case (mesg)
   case (WM_CREATE)
     hDC = GetDC(hWnd)     ! Get the DC of the Window
     b = GetClientRect(hWnd, grect)
     gwx = 640
     gwy = 480
     gpts%x = 0
     gpts%y = 0
     ghDCmem = CreateCompatibleDC(hDC)
     hBmBuffer = CreateCompatibleBitmap(hDC, gwx, gwy)
     i = SelectObject(ghDCmem, hBmBuffer)
     CALL CFUNC1
     hCursorA = LoadCursor(NULL,IDC_ARROW)
     hCursorC = LoadCursor(NULL,IDC_CROSS)
     hCursorW = LoadCursor(NULL,IDC_WAIT)
   case (WM_CLOSE)
     i = DeleteDC(ghDCmem)
     i = DeleteObject(hBmBuffer)
     i = DestroyWindow(hWnd)
   case (WM_DESTROY)
     call PostQuitMessage(0)
   case (WM_SIZE)
     b = GetClientRect(hWnd, grect)
     call SetScrollRanges(hWnd)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)         ! ==> EndPaint
     b = BitBlt(hDC,-ghPos,-gvPos, gwx,gwy, ghDCmem, 0, 0, SRCCOPY)
     b = EndPaint(hWnd, ps)             ! <== BeginPaint
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case (WM_VSCROLL)
     call vScrollBar(hWnd, wParam)
   case (WM_HSCROLL)
     call hScrollBar(hWnd, wParam)
   case (WM_LBUTTONDOWN)
     i = SetCursor(hCursorC)
     i = SetCapture(hWnd)
   case (WM_LBUTTONUP)
     i = ReleaseCapture()
     i = SetCursor(hCursorW)
     gpts%x = LOWORD(lParam)
     gpts%y = HIWORD(lParam)
     CALL CFUNC1
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
     i = SetCursor(hCursorA)
   case (WM_RBUTTONDOWN)
     i = SetCursor(hCursorC)
     i = SetCapture(hWnd)
   case (WM_RBUTTONUP)
     i = ReleaseCapture()
     i = SetCursor(hCursorW)
     gpts%x = LOWORD(lParam)
     gpts%y = HIWORD(lParam)
     CALL CFUNC2
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
     i = SetCursor(hCursorA)
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

!*********************************************************************
!*  SetScroolRanges subroutine.
!*********************************************************************
subroutine SetScrollRanges(hWnd)
use WINCOM
type (T_SCROLLINFO) sih, siv
integer*4 hWnd, wParam, dx, dy, RangeX, RangeY
logical b
    gvPos = 0
    siv%Size = SIZEOF(siv)    ! Size of Info structure
    siv%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    siv%Min = 0               ! Minimum scrolling position
    siv%Max = gwy             ! Maximum scrolling position
    siv%Page= grect%bottom - grect%top ! Page scroll size
    siv%Pos = 0               ! Position of the scroll box
    siv%TrackPos = 0
    RangeY  = gwy - siv%Page  ! Scrolling range
    i = SetScrollInfo (hWnd, SB_VERT, siv, .TRUE.)
!
    ghPos = 0
    sih%Size = SIZEOF(sih)    ! Size of Info structure
    sih%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    sih%Min = 0               ! Minimum scrolling position
    sih%Max = gwx             ! Maximum scrolling position
    sih%Page = grect%right - grect%left ! Page scroll size
    sih%Pos = 0               ! Position of the scroll box
    sih%TrackPos = 0
    RangeX  = gwx - sih%Page  ! Scrolling range
    i = SetScrollInfo (hWnd, SB_HORZ, sih, .TRUE.)
    return
!=====================================================================
!*  vScroolBar Entry subroutine.
!=====================================================================
entry vScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINEUP)
      dy = -5
    case (SB_LINEDOWN)
      dy = 5
    case (SB_PAGEUP)
      dy = -siv%Page
    case (SB_PAGEDOWN)
      dy = siv%Page
    case (SB_THUMBPOSITION)
      dy = HiWord(wParam) - siv%Pos
    case (SB_THUMBTRACK)
      dy = HiWord(wParam) - siv%Pos
    case default
      dy = 0
    end select
    dy = MAX(-siv%Pos, MIN(dy, RangeY - siv%Pos))
    if(dy /= 0) then
      siv%Pos = siv%Pos + dy
      gvPos = siv%Pos
      i = SetScrollInfo(hWnd, SB_VERT, siv, .TRUE.)
      i = ScrollWindowEx(hWnd, 0, -dy, grect, grect, 0, &
                         NULL_RECT, SW_INVALIDATE)
    end if
    return
!=====================================================================
!*  hScrollBar Subroutine Entry.
!=====================================================================
entry hScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINELEFT)
      dx = -10
    case (SB_LINERIGHT)
      dx = 10
    case (SB_PAGELEFT)
      dx = -sih%Page
    case (SB_PAGERIGHT)
      dx = sih%Page
    case (SB_THUMBPOSITION)
      dx = HiWord(wParam) - sih%Pos  ! wParam : pushout position
    case (SB_THUMBTRACK)
      dx = HiWord(wParam) - sih%Pos  ! wParam : tracking position
    case default
      dx = 0
    end select
    dx = MAX(-sih%Pos, MIN(dx, RangeX - sih%Pos))
    if(dx /= 0) then
      sih%Pos = sih%Pos + dx
      ghPos = sih%Pos
      i = SetScrollInfo(hWnd, SB_HORZ, sih, .TRUE.)
      i = ScrollWindowEx(hWnd, -dx, 0, NULL_RECT, grect, 0, &
                        NULL_RECT, SW_INVALIDATE)
    end if
    return
end

!********************************************************************
!*   CFUNC1   pushed left button
!********************************************************************
SUBROUTINE CFUNC1
use  WINCOM
integer COL(0:7)/Z"00FF0000",Z"0000FF00",Z"000000FF",Z"00FFFF00", &
                 Z"00FF00FF",Z"0000FFFF",Z"00FFFFFF",Z"00777777"/
logical b
DATA  X0,Y0,W,BK,MX/2*0.0,0.01,10.0,80/
      IF(gpts%x.eq.0 .and. gpts%y.eq.0)GO TO 2
      GO TO 1
!==================================================================
!    CFUNC2   pushed right button, calculate function.
!==================================================================
ENTRY CFUNC2
      W  = W*0.5
      BK = BK*1.5
      MX = MX+MX/2
    1 X0 = X0+FLOAT(gpts%x-gwx/2)*WW
      Y0 = Y0+FLOAT(gwy/2-gpts%y)*WW
    2 WW = W
      b = FillRect(ghDCmem, grect, GetStockObject(BLACK_BRUSH))
      IHWX = gwx / 2
      IHWY = gwy / 2
      DO 10 J=1, gwy
      V = FLOAT(IHWY-J)*WW+Y0
      DO 20 I=1, gwx
      U = FLOAT(I-IHWX)*WW+X0
      X = 0.0
      Y = 0.0
      DO 30 L=1,MX
      ZX= X*X-Y*Y+U
      ZY= X*Y*2.0+V
      X = ZX
      Y = ZY
      IF(X*X+Y*Y.GT.BK)GO TO 3
   30 CONTINUE
      GO TO 20
    3 b = SetPixelV(ghDCmem,I,J,COL(MOD(L,8)))
   20 CONTINUE
   10 CONTINUE
      RETURN
      END

 このプログラムは,簡単な複素関数を反復計算し,得られた絶対値を適当な閾値によって色分けしたものです。 スクロール機能は付いています。 また,次章で解説するカーソルを表示し座標値を入力するための機能を付けてあります。 計算を更に続けて表示されたある部分を拡大してみると,似たような図形を得ることができます。 このような図形をフラクタル図形と呼びます。

 プログラムは,グローバル変数をモジュール文を用いて定義しています。 POINTS構造体はマウスでポイントしたときのウィンドウ座標を設定する領域ですが,このプログラムでは特に構造体にする必要はありません。 その他の共通変数には,プログラムのインスタンスハンドル,表示する画像の幅と高さ,スクロールバーのポイント座標,ウィンドウハンドル,それにこのプログラムで初めて用いるメモリーデバイス・コンテキストのハンドルを定義しています。

 WinMain関数は,Windowの名前をFRACTALに変更した以外は特に変わったところはありません。

 MainWndProc関数は,今までと同様にメッセージの処理を記述します。 PAINTSTRUCT構造体,BITMAP構造体を定義しています。 また,3種類のカーソルのハンドル,ビットマップバッファのハンドル,その他の必要な変数を定義しています。

 手続き部は,受け取ったメッセージの内容に従って,以下の処理を行います。

・WM_CREATE
Windowが作られたときに実行する部分で,デバイスコンテキストを取得し,必要な変数の初期化を行います。GetClientRect関数を用いて,ウィンドウのクライアント領域のサイズを取得します。画面表示を高速化するために,CreateCompatibleDC関数を用いて,デバイスコンテキストに互換のあるメモリデバイスコンテキストを作成します。CreateCompatibleBitmap関数でデバイスコンテキストに互換のあるビットマップを作成し,SelectObject関数を用いて取得したメモリデバイスコンテキストに選択します。
CFUNC1という画像を計算表示するサブルーチンを実行し,初期画面を表示します。
LoadCursor関数を実行し,3種類のカーソルのハンドルを取得しておきます。
・WM_CLOSE
DeleteDC関数でメモリデバイスコンテキストを削除し,DeleteObject関数で互換ビットマップを削除します。DestroyWindow関数でウィンドウを閉じます。
・WM_DESTROY
PostQuitMessage関数を実行し,プログラムを終了させます。
・WM_SIZE
ウィンドウサイズを変更したときに実行され,新しいクライアント領域のサイズを取得し,SetScrollRangesサブルーチンを実行してスクロールバーの設定を行います。.FALSE.パラメータを指定したInvalidateRect関数を実行し画面を再表示します。
・WM_PAINT
メモリデバイスコンテキストに作画した画像をBitBlt関数を用いて画面に表示します。
・WM_COMMAND
コマンドを処理する手続きですが,ここでは特に記述することはありません。DefWindowProc関数でデフォルト処理をWindowsにまかせます。
・WM_VSCROLL,WM_HSCROLL
ウィンドウのスクロールボタンを操作したときの手続きです。それぞれvScrollBarサブルーチンとhScrollBarサブルーチンに処理を任せます。
・WM_LBUTTONDOWN
マウスの左ボタンを押したときの処理で,SetCursor関数を実行し,クロスヘアカーソルを表示します。SetCapture関数を実行し,座標値のキャプチャーを可能にします。ウィンドウの内部だけのキャプチャーであれば,特にこの関数を実行する必要はありません。
・WM_LBUTTONUP
押されたマウスの左ボタンを離したときの処理で,ReleaseCapture関数でキャプチャーを終了します。SetCursor関数を実行し,次に時間のかかる処理を実行するので砂時計マークのカーソルを表示します。lParamの値からボタンを離したときの座標値を取得しグローバル変数gptsにセットしておきます。CFUNC1というサブルーチンを実行し,得られた座標値を中心とする画像を計算します。InvalidateRect関数で画面を再表示し,SetCursor関数でカーソルを標準の矢印に戻します。
・WM_RBUTTONDOWN
マウスの右ボタンを押したときの処理で,左ボタンを押したときと同様の処理を行います。
・WM_RBUTTONUP
押されたマウスの右ボタンを離したときの処理で,左ボタンの場合と同様の処理を行います。異なるのはCFUNC2を実行するところです。CFUNC2では画像を拡大するように計算します

 画面のスクロールに関する記述は,第6章を参照してください。

 画像を計算するサブルーチンCFUNC1では,初期値又は指定された座標値に基づいてマンデルブロ集合を計算します。CFUNC2では,指定された座標値を中心として更に拡大するように値を設定し,計算の反復回数も増やしています。FillRect関数は画面を黒く塗りつぶすために実行します。ここでは,f(z)=z2+cという簡単な有利関数を用いています。画面の座標値をcの実部と虚部に対応させ,zの実部と虚部を初期値を0にして一定回数反復計算し,絶対値が閾値を超えたときの反復回数でSetPixelV関数を用いて色分けします。初期値や閾値を変えたり色の指定を変えると変化に富んだ画像が得られます。
 その他に,次のような関数を用いると興味深い画像が得られるようです。
 ・f(z)=cz(1-zk) k=0,±1,±2,…
 ・f(z)=czk/(1+z2) k=0,1,2,…
 ・f(z)=zk(z-c)/(1-c~z) k=0,1,2,… c~はcの共役複素数


目次 次の項目

9.カーソル出力


9.1 カーソルの表示

 マウスで入力位置を指定したり,座標値を入力したりする場合にカーソルを用います。 カーソルには,WindowsのAPIに標準で用意されている矢印カーソルやクロスカーソルなどがあります。 その他にプログラム固有の任意のカーソルを作成することもできます。

図9.1 クロスカーソルを表示した例

9.2 カーソルの種類

 Windowsのシステム標準カーソルには,矢印,I型,砂時計,十字,上向き矢印,などがあります。その他に任意のパターンをカーソルにすることもできます。画像を扱うソフトでは十字カーソルを画面いっぱいに表示したり,矩形領域を囲んだりするようなカーソルを独自に作成したりしています。

9.2 関連するAPI関数

・LoadCursor関数
 LoadCursor関数は,予めシステムに用意されているカーソルや,指定したインスタンスハンドルに関連付けされた実行可能(.EXE)ファイルから指定のカーソルをロードしそのハンドルを取得します。なお,マニュアルには,この関数はLoadImage関数に置き換わるという説明がありますが,LoadImage関数を用いてシステム標準のカーソルをロードすることはできません。Fortranの制約で,定義されている引数の型の対応が取れないためです。

    integer(4) function LoadCursor(hInstance,lpCursorName)
     integer hInstance      ! EXEファイルのインスタンスハンドル
     integer lpCursorName   ! カーソル名のポインタ

   戻り値:成功時はロードしたカーソルのハンドル。失敗時はNULLが返ります。

 hInstanceには,Win32で予め定義されているカーソルをロードする場合はNULLを指定します。

 lpCursorNameに指定できる予め定義されている主なカーソルは以下のとおりです。
   IDC_ARROW : 標準の矢印
   IDC_CROSS : 十文字
   IDC_WAIT : 砂時計

・GetPixel関数
 GetPixel関数は,指定したピクセル座標の色を取得します。

  integer(4) function GetPixel(hDC,X,Y)
     integer hDC     ! デバイスコンテキストのハンドル
     integer X       ! X座標
     integer Y       ! Y座標

   戻り値:成功するとRGB値。領域外を指定するとCLR_INVALIDが返ります

 十文字カーソルは,座標値を拾う場合などに用います。また,砂時計カーソルは,暫く計算に時間がかかり表示が待たされる場合などに使用します。

9.3 カーソルをプログラムで作画する例

 画像を扱うプログラムなどでは,図9.2のように画像の切り出しや貼り付けを行う場合などに画像幅いっぱいに表示するカーソルを用いる場合があります。このようなカーソルは,通常のカーソルとは全く別に前章でも用いたSetPixelV関数を用いて画面にオーバーラップさせるように表示します。

図9.2 クロスカーソルの例

 また,同様の手法で画像の切り出しを行う場合などに,その範囲を枠で囲んで表示する例を図9.3に示します。

図9.3 矩形カーソルの例

9.4 プログラム例

!*********************************************************************
!  Cursor Display Sample Program
!*********************************************************************
module WINCOM
use dfwina
type (T_RECT) grect
type (T_POINTS) gpts, gpts0
integer*4  ghinst, gwx, gwy, ghPos, gvPos
end module

!*********************************************************************
!  WinMain
!        2002.01.18  2002.01.18  Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WINCOM
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu, hIcon
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="Cursor"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0 ! IOR(CS_VREDRAW CS_HREDRAW)
      wc%hInstance    = hInstance
!     wc%hIcon        = LoadIcon(hInstance,LOC("MYICON"C))
      wc%hIcon        = LoadImage(hInstance,"MYICON"C,IMAGE_ICON,0,0, &
                        LR_DEFAULTCOLOR)
      wc%hCursor      = LoadCursor(NULL,IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   hmenu = LoadMenu(hInstance, LOC("MYMENU"C))
   ghinst = hInstance
!
   hWnd = CreateWindowEx(0, lpszClassName,  &
                  "Cursor"C,                &
                  INT(WS_OVERLAPPEDWINDOW), &
                  CW_USEDEFAULT,            &
                  0,                        &
                  CW_USEDEFAULT,            &
                  0,                        &
                  NULL,                     &
                  hmenu,                    &
                  hInstance,                &
                  NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
!
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use WINCOM
integer hWnd, mesg, wParam, lParam
type (T_PAINTSTRUCT) ps
integer hInst, hDC
logical b, cCap, bCap
character buf*80
!
   select case (mesg)
   case (WM_CREATE)
     cCap = .FALSE.
     bCap = .FALSE.
   case (WM_CLOSE)
     call BMPCLS(hWnd)
     i = DestroyWindow(hWnd)
   case (WM_DESTROY)
     call PostQuitMessage(0)
   case (WM_SIZE)
     b = GetClientRect(hWnd, grect)
     call SetScrollRanges(hWnd)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)       ! ==> EndPaint
     call BMPDSP(hWnd,hDC)
     if (cCap) then
       call Cursor(hWnd,hDC)
     end if
     if (bCap) then
       call CsrSQR(hWnd,hDC)
     end if
     b = EndPaint(hWnd, ps)           ! <== BeginPaint
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case (101) ! Open
       call BMPOPN(hWnd)
       call SetScrollRanges(hWnd)
       i = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
     case (109)  ! Exit
       i = SendMessage(hWnd, WM_CLOSE, 0, 0)
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case (WM_VSCROLL)
     call vScrollBar(hWnd, wParam)
   case (WM_HSCROLL)
     call hScrollBar(hWnd, wParam)
   case (WM_LBUTTONDOWN)
     cCap = .TRUE.
     gpts0%x = LOWORD(lParam) + ghPos
     gpts0%y = HIWORD(lParam) + gvPos
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_MOUSEMOVE)
     gpts%x = LOWORD(lParam) + ghPos
     gpts%y = HIWORD(lParam) + gvPos
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_LBUTTONUP)
     cCap = .FALSE.
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_RBUTTONDOWN)
     bCap = .TRUE.
     gpts0%x = LOWORD(lParam) + ghPos
     gpts0%y = HIWORD(lParam) + gvPos
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_RBUTTONUP)
     bCap = .FALSE.
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

!*********************************************************************
!*  Cursor SUBROUTINE called by WM_PAINT.
!*********************************************************************
subroutine Cursor(hWnd,hDC)
use WINCOM
integer hWnd, hDC
byte    Red,Green,Blue
logical b
   ix = MIN(gwx,grect%right) - 1
   iy = MIN(gwy,grect%bottom)- 1
   if(gpts%y < gwy)then
     do IH = 0,ix
       MCOL = GetPixel(hDC,IH,gpts%y)
       Red  = GetRedValue(MCOL)  + Z"80"
       Green= GetGreenValue(MCOL)+ Z"80"
       Blue = GetBlueValue(MCOL) + Z"80"
       b    = SetPixelV(hDC,IH,gpts%y,RGB(Red,Green,Blue))
     end do
   end if
   if(gpts%x < gwx)then
     do IV = 0,iy
       MCOL = GetPixel(hDC,gpts%x,IV)
       Red  = GetRedValue(MCOL)  + Z"80"
       Green= GetGreenValue(MCOL)+ Z"80"
       Blue = GetBlueValue(MCOL) + Z"80"
       b    = SetPixelV(hDC,gpts%x,IV,RGB(Red,Green,Blue))
     end do
   end if
   return
!==============================================================
!   CsrSQR
!==============================================================
entry CsrSQR(hWnd,hDC)
    ix0 = MIN(MAX(gpts0%x,0),gwx-1)
    ix1 = MIN(MAX(gpts%x, 0),gwx-1)
    iy0 = MIN(MAX(gpts0%y,0),gwy-1)
    iy1 = MIN(MAX(gpts%y, 0),gwy-1)
    do IV = iy0,iy1
      MCOL = GetPixel(hDC,ix0,IV)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b = SetPixelV(hDC,ix0,IV,RGB(Red,Green,Blue))
      MCOL = GetPixel(hDC,ix1,IV)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b = SetPixelV(hDC,ix1,IV,RGB(Red,Green,Blue))
    end do
    do IH = ix0,ix1
      MCOL = GetPixel(hDC,IH,iy0)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b    = SetPixelV(hDC,IH,iy0,RGB(Red,Green,Blue))
      MCOL = GetPixel(hDC,IH,iy1)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b    = SetPixelV(hDC,IH,iy1,RGB(Red,Green,Blue))
    end do
    return
end

 このプログラムは,十字カーソルや矩形カーソルをプログラムで作画する例です。プログラムの基本部分は第6章のプログラムを引用しています。変更したり追加した部分のみ表示しています。

 MainWndProc関数では,bCap,cCapという論理変数を用意しています。マウスの左ボタンを押したときに,cCapをTRUEにし,構造体gpts0に座標をセットします。左ボタンを離したときに,cCapをFALSEに戻します。同様に右ボタンを押したときに,bCapをTRUEにし,gpts0に座標をセットします。右ボタンを離したときに,bCapをFALSEに戻します。 マウスを移動したときには,構造体gptsに座標をセットします。

 Cursorサブルーチンは,cCapがTRUEのときにWM_PAINTから呼び出されウィンドウいっぱいの十字カーソルを作画します。このサブルーチンでは,カーソルの色が表示されている画像と補色の色でカーソルを作画します。GetPixel関数で表示している色を取得し,GetRedValue関数などを用いてRGB成分を取得し補色を作成して,SetPixelV関数を用いて作画します。

 CsrSQRサブルーチンでは,bCapがTRUEのときにWM_PAINTから呼び出され,マウスの右ボタンを押した位置を基準に移動した位置を囲む矩形領域を作画します。

 このプログラムでは,画面の相対位置の座標を取得し,画面のスクロール状態を考慮して画像自体の相対座標を取得しています。


目次 次の項目

10.プリンタ出力


10.1 プリンタ出力の概要

PRINT

図10.1 プリンタ出力の概要

 プリンタ出力は要約すると次のようになります。

1) プリンタDCの取得
2) アボート関数の作成とセット
3) StartDoc関数の実行
4) StartPage関数の実行
5) プリンタDCへのデータ出力
6) EndPage関数の実行
7) EndDoc関数の実行
 プリンタへ出力するには,プリンタDCを取得しなければなりません。プリンタDCは,CreateDC関数かPrintDlg関数を用いますが,後者の方が手続きが簡単です。図10.1に示すようにPrintDlg関数によってプリンタ選択を行った後,印刷処理の開始にStartDock関数,印刷処理の終了にはEndDoc関数を実行します。ページの出力の開始にはStartPage関数,ページ出力の終わりにはEndPage関数を実行します。

 1ページ分の出力データは,画面表示と同様の手続きを用いて,4),5),6)が対になるように,StartPage関数とEndPage関数の実行の間に行います。これは,ちょうど画面出力をBeginPaint関数とEndPaint関数の実行の間に行うのと類似しています。

 ただし,LoadBitmap関数は,ディスプレイ用に用いることはできますが,プリンタに用ることはできません。また,CreateCompatibleBitmap関数を用いてディスプレイ互換ビットマップを作成すると,ネットワークプリンタなどではモノクロのビットマップしか印刷できない場合があります。CreateDIBsection関数を用いてビットマップのサイズやカラーの指定をすれば,任意のビットマップを作成することができ,StretchBlt関数を用いてプリンタ用のDCに出力することができます。

 なお,出力中のプリントをキャンセルするダイアログを必要に応じて作成します。

10.2 関連するAPI関数

・PrintDlg関数
 PrintDlg関数は,プリントダイアログを表示します。このダイアログでは,プリンタの選択や用紙の選択などプリントジョブのプロパティを指定することができます。また,この関数で指定するPRINTDLG構造体にセットされる情報からプリンタのDC(デバイスコンテキスト)を取得することができます。

    logical(4) function PrintDlg(lppd)
     type(T_PRINTDLG) lppd  ! initialization data

   戻り値:OKボタンを押して復帰したときはTRUEが返ります。
      また,lppdに指定されたPRINTDLG構造体のメンバにはユーザが選択した値がセットされます。
      CANCELボタンを押したとき,又はプリントダイアログボックスを閉じたときは,FALSEが返ります。

 PRINTDLG構造体は,次の形をしています。

    type  T_PRINTDLG
       integer lStructSize      ! 構造体のサイズ
       integer hwndOwner        ! DialogBoxをもつウィンドウのハンドル
       integer hDevMode         ! DEVMODE構造体を格納するメモリオブジェクト
       integer hDevNames        ! DEVNAME構造体を格納するメモリオブジェクト
       integer hDC              ! 選択されたプリンタのデバイスコンテキスト
       integer Flags            ! ダイアログボックス初期化フラグ
       integer(2)  nFromPage    ! 印刷開始ページ番号。PD_PAGENUMSフラグを指定
       integer(2)  nToPage      ! 印刷開始ページ番号
       integer(2)  nMinPage     ! 開始・終了ページの範囲の最小値
       integer(2)  nMaxPage     ! 開始・終了ページの範囲の最大値
       integer(2)  nCopies      ! hDevModeがNULLのときの初期部数値
       integer hInstance        ! Templateを格納するモジュールのインスタンスハンドル
       integer lCustData        ! フック関数にOSが渡すデータのポインタ
       integer lpfnPrintHook    ! [印刷]DlgBoxを修正した場合にメッセージを処理するフック関数のポインタ
       integer lpfnSetupHook    ! [設定]DlgBoxを修正した時にメッセージを処理するフック関数のポインタ
       integer lpPrintTemplateName  ! hInstanceで指定した[印刷]DlgBoxTemplateの名前
       integer lpSetupTemplateName  ! hInstanceで指定した[設定]DlgBoxTemplateの名前
       integer hPrintTemplate   ! [印刷]DlgBoxTemplateのメモリオブジェクト
       integer hSetupTemplate   ! [設定]DlgBoxTemplateのメモリオブジェクト
    end type  T_PRINTDLG

・ResetDC関数
 ResetDC関数は,DEVMODE構造体の情報に基づいてプリンタDCを更新します。ドキュメントを印刷しているときに,用紙の向きやトレイを変更する場合にも用います。

    integer function ResetDC(hDC,lpInitData)
     integer         hDC        ! handle to DC
     type(T_DEVMODE) lpInitData ! pointer to DEVMODE

    戻り値:成功時は元のデバイスコンテキストのハンドル,失敗時はNULLが返ります。

 DEVMODE構造体は,次の形をしています。

    type T_DEVMODE
        character(32) dmDeviceName  ! デバイスドライバで付けられたプリンタの名前
        integer*2 dmSpecVersion
        integer*2 dmDriverVersion
        integer*2 dmSize            ! DEVMODE構造体のサイス
        integer*2 dmDriverExtra
        integer*4 dmFields          ! DEVMODE構造体の使用するメンバのフラグ
        integer*2 dmOrientation     ! 用紙の方向
        integer*2 dmPaperSize       ! 用紙のサイズ
        integer*2 dmPaperLength
        integer*2 dmPaperWidth
        integer*2 dmScale           ! スケールファクタ
        integer*2 dmCopies          ! 印刷部数
        integer*2 dmDefaultSource   ! デフォルト用紙トレイ
        integer*2 dmPrintQuality    ! プリンタの解像度
        integer*2 dmColor           ! カラーorモノクロ
        integer*2 dmDuplex          ! 両面印刷のタイプ
        integer*2 dmYResolution     ! Y軸解像度
        integer*2 dmTTOption        ! フォントの出力方法
        integer*2 dmCollate         ! 複数コピー時の照合の有無
        character(32) dmFormName
        integer*2 dmLogPixels
        integer*4 dmBitsPerPel
        integer*4 dmPelsWidth
        integer*4 dmPelsHeight
        integer*4 dmDisplayFlags
        integer*4 dmDisplayFrequency
        integer*4 dmICMMethod
        integer*4 dmICMIntent
        integer*4 dmMediaType
        integer*4 dmDitherType
        integer*4 dmICCManufacturer
        integer*4 dmICCModel
        integer*4 dmPanningWidth
        integer*4 dmPanningHeight
    end type T_DEVMODE

 各パラメータに指定できる値は,参考資料1)又は5)を参照してください。
 例えば,A4用紙にポートレートを設定するには,dmFieldsにIOR(DM_ORIENTATION,DM_PAPERSIZE)を指定し,dmOrientationにDMORIENT_PORTRAIT,dmPaperSizeにDMPAPER_A4などと指定します。

・StartDoc関数
 StartDoc関数は,指定したプリンタで印刷を開始します。

    integer function StartDoc(hDC,lpdi)
     integer         hDC     ! handle to DC
     type(T_DOCINFO) lpdi    ! pointer to DOCINFO

    戻り値:成功時は1(Win95/98),失敗時は負又は0が返ります。

 DOCINFO構造体は,次の形をしています。

    type  T_DOCINFO
        integer cbSize       ! DOCINFO構造体のサイズ
        integer lpszDocName  ! ドキュメント名へのポインタ
        integer lpszOutput   ! 出力ファイル名へのポインタ
        integer lpszDatatype ! データタイプへのポインタ
        integer fwType       ! 追加情報
    end type  T_DOCINFO

 lpszOutputにNULLを指定すると,hDCで定義されたデバイスに出力されます。

・EndDoc関数
 EndDoc関数は,StartDoc関数で開始された印刷ジョブを終了します。

    integer function EndDoc(hDC)
     integer       hDC       ! handle to DC

   戻り値:成功時は正の値,失敗時は負又は0が返ります。

・AbortDoc関数
 AbortDoc関数は,印刷ジョブを停止し,印刷キューから除去します。印刷をキャンセルしたとき,その応答として用います。

    integer function AbortDoc(hDC)
     integer       hDC        ! handle to DC

   戻り値:成功時は正の値,失敗時は負又は0が返ります。

・StartPage関数
 StartPage関数は,プリンタドライバに新しいページのデータの受け入れを指示します。この関数は印刷するページ毎に実行します。

    integer function StartPage(hDC)
     integer       hDC       ! handle to DC

   戻り値:成功時は正の値,失敗時は負又は0が返ります。

・EndPage関数
 EndPage関数はStartPage関数と対で用いられ,アプリケーションがページデータの書き込みを終了したことをデバイスに伝えます。

    integer function EndPage(hDC)
     integer       hDC       ! handle to DC

   戻り値:成功時は正の値,失敗時は負又は0が返ります。

・DeleteDC関数
 DeleteDC関数は,指定したデバイスコンテキスト(DC)を削除します。

    logical(4) function DeleteDC(hDC)
     integer       hDC       ! handle to DC

   戻り値:成功時はTRUE,失敗時はFALSEが返ります。

・CreateDialogParam関数
 CreateDialogParam関数は,リソースファイルのDialog Boxのテンプレートに基づいて,モードレスダイアログボックスを作成します。モードレスダイアログボックスは,これが表示されている間でもプログラムの実行が中断されずに文字入力等もできるタイプのものをいいます。一方,MessageBox関数などで表示されるダイアログボックスはモーダルダイアログボックスといい,実行が中断されて,これに応答しないとプログラムが先に進みません。

    integer(4) function CreateDialogParam(hInstance,lpTemplateName,hWndParent, &
               lpDialogFunc ,dwInitParam)
     integer hInstance        ! handle to module
     integer lpTemplateName   ! pointer to the dialog box template name
     integer hWndParent       ! handle to owner window
     integer lpDialogFunc     ! dialog box procedure
     integer dwInitParam      ! initialization value

   戻り値:成功時はDialog Boxのハンドル,失敗時はNULLが返ります。

・SetAbortProc関数
 SetAbortProc関数は,スプール中のプリントジョブのキャンセルを可能にするためのabort関数を定義します。

    integer function  SetAbortProc(hdc,lpAbortProc)
     integer hdc              ! handle to DC
     integer lpAbortProc      ! pointer to the abort function

   戻り値:成功時は正の値,失敗時はSP_ERROR(-1)が返ります。

・EnableWindow関数
 EnableWindow関数は,指定したウィンドウやコントロールを有効又は無効にし,マウスやキーの入力を禁止したり,可能にしたりします。

    logical(4) function  EnableWindow(hWnd ,bEnable)
     integer     hWnd         ! handle to window
     logical(4)  bEnable      ! TRUE(enable) or FALSE(disable) input

   戻り値:指定したウィンドウが既に無効の時はTRUE,それ以外はFALSEが返ります。

10.3 プリントのキャンセル

 開始したプリント処理を何らかの理由で印刷を途中でキャンセルしたいことがあります。このため,プリントを開始した後で図10.2のようなキャンセルボタンを押すと印刷を中止するためのダイアログを表示するようにします。

図10.2 プリントキャンセルダイアログ

 プリントのキャンセル処理は必ずしも必要ではありませんが,印刷ページ数が多い場合には途中でキャンセルできるようにした方が便利です。
 これを行うには,StartDoc関数を実行して印刷を開始する直前にCreateDialogParam関数を用いて印刷中止を示すダイアログボックスを表示し,親ウィンドウを入力禁止にします。
 キャンセルボタンが押されたら,それをグローバル変数にセットするためのダイアログのプロシジャを用意します。また,ダイアログのメッセージを処理するプロシジャを作成し,SetAbortProc関数でこのプロシジャを設定します。
 プリント手続きの過程では,1ページ分の処理が終わった時点でこのグローバル変数をチェックし,プリント処理を継続するか否かを決めます。印刷を中止する場合にはAbortDoc関数を実行し,ダイアログを破棄して処理を終了します。

10.4 リソーススクリプトファイルの定義

#include "winres.h"
/////////////////////////////////////////////////////////////////////////////
//
// Menu
//

MYMENU   MENU  DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Open...",                 101
        MENUITEM "&Print...",                104
        MENUITEM "E&xit",                    109
    END
END

/////////////////////////////////////////////////////////////////////////////
//
// Icon
//
MYICON   ICON     DISCARDABLE  "MYICON.ico"

/////////////////////////////////////////////////////////////////////////////
//
// Dialog
//

PRNSTOP DIALOG DISCARDABLE  100, 0, 125, 47
STYLE DS_MODALFRAME | WS_POPUP | WS_CAPTION | WS_SYSMENU
CAPTION "印刷中止"
FONT 9, "MS Pゴシック"
BEGIN
    PUSHBUTTON  "Cancel",IDCANCEL,37,26,50,14
    LTEXT       "Cancelボタンで印刷を中止します",IDC_STATIC,7,7,107,8
END

 リソーススクリプトファイルには,印刷を指示するためにMENUの項目にPrintのMENUITEMを追加しておきます。また,プリントをキャンセルするためのダイアログを定義します。STYLEには,DS_MODALFRAME(モーダルフレームを有するという意味)を選択し,Cancelボタンとその説明文を定義します。
 なお,IDCANCELやIDC_STATICなどが定義してあるヘッダーファイルを引用しているので,#include文で "winres.h"を定義しておきます。winres.hは,DevStudio(Microsoft Visual Studio)ディレクトリの\VC98\INCLUDEにインストールされています。もし,翻訳結合時にこれらが未定義になる場合には,Visual FortranウィンドウのToolsメニューからOptions->Directoriesを選択し,Include filesの項目に...\VC98\includeが設定されていることを確認してください。

10.5 プログラム例

!*********************************************************************
!  Windows programming sample Fractal.
!         2001.10.12   2002.01.29    Y.Akatsuka
!*********************************************************************
module WINCOM
use dfwina
type (T_RECT) grect
type (T_POINTS) gpts

integer*4 ghinst, gwx, gwy, ghPos, gvPos, ghCancelDlg, gINTPRN
logical   gCancel
end module

!*********************************************************************
!  WinMain
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WINCOM
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu, hIcon
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="PRINT"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0
      wc%hInstance    = hInstance
      wc%hIcon        = LoadImage(hInstance,"MYICON"C,IMAGE_ICON,0,0, &
                        LR_DEFAULTCOLOR)
      wc%hCursor      = LoadCursor(NULL,IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   ghinst = hInstance
!
   hWnd = CreateWindowEx(0, lpszClassName,  &
                  "FRACTAL"C,               &
                  INT(WS_OVERLAPPEDWINDOW), &
                  CW_USEDEFAULT,            &
                  0,                        &
                  CW_USEDEFAULT,            &
                  0,                        &
                  NULL,                     &
                  LoadMenu(hInstance, LOC("MYMENU"C)), &
                  hInstance,                &
                  NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
!
   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
     i = TranslateMessage(mesg)
     i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use WINCOM

integer hWnd, mesg, wParam, lParam
type (T_PAINTSTRUCT) ps
type (T_BITMAP) bm
integer hInst, hDC, hCursorA, hCursorC, hCursorW, hBmBuffer, hDCmem
logical b
character buf*100
!
   select case (mesg)
   case (WM_CREATE)
     hDC = GetDC(hWnd)     ! Get the DC of the Window
     b = GetClientRect(hWnd, grect)
     gwx = 640
     gwy = 480
     gpts%x = 0
     gpts%y = 0
     hDCmem = CreateCompatibleDC(hDC)
     hBmBuffer = CreateCompatibleBitmap(hDC, gwx, gwy)
     i = SelectObject(hDCmem, hBmBuffer)
     CALL CFUNC1(hDCmem)
     hCursorA = LoadCursor(NULL,IDC_ARROW)
     hCursorC = LoadCursor(NULL,IDC_CROSS)
     hCursorW = LoadCursor(NULL,IDC_WAIT)
   case (WM_CLOSE)
     i = DeleteDC(hDCmem)
     i = DeleteObject(hBmBuffer)
     i = DestroyWindow(hWnd)
   case (WM_DESTROY)
     call PostQuitMessage(0)
   case (WM_SIZE)
     b = GetClientRect(hWnd, grect)
     call SetScrollRanges(hWnd)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)         ! ==> EndPaint
     b = BitBlt(hDC,-ghPos,-gvPos, gwx,gwy, hDCmem, 0, 0, SRCCOPY)
     b = EndPaint(hWnd, ps)             ! <== BeginPaint
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case (104)
       CALL PINTS (hWnd, mesg, wParam, lParam)
       if(gINTPRN >= 0)then
        CALL PSTART
        CALL PRNBMP
        CALL PEND
       end if
     case (109)
       i = SendMessage(hWnd, WM_CLOSE, 0, 0)
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case (WM_VSCROLL)
     call vScrollBar(hWnd, wParam)
   case (WM_HSCROLL)
     call hScrollBar(hWnd, wParam)
   case (WM_LBUTTONDOWN)
     i = SetCursor(hCursorC)
     i = SetCapture(hWnd)
   case (WM_LBUTTONUP)
     i = ReleaseCapture()
     i = SetCursor(hCursorW)
     gpts%x = LOWORD(lParam) + ghPos
     gpts%y = HIWORD(lParam) + gvPos
     CALL CFUNC1(hDCmem)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
     i = SetCursor(hCursorA)
   case (WM_RBUTTONDOWN)
     i = SetCursor(hCursorC)
     i = SetCapture(hWnd)
   case (WM_RBUTTONUP)
     i = ReleaseCapture()
     i = SetCursor(hCursorW)
     gpts%x = LOWORD(lParam) + ghPos
     gpts%y = HIWORD(lParam) + gvPos
     CALL CFUNC2(hDCmem)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
     i = SetCursor(hCursorA)
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

!*********************************************************************
!*  SetScroolRanges subroutine.
!*********************************************************************
subroutine SetScrollRanges(hWnd)
use WINCOM
type (T_SCROLLINFO) sih, siv
integer*4 hWnd, wParam, dx, dy, RangeX, RangeY
logical b
    gvPos   = 0
    siv%Size= SIZEOF(siv)     ! Size of Info structure
    siv%Mask= IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    siv%Min = 0               ! Minimum scrolling position
    siv%Max = gwy             ! Maximum scrolling position
    siv%Page= grect%bottom - grect%top ! Page scroll size
    siv%Pos = 0               ! Position of the scroll box
    siv%TrackPos = 0
    RangeY  = gwy - siv%Page  ! Scrolling range
    i = SetScrollInfo(hWnd, SB_VERT, siv, .TRUE.)
!
    ghPos   = 0
    sih%Size= SIZEOF(sih)     ! Size of Info structure
    sih%Mask= IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    sih%Min = 0               ! Minimum scrolling position
    sih%Max = gwx             ! Maximum scrolling position
    sih%Page= grect%right - grect%left ! Page scroll size
    sih%Pos = 0               ! Position of the scroll box
    sih%TrackPos = 0
    RangeX  = gwx - sih%Page  ! Scrolling range
    i = SetScrollInfo(hWnd, SB_HORZ, sih, .TRUE.)
    return
!=====================================================================
!*  vScroolBar Entry subroutine.
!=====================================================================
entry vScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINEUP)
      dy = -5
    case (SB_LINEDOWN)
      dy = 5
    case (SB_PAGEUP)
      dy = -siv%Page
    case (SB_PAGEDOWN)
      dy = siv%Page
    case (SB_THUMBPOSITION)
      dy = HiWord(wParam) - siv%Pos
    case (SB_THUMBTRACK)
      dy = HiWord(wParam) - siv%Pos
    case default
      dy = 0
    end select
    dy = MAX(-siv%Pos,MIN(dy,RangeY-siv%Pos))
    if(dy /= 0) then
      siv%Pos = siv%Pos + dy
      gvPos = siv%Pos
      i = SetScrollInfo(hWnd, SB_VERT, siv, .TRUE.)
      i = ScrollWindowEx(hWnd, 0, -dy, grect, grect, 0, &
                         NULL_RECT, SW_INVALIDATE)
    end if
    return
!=====================================================================
!*  hScrollBar Subroutine Entry.
!=====================================================================
entry hScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINELEFT)
      dx = -10
    case (SB_LINERIGHT)
      dx = 10
    case (SB_PAGELEFT)
      dx = -sih%Page
    case (SB_PAGERIGHT)
      dx = sih%Page
    case (SB_THUMBPOSITION)
      dx = HiWord(wParam) - sih%Pos
    case (SB_THUMBTRACK)
      dx = HiWord(wParam) - sih%Pos
    case default
      dx = 0
    end select
    dx = MAX(-sih%Pos,MIN(dx,RangeX-sih%Pos))
    if(dx /= 0) then
      sih%Pos = sih%Pos + dx
      ghPos = sih%Pos
      i = SetScrollInfo(hWnd, SB_HORZ, sih, .TRUE.)
      i = ScrollWindowEx(hWnd, -dx, 0, NULL_RECT, grect, 0, &
                        NULL_RECT, SW_INVALIDATE)
    end if
    return
end

!********************************************************************
!*   CFUNC1   pushed left button
!********************************************************************
SUBROUTINE CFUNC1(hDC)
use  WINCOM
type (T_RECT) rc
integer COL(0:7)/Z"00FF0000",Z"00FF2000",Z"00FF4000",Z"00FF6000", &
                 Z"00FF8000",Z"00FFA000",Z"00FFC000",Z"00FFE000"/
integer(4) hDC
logical b
DATA  X0,Y0,W,BK,MX,CR,CI/2*0.0, 0.005, 10.0, 40, -0.74543,0.11301/
      IF(gpts%x.ne.0 .or. gpts%y.ne.0)GO TO 1
      rc%left  = 0
      rc%top   = 0
      rc%right = gwx
      rc%bottom= gwy
      IHWX = gwx / 2
      IHWY = gwy / 2
      GO TO 2
!==================================================================
!    CFUNC2   pushed right button, calculate function.
!==================================================================
ENTRY CFUNC2(hDC)
      W  = W*0.5
      BK = BK*1.5
      MX = MX+MX/2
    1 X0 = X0+FLOAT(gpts%x-gwx/2)*WW
      Y0 = Y0+FLOAT(gwy/2-gpts%y)*WW
    2 WW = W
      b = FillRect(hDC, rc, GetStockObject(BLACK_BRUSH))
      DO 10 J=1, gwy
      V = FLOAT(IHWY-J)*WW+Y0
      DO 20 I=1, gwx
      U = FLOAT(I-IHWX)*WW+X0
      X = U
      Y = V
      DO 30 L=1,MX
      ZX= X*X-Y*Y+CR
      ZY= X*Y*2.0+CI
      X = ZX
      Y = ZY
      IF(X*X+Y*Y.GT.BK)GO TO 3
   30 CONTINUE
      GO TO 20
    3 b = SetPixelV(hDC,I-1,J-1,COL(MOD(L,8)))
   20 CONTINUE
   10 CONTINUE
      RETURN
      END

!*********************************************************************
!*  PINTS SUBROUTINE FOR WIN PRINT.
!*        V01L002  2002.02.27   Y.AKATSUKA
!*********************************************************************
SUBROUTINE PINTS(hWnd, mesg, wParam, lParam)
use WINCOM

interface
integer(4) function MyPrnCancelProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyPrnCancelProc@16' :: MyPrnCancelProc
integer hWnd, mesg, wParam, lParam
end function MyPrnCancelProc
!
logical function MyAbortProc(hDC, Code)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyAbortProc@8' :: MyAbortProc
integer hDC, Code
end function MyAbortProc
end interface

integer  hWnd, mesg, wParam, lParam
INTEGER  hDC    ! handle to printer device context
INTEGER  HWD, hDCmem, hBmBuffer, lpBits, hDC0
SAVE     hDC,HWD
LOGICAL(4) b
CHARACTER  buf*80
type (T_PRINTDLG) Pdlg
type (T_DOCINFO)  Di
type (T_DEVMODE)  Dm
type (T_BITMAPINFO) lpbi
    HWD = hWnd
!   Initialize Pdlg structure.
    Pdlg%lStructSize = SIZEOF(Pdlg)
    Pdlg%hwndOwner = NULL
    Pdlg%hDevMode  = NULL
    Pdlg%hDevNames = NULL
    Pdlg%hDc       = NULL
    Pdlg%Flags = IOR(PD_RETURNDC,IOR(PD_NOPAGENUMS,PD_NOSELECTION))
    Pdlg%nFromPage = 1
    Pdlg%nToPage   = 1
    Pdlg%nMinPage  = 1
    Pdlg%nMaxPage  = 1
    Pdlg%nCopies   = 1
    Pdlg%hInstance = NULL
    Pdlg%lCustData = NULL
    Pdlg%lpfnPrintHook = NULL
    Pdlg%lpfnSetupHook = NULL
    Pdlg%lpPrintTemplateName = NULL
    Pdlg%lpSetupTemplateName = NULL
    Pdlg%hPrintTemplate = NULL
    Pdlg%hSetupTemplate = NULL
    b = PrintDlg(Pdlg)      ! Show printer dialog box.
    if (.NOT. b) then       ! TRUE return value is OK.
      i = CommDlgExtendedError()
      gINTPRN = -1
      return
    end if
!*  Bring up the Print dialog box and allow user to select printer.
    hDC = Pdlg%hDc
!*  ResetDC
    Dm%dmsize       = SIZEOF(Dm)
    Dm%dmFields     = IOR(DM_ORIENTATION,IOR(DM_PAPERSIZE,DM_COLOR))
    Dm%dmOrientation= DMORIENT_LANDSCAPE ! DMORIENT_PORTRAIT
    Dm%dmPaperSize  = DMPAPER_A4
    Dm%dmColor      = DMCOLOR_COLOR      ! DMCOLOR_MONOCHROME
    hDC0 = ResetDC(hDC, Dm)
!*  Create Cancel Dialog & set abort function
    ghCancelDlg = CreateDialogParam(ghinst, LOC("PRNSTOP"C), HWD, &
                  LOC(MyPrnCancelProc), 0)
    i = ShowWindow(ghCancelDlg, SW_SHOW)
    i = EnableWindow(HWD,.FALSE.)   ! Unavailable Main Window
    i = SetAbortProc(hDC, LOC(MyAbortProc))
!*  Initialize DOCINFO structure
    Di%cbSize = SIZEOF(Di)
    Di%lpszDocName = LOC("Bitmap Document"C)
    Di%lpszOutput  = NULL
    Di%lpszDatatype= NULL
    Di%fwType      = 0
!*  Start Print
    i = StartDoc(hDC, di)   ! Return value is print job identifier (>0)
    if (i == SP_ERROR) then ! SP_ERROR = -1
      write(buf,*)i,""C
      i = MessageBox(HWD, buf, "StartDoc Error"C, MB_OK)
      return
    end if
!*  BitmapInfo
    lpbi%bmiHeader%biSize         = SIZEOF(lpbi%bmiHeader)
    lpbi%bmiHeader%biWidth        = gwx
    lpbi%bmiHeader%biHeight       = gwy
    lpbi%bmiHeader%biPlanes       = 1
    lpbi%bmiHeader%biBitcount     = 24
    lpbi%bmiHeader%biCompression  = BI_RGB
    lpbi%bmiHeader%biSizeImage    = 0
    lpbi%bmiHeader%biXPelsPermeter= 0
    lpbi%bmiHeader%biYPelsPerMeter= 0
    lpbi%bmiHeader%biClrUsed      = 0
    lpbi%bmiHeader%biClrImportant = 0
    hDCmem = CreateCompatibleDC(hDC)
    hBmBuffer = CreateDIBSection(hDCmem,lpbi,DIB_RGB_COLORS, &
                LOC(lpBits),NULL,0)
    i = SelectObject(hDCmem, hBmBuffer)
    gINTPRN = 0
    return
!=====================================================================
!*  PSTART ENTRY called by each page.
!=====================================================================
    ENTRY PSTART
    IF(gINTPRN.GT.0) i = EndPage(hDC)
    gINTPRN = StartPage(hDC) ! normal return > 0
    return
!=====================================================================
!*  PRNBMP ENTRY called by WM_PRINT.
!=====================================================================
    ENTRY PRNBMP
    gpts%x = 0
    gpts%y = 0
    CALL CFUNC1(hDCmem)
    b = StretchBlt(hDC,0,0,gwx*5,gwy*5,hDCmem,0,0,gwx,gwy,SRCCOPY)
    return
!=====================================================================
!*  PEND ENTRY FOR PRINT SECTION.
!=====================================================================
    ENTRY PEND
    i = EndPage(hDC)       ! End the page
    gINTPRN = 0
    if (gCancel) then
      i = AbortDoc(hDC)    ! Abort the document
      i = MessageBox(HWD, "印刷をキャンセルしました。"C, "Print"C, MB_OK)
    else
      i = EndDoc(hDC)      ! End the document
    end if
    i = EnableWindow(HWD,.TRUE.)
    i = SetFocus(HWD)
    b = DestroyWindow(ghCancelDlg)
    ghCancelDlg = 0
    i = InvalidateRect(HWD, NULL_RECT, .FALSE.)
!
    b = DeleteDC(hDCmem)   ! Delete the memory device context
    i = DeleteObject(hBmBuffer)
    b = DeleteDC(hDC)      ! Delete the device context
    RETURN
    END

!*********************************************************************
!*  MyPrnCancelProc Function for the cancel dialog.
!*********************************************************************
integer*4 FUNCTION MyPrnCancelProc(hWnd,msg,wp,lp)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyPrnCancelProc@16' :: MyPrnCancelProc
use WINCOM
integer hWnd,msg,wp,lp
    lp = lp ! dummy
    select case ( msg )
    case (WM_INITDIALOG)
      i = SetFocus(hWnd)
      gCancel = .FALSE.
      MyPrnCancelProc = 1
      return
    case (WM_COMMAND)
      if (LOWORD(wp) == IDCANCEL) then
        gCancel = .TRUE.
        MyPrnCancelProc = 1
        return
      end if
    case DEFAULT
    end select
    MyPrnCancelProc = 0
    RETURN
    END

!*********************************************************************
!*  MyAbortProc Function.
!*********************************************************************
logical FUNCTION MyAbortProc(hDC, Code)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyAbortProc@8' :: MyAbortProc
use WINCOM
type (T_MSG) msg
integer hDC, Code
    do while(.NOT. gCancel .AND. PeekMessage(msg,NULL,0,0,PM_REMOVE))
      if(.NOT. IsDialogMessage(ghCancelDlg, msg)) then
        i = TranslateMessage(msg)
        i = DispatchMessage(msg)
      end if
    end do
    MyAbortProc = .NOT. gCancel   ! TRUE:continue  FALSE:cancel
    RETURN
    END

 プログラムは第8章のものを引用しています。グローバル変数には,プリント出力のキャンセルを行うダイアログ・プロシジャのハンドルとキャンセル情報を受け渡す変数を追加しています。
 WinMain関数は,第8章とほとんど同じです。

 MainWndProc関数では,WM_CREATEでグローバル変数gwx,gwyに作成する画像の大きさをセットしています。ディスプレイ互換のメモリーDCを作成し,CFUNC1サブルーチンを実行してメモリーDCに初期画像を作画します。また,使用するカーソルのハンドルを取得しています。
 WM_CLOSEでは,メモリーDC,ビットマップオブジェクトの削除,ウィンドウの廃棄を行います。
 WM_COMMANDでは,メニューのPrintメッセージを捕まえ,印刷処理を行うサブルーチンを実行します。
 その他のところは,第8章と同じです。

 CFUNC1サブルーチン及びCFUNC2エントリでは,パラメータに指定されたDCに対して作画処理を行います。第8章のプログラムを少し変更し,f(z)=z2+c という関数の c を固定して計算しています。これはジュリア集合と呼ばれるものです。カラーもブルー系にしてみました。CFUNC1はマウスの左クリックで呼び出され,クリックした位置を中心に画像を作画します。CFUNC2はマウスの右クリック時に呼び出され,クリックした位置を中心にして画像を拡大表示するように計算します。これらのサブルーチンは,画面表示のときと印刷のときに実行します。

 PINTSサブルーチンでは,PrintDlg関数を用いてプリンタダイアログを表示し,プリンタの選択や設定を行い,プリンタのデバイスコンテキストを取得します。
 ResetDC関数を用いて,プリンタをリセットし,用紙のサイズや向きをプログラムから指定します。この関数を実行しないとネットワークプリンタなどでは,以前に出力したときの状態が残っている場合があります。
 CreateDialogParam関数を用いて,プリンタキャンセルダイアログを作成し,EnableWindow関数によって親ウィンドウから入力ができないようにします。SetAbortProc関数で,メッセージ処理ループを記述したアボート関数を設定します。
 DOCINFO構造体に文書名を指定し,StartDoc関数で,印刷の開始を指示します。
 また,プリンタ互換のメモリDCを作成し,CreateDIBSection関数で作成したフルカラーのビットマップバッファをSelectObject関数で選択します。メモリDCを作成しないで直接プリンタDCに出力することもできますが,画像などの場合は印刷時間が非常に多くかかります。

 PSTARTサブルーチンでは,StartPage関数,EndPage関数で印刷ページの開始と終了を指示します。

 PRNBMPサブルーチンでは,CFUNC1サブルーチンを用いてPINTSサブルーチンで作成したプリンタ互換のメモリDC上に作画をします。StretchBlt関数でメモリDC上の画像を5倍に拡大し,プリンタDCに出力します。
 このプログラム例では1ページしか印刷しないので必要はありませんが,1ページ分の処理が終了した時点で,キャンセル情報をセットしたgCancel変数を調べ,TRUEのときはPENDサブルーチンを実行し印刷処理を終了するようにします。

 PENDサブルーチンでは,プリントの後処理をします。EndPage関数で1ページ分の後処理を行います。キャンセルボタンが押されてgCancelがTRUEのときは,AbortDoc関数を実行します。正常終了するときはEndDoc関数を実行し,印刷処理を終了します。EnableWindow関数で親ウィンドウの入力を可能にし,SetFocus関数で親ウインドウをアクティブにした後,キャンセルダイアログを閉じます。メモリDCとプリンタDCを削除し,ビットマップバッファを削除し,親画面を復元して終了します。

 MyPrnCancelProc関数は,キャンセルダイアログのメッセージ処理を記述します。WM_INITDIALOGは,ダイアログが作成されたときに実行し,ダイアログをアクティブにします。WM_COMMANDでは,キャンセルボタンが押されたときのメッセージを捕らえ,グローバル変数gCancelをTRUEにして終了します。

 MyAbortProc関数は,SetAbortProc関数で設定する印刷中止用のプロシジャです。GDIから適宜呼び出されて実行します(注)。WinMain関数のメッセージ処理ループに似ています。PeekMessage関数で調べてメッセージが存在するとき,IsDialogMessage関数でMyPrnCancelProc関数にメッセージの処理を依頼します。gCancel変数の値を用いて,印刷処理を継続するときはFALSE,印刷をキャンセルするときはTRUEで復帰するようにします。

(注)AbortProc関数に制御が渡ってくるのは,GDI関数のBitBlt関数やStretchBlt関数を実行したときです。また,SetAbortProc関数を実行した後でResetDC関数を実行すると,制御が渡って来ません。筆者は当初これで随分と悩みました。なお,印刷終了時に親ウィンドウをアクティブにしてからキャンセルダイアログを破棄しないと親ウィンドウが他のウィンドウに隠れてしまう場合があります。


目次 次の項目

11.ツールバー,ステイタスバー,子ウィンドウ


11.1 ツールバーとステイタスバー

 ツールバーは,よく使用するコマンドなどのコントロールを集めたパネルで,通常はボタンを組み込んで用います。ファイルのオープンやプリンタなどのボタンは標準で用意されています。

 ステイタスバーは,ウィンドウに表示されている内容についての状態を示す情報を表示するのに用い,通常はウィンドウの一番下に置きます。

TOOLBAR

図11.1 ツールバーとステイタスバーを表示した例

 ツールバーとステイタスバーを表示した例を図11.1に示します。ツールバーはファイルのオープン,印刷プレビュー,印刷の3つの標準品ボタンを組み込んでいます。任意のボタンを作成して組み込むこともできます。
 ステイタスバーは,処理の状態を適宜表示するのに用いますが,例では”宛名印刷”と表示しています。
 ツールバーやステイタスバーも一つのウィンドウです。そのため,内容をメインウィンドウに直接表示すると,表示内容の一部がこれらのウィンドウに隠されてしまいます。また,スクロールバーの表示をしたときには,見えている画面とスクロールバーとの対応が不自然になってしまいます。これを回避する最も簡単な方法は,内容を直接メインウィンドウに表示するのではなく,メインウィンドウからツールバーとステイタスバーを除いた領域に子ウィンドウを貼り付けて,そこに表示するようにします。

 ここでは,やや実用的な宛名印刷のプログラムを作成し,ツールバーやステイタスバーの表示と子ウィンドウの用い方について解説します。

11.2 関連するAPI関数

・SystemParametersInfo関数
 SystemParametersInfo関数は,さまざまなシステムパラメータの値を取得するのに用います。ここでは,デスクトップの作業領域のサイズを調べ,表示可能なウィンドウの最大サイズを取得するのに用います。

    logical(4) SystemParametersInfo(uAction,uParam,pvParam,fWinIni)
     integer uAction    ! system parameter to retrieve or set
     integer uParam     ! depends on action to be taken
     integer pvParam    ! depends on action to be taken
     integer fWinIni    ! user profile update option

     uAction  : システムパラメータを指定するコマンドを指定します。
     uParam   : uActionで指定したアクションに対応する汎用パラメータを指定します。

   戻り値:成功したときはTRUE,失敗したときはFALSEが返ります。

・CheckMenuItem関数
 CheckMenuItem関数は,指定したメニュー項目のチェックマークを付けたり外したりします。ここでは,メニューオプションでツールバーとステイタスバーの表示をするかしないかの選択に用います。

    integer(4) function CheckMenuItem(hMenu, uIDCheckItem, uCheck)
     integer hMenu        ! handle to menu
     integer uIDCheckItem ! menu item to check or uncheck
     integer uCheck       ! menu item options

     uCheckパラメータでは,関数の実行方法を以下のパラメータを2つ組み合わせて指定します。
      MF_BYCOMMAND : uIDCheckItemの値がメニュー識別子IDであることを示す。
      MF_BYPOSITION: uIDCheckItemの値がメニュー項目の最上位からの相対位置を示す。
      MF_CHECKED   : メニュー項目の横にチェックマークを付ける。
      MF_UNCHECKED : チェックマークをクリアする。

   戻り値:成功したときはメニュー項目の状態(MF_CHECKED又はMF_UNCHECKED),失敗したときは-1が返ります。

・InitCommonControlsEx関数
 InitCommonControlsEx関数は,InitCommonControls関数に取って替わった関数で指定したコモンコントロールクラスのDLLライブラリを登録し実行できるようにします。

    subroutine InitCommonControlsEx(lpInitCtrls)
      type (T_INITCOMMONCONTROLSEX) lpInitCtrls
lpInitCtrlsパラメータは,INITCOMMONCONTROLSEX構造体へのポインタ。

 T_INITCOMMONCONTROLSEX構造体
 T_INITCOMMONCONTROLSEX構造体は,InitCommonControlsEx関数で登録するコントロールクラスの情報をセットします。

    type T_INITCOMMONCONTROLSEX
      integer(4) dwSize	! 構造体のサイズ
      integer(4) dwICC	! 初期化するクラスを示すフラグ
    end type T_INITCOMMONCONTROLSEX
dwICCパラメータは,どのコモンコントロールクラスをロードするかを,以下のパラメータを組み合わせて指定します。
    ICC_ANIMATE_CLASS    Load animate control class.
    ICC_BAR_CLASSES      Load toolbar, status bar, trackbar, and ToolTip control classes.
    ICC_COOL_CLASSES     Load rebar control class.
    ICC_DATE_CLASSES     Load date and time picker control class.
    ICC_HOTKEY_CLASS     Load hot key control class.
    ICC_INTERNET_CLASSES Load IP address class.
    ICC_LINK_CLASS       Load a hyperlink control class.
    ICC_LISTVIEW_CLASSES Load list-view and header control classes.
    ICC_NATIVEFNTCTL_CLASS Load a native font control class.
    ICC_PAGESCROLLER_CLASS Load pager control class.
    ICC_PROGRESS_CLASS   Load progress bar control class.
    ICC_STANDARD_CLASSES Load one of the intrinsic User32 control classes.
                         The user controls include button, edit, static, listbox, combobox, and scrollbar.
    ICC_TAB_CLASSES      Load tab and ToolTip control classes.
    ICC_TREEVIEW_CLASSES Load tree-view and ToolTip control classes.
    ICC_UPDOWN_CLASS     Load up-down control class.
    ICC_USEREX_CLASSES   Load ComboBoxEx class.
    ICC_WIN95_CLASSES    Load animate control, header, hot key, list-view, progress bar, status bar,
                         tab, ToolTip, toolbar, trackbar, tree-view, and up-down control classes.

・SendMessage関数
 SendMessage関数は,別のウィンドウにメッセージを送ります。ボタンやステイタスバーなどのコントロールウィンドウと通信するのに用います。

    integer*4 function SendMessage(hWnd, Msg, wParam, lParam)
     integer hWnd    ! メッセージを受け取るウィンドウのハンドル
     integer Msg     ! 送信するメッセージ
     integer wParam  ! メッセージのwParam値
     integer lParam  ! メッセージのlParam値

   戻り値:送るメッセージによります。

・CreateToolbarEx関数
 CreateToolbarEx関数は,ツールバーウィンドウを作成し,指定されたボタンをツールバーに追加します。使用に当たっては,InitCommonControlsEx関数を実行し,コモンコントロールライブラリを初期化する必要があります。

    integer(4) function CreateToolbarEx(hwnd,ws,wID,nBitmaps,hBMInst,wBMID, &
       lpButtons,iNumButtons,dxButton,dyButton,dxBitmap,dyBitmap,uStructSize)
     integer(4) hwnd     ! Window handle
     integer(4) ws       ! Window style
     integer(4) wID      ! Control ID
     integer(4) nBitmaps ! Number of button images
     integer(4) hBMInst  ! Module instance handle
     integer(4) wBMID    ! Bitmap resource ID
     type(T_TBBUTTON),dimension(*) :: lpButtons ! Pointer to TBBUTTON
     integer(4) iNumButtons ! Number of add button
     integer(4) dxButton ! Width of add button
     integer(4) dyButton ! Hight of add button
     integer(4) dxBitmap ! Width of add button image
     integer(4) dyBitmap ! Hight of add button image
     integer(4) uStructSize ! Size of TBBUTTON structure

   戻り値:成功したときはTRUE,失敗したときはFALSEが返ります。

 T_TBBUTTON構造体
 T_TBBUTTON構造体は,ツールバーに追加するボタンに関する情報を定義します。

    type T_TBBUTTON
     integer(4) iBitmap   ! ボタンイメージへのインデックス
     integer(4) idCommand ! ボタンに対応するコマンド識別子(WM_COMMANDメッセージで取得)
     integer(1) fsState   ! ボタンの状態フラグ
     integer(1) fsStyle   ! ボタンのスタイル
     integer(1) bReserved(2) ! リザーブ
     integer(4) dwData    ! ボタンに対応付けるアプリケーション定義の値
     integer(4) iString   ! ボタン文字列インデックス
    end type T_TBBUTTON
iBitmapは,付加するボタンのインデックスでシステムで定義された標準ボタンを用いるときは以下の値が指定できます。
     STD_CUT,STD_COPY,STD_PASTE,STD_UNDO,STD_REDOW,STD_DELETE,STD_FILENEW,STD_FILEOPEN,
     STD_FILESAVE,STD_PRINTPRE,STD_PROPERTIES,STD_HELP,STD_FIND,STD_REPLACE,STD_PRINT
     VIEW_DETAILS,VIEW_LARGEICONS,VIEW_LIST,VIEW_NETCONNECT,VIEW_NETDISCONNECT,VIEW_NEWFOLDER,
     VIEW_PARENTFOLDER,VIEW_SMALLICONS,VIEW_SORTDATE,VIEW_SORTNAME,VIEW_SORTSIZE,VIEW_SORTTYPE
fsStateは,ボタンの状態を以下の値を用いて指定します。
     TBSTATE_CHECKED       TBSTYLE_CHECKスタイルが割り当てられ,押された状態。
     TBSTATE_ENABLED       ボタンは使用可能。
     TBSTATE_HIDDEN        ボタンは非表示。
     TBSTATE_INDETERMINATE ボタンは淡色表示。
     TBSTATE_PRESSED       ボタンは押されている。
     TBSTATE_WRAP          TBSTATE_ENABLEと共に指定し,ボタンの後で改行発生。
fsStyleでは,ボタンのスタイルを以下の値を用いて指定します。
     TBSTYLE_BUTTON        標準プッシュボタンを作成する。
     TBSTYLE_CHECK         クリックするとボタンのON-OFFが切り替わる。
     TBSTYLE_CHECKGROUP    他のボタンが押されるまで押された状態を保持するチェックボタンを作成する。
     TBSTYLE_GROUP         他のボタンが押されるまで状態を保持する標準ボタンを作成する。
     TBSTYLE_SEP           ボタングループの間にセパレータを作成する。

 T_TBADDBITMAP構造体
 T_TBADDBITMAP構造体は,SendMessage関数を用いて組み込むボタンイメージのリストにイメージを追加するメッセージを定義します。

     type T_TBADDBITMAP
      integer(4) hInst    ! HINSTANCE
      integer(4) nID      ! UINT
     end type T_TBADDBITMAP
hInstはビットマップリソースが入っているモジュールヘのインスタンスハンドルを指定します。システム定義のボタンビットマップを追加する場合は,HINST_COMMCTRLを指定します。
nIDはボタンイメージが入っているビットマップリソースの識別子です。hInstにHINST_COMMCTRLを指定したときは,以下の何れかを指定します。
     IDB_STD_LARGE_COLOR   大きいカラー標準ビットマップを追加する。
     IDB_STD_SMALL_COLOR   小さいカラー標準ビットマップを追加する。
     IDB_VIEW_LARGE_COLOR  大きいカラービュービットマップを追加する。
     IDB_VIEW_SMALL_COLOR  小さいカラービュービットマップを追加する。

 T_NMHDR構造体
 T_NMHDR構造体は,通知メッセージに関する情報を格納します。ここではツールチップの表示に用いますが,コントロールにイベントが発生したりしたときにWM_NOTIFYメッセージとして親ウィンドウに通知されます。

   type T_NMHDR
       integer hwndFrom    ! Window Handle from Control
       integer idFrom      ! Control ID
       integer code        ! NM_code
   end type T_NMHDR

 T_TOOLTIPTEXT構造体
 T_TOOLTIPTEXT構造体は,ツールチップを表示するときに情報をセットする構造体です。構造体の中にはT_NMHDR構造体を含んでいます。

    type T_TOOLTIPTEXT
           type(T_NMHDR) hdr     ! NMHDR structure
           integer(4) lpszText   ! Address of a string to receive the text
           integer(1) szText(80) ! buffer for tool tip text
           integer(4) hinst      ! HINSTANCE
           integer(4) uFlags     ! indicating flag
           integer(4) lParam     ! LPARAM
    end type T_TOOLTIPTEXT

・CreateStatusWindow関数
 CreateStatusWindow関数(Visual FortranからはCreateStatusWindowA関数として用いる)は,ステイタスウィンドウを作成します。ステイタスウィンドウは通常クライアント領域の最下部に作成し,プログラムの状況などを表示します。

    integer(4) function CreateStatusWindowA(style,lpszText,hwndParent,wID)
     integer(4) style       ! ウィンドウスタイル(WS_CHILDとWS_VISIBLEを含める)
     character*(*) lpszText ! NULLで終わる文字列のポインタ
     integer(4) hwndParent  ! 親ウィンドウのハンドル
     integer(4) wID         ! コントロール識別子

   戻り値:成功したときはステイタスウィンドウのハンドル,失敗したときはNULLが返ります。

11.4 ツールバーの作成

 @ 環境設定
コモンコントロールの機能を用いるので,Visual StudioのProject SettingsでFortranのCategoryでLibraryを選択し,Other Library OptionsのUse Common Windows Librariesの項目にチェックを入れておきます。
 A comctl32の定義
ツールバーの作成に当たっては,コモンコントロールを用いるのでuse文でcomctl32を定義しておきます。
 B InitCommonControlsEx関数の実行
ICC_BAR_CLASSESをパラメータに指定したInitCommonControlsEx関数を用いてコモンコントロールの初期化を行います。
 C T_TBBUTTON構造体にボタンの情報をセット
組み込むボタンの数だけT_TBBUTTON構造体を配列で用意し,ボタンの情報をセットしておきます。
 D CreateToolbarEx関数の実行
モジュールインスタンスハンドルをGetWindowLong関数で取得します。iNumButtonsパラメータには,組み込むボタンの数をセットします。ボタンの幅と高さは0を指定すると適当な大きさで作成されます。 こうして実行すると何も表示のない"のッペらぼう"ボタンの付いたツールバーができます。
 E ボタンイメージの組み込み
TB_ADDBITMAP構造体に組み込むボタンイメージの情報をセットし,ツールバーウィンドウに対してSendMessage関数を実行すると,ボタンにイメージが組み込まれます。
 後からボタンを追加することもできます。この場合はT_TBBUTTON構造体に値をセットし,TB_ADDBUTTONメッセージ又はTB_INSERTBUTTONメッセージを発行します。
 F ツールチップの設定
ツールチップは,ツールボタンの上にマウスを移動したときに表示されるコメントで図11.2 のような形をしています。
TOOLTIP

図11.2 ツールチップ

ツールチップを設定するには,対応するコードと文字列をリソースファイルに設定しておきます。
WM_NOTIFYメッセージを捕らえ,lParamによってポイントされるT_TOOLTIPTEXT構造体に含まれるT_NMHDR構造体のcodeを調べます。TTN_NEEDTEXTであるときに,同構造体のidFromを判定し,表示する文字列のポインタをセットします。

11.5 ステイタスバーの作成

 @ 環境設定
コモンコントロールの機能を用いるので,Visual StudioのProject SettingsでFortranのCategoryでLibraryを選択し,Other Library OptionsのUse Common Windows Librariesの項目にチェックを入れておきます。
 A comctl32の定義
ツールバーの作成に当たっては,コモンコントロールを用いるのでuse文でcomctl32を定義しておきます。
 B InitCommonControlsEx関数の実行
ICC_BAR_CLASSESをパラメータに指定したInitCommonControlsEx関数を用いてコモンコントロールの初期化を行います。
 ここまではツールバーを作るときと同様に行います。ツールバーを作成するときに既に初期化が行われていれば行う必要はありません。
 C CreateStatusWindow関数又はCreateWindowEX関数の実行
ステイタスバーは,CreateStatusWindow関数又はCreateWindowEX関数で作成します。CreateWindowEX関数を用いる場合は,第2パラメータのウィンドウクラス名はSTATUSCLASSNAMEを指定します。STATUSCLASSNAMEは予め"msctls_statusbar32"Cと定義されています。第4パラメータのウィンドウスタイルには,WS_CHILDとWS_VISIBLEを含めて指定します。SBARS_SIZEGRIPを同時に指定すると,ステータスウィンドウの右端にウィンドウのサイズを変更するサイズグリップを表示します。第10パラメータには適当な値をコントロールIDに指定します。その他のパラメータの指定はウィンドウを作成するときと同様に行います。
 CreateStatusWindow関数を用いる場合もほぼ同様に指定します。内部ではCreateWindowExを実行しています。
【例】
 ghStatusWnd = CreateWindowEx(0, STATUSCLASSNAME,"宛名印刷"C, &
  IOR(WS_CHILD,IOR(WS_VISIBLE,SBARS_SIZEGRIP)),0,0,0,0,   &
  hWnd,ID_STATUSBAR,hInst2,NULL)

 D 領域の設定
ステータスバーは単一領域又は複数領域に分割することができます。
単一領域にするには,SendMessage関数を用いてSB_SIMPLEメッセージを,

 i = SendMessage(ghStatusWnd, SB_SIMPLE, TRUE, 0)

のようにステータスバーウィンドウに送ります。
複数領域に分割するには,領域の数だけ整数配列を用意し,それぞれの領域のサイズを設定しておきます。 SendMessage関数を用いて,領域の数,設定した配列のアドレスと共にSB_SETPARTSメッセージを,ステータスバーウィンドウに送ります。

 integer sbSize(2)/100,200/
 i = SendMessage(ghStatusWnd, SB_SETPARTS, 2, LOC(sbSize))

 E SendMessage関数でテキスト送信
アプリケーションの状況に応じて必要なテキストを表示するには,SendMessage関数を用いてSB_SETTEXTメッセージをステータスバーウィンドウに送ります。

 i = SendMessage(ghStatusWnd, SB_SETTEXT, 1, LOC("***を実行中"C))

ここで第3パラメータは,0から数えた領域の番号です。

11.6 子ウィンドウの作成

 ツールバーやステータスバーを持った親ウィンドウにスクロールバーを付けて,表示されている内容を全領域スクロールすると,ツールバーやステータスバーも一緒にスクロールされてしまいます。 また,ツールバーやステータスバーを除いた領域だけを表示領域にしてスクロールするようにしようとするとプログラムが非常に煩雑になってしまいます。
 そこで,内容表示専用の子ウィンドウを親ウィンドウの表示域に貼り付けるようにします。

@ ウィンドウクラスの登録
メインウィンドウを作る場合と同様にRegisterClass関数を用いてウィンドウクラスを登録します。子ウィンドウプロシジャ名の設定もここで行います。
A 子ウィンドウの作成
CreateWindowEx関数を用いてメインウィンドウのクライアント領域に子ウィンドウを作ります。子ウィンドウは親ウィンドウの外には出られません。子ウィンドウを作るにはCreateWindowEx関数のウィンドウスタイルにWS_CHILDを指定します。WS_VISIBLEも同時に指定するとShowWindow関数の実行を省略できます。メニューハンドルには適当な子ウィンドウIDを設定しておきます。
      ghChdWnd = CreateWindowEx(0,"ChdWind"C, & ! Window Class name
                  "ChdWind"C,               & ! Window name
                  IOR(WS_CHILD,WS_VISIBLE), & ! Window style
                  0,0,                      & ! L/U x,y position
                  grect%right,              & ! Width
                  grect%bottom,             & ! Height
                  hWnd,                     & ! Parent Window handle
                  ID_CHILD,                 & ! Menu handle
                  hInst,                    & ! Instance handle
                  NULL)                       ! Message pointer to lParam
B 子ウィンドウ用のプロシジャの作成
子ウィンドウに送られてくるメッセージを処理するプロシジャを用意します。
子ウィンドウのプロシジャは,基本的にメインウィンドウで行う場合と同じです。ただし,キーボードからの入力などはメインウィンドウに送られてきますので,それをこのプロシジャで処理するときはメインプロシジャの中でSendMessage関数を用いてメッセージを転送するような処理が必要です。

11.7 リソーススクリプトファイルの定義

 リソーススクリプトファイルにはプログラムで使用する次のリソースを定義します。

・インクルードファイル
・ダイアログ
・アイコン
・メニュー
・ビットマップ
・アクセラレータ
 (1) インクルードファイル
リソーススクリプトの中で用いる定数を定義したヘッダーファイルです。
サンプルプログラムではWINRES.HとADDRESS.Hという2つのファイルを用いていますが,WINRES.HはMicrsoft Visual Studio\VC98\INCLUDEディレクトリの中に用意されています。ADDRESS.Hは自前のヘッダーファイルですが,リソースファイルの中に直接書いてもかまいません。
/*************************************************************\
* ADDRESS.H : Header file.                                    *
\*************************************************************/
/***** Control Defines ******/
#define ID_OK              891
#define ID_CANCEL          892
#define IDC_LIST          2002
#define IDC_FORM          2003
#define IDM_NEW            100
#define IDM_OPEN           101
#define IDM_CLOSE          102
#define IDM_SAVE           103
#define IDM_SAVEAS         104
#define IDM_PREVIEW        105
#define IDM_PRINT          106
#define IDM_PRINTSETUP     107
#define IDM_EXIT           108
#define IDM_INPUT          200
#define IDM_FORM           201
#define IDM_COPY           202
#define IDM_PASTE          203
#define IDM_LINK           204
#define IDM_LINKS          205
#define IDM_FONTS          206
#define IDM_TOOLBAR        300
#define IDM_STATUSBAR      301
#define IDM_HELPCONTENTS   400
#define IDM_HELPSEARCH     401
#define IDM_HELPHELP       402
#define IDM_ABOUT          403
#define DLG_VERFIRST       500
#define DLG_VERLAST        501
#define ID_TOOLBAR         601
#define ID_STATUSBAR       602
#define DID_SID            901
#define DID_ALL            903
#define DID_OK             991
#define DID_CANCEL         992
#define WM_MYLSTMSG        701
 (2) ダイアログ
プログラムのなかで用いるダイアログボックスに関する定義を行います。ここでは5種類のダイアログボックスを用いています。
 (3) アイコン
ウィンドウのタイトルバーに表示するアイコンを定義します。アイコンの作り方は第7章を参照してください。
 (4) メニュー
メニューバーに表示するメニューやプルダウンメニューを定義します。
 (5) ビットマップ
ウィンドウの初期画面に用いるビットマップ画像を定義します。
 (6) アクセラレータ
メニューボタンをマウスでクリックする代わりに特定のキーを押すことで同等の処理を行うようにするキー入力を定義します。
・リソースファイルの内容
/////////////////////////////////////////////////////////////////////////////
//
// include file
//
#include "WINRES.H"
#include "ADDRESS.H"

/////////////////////////////////////////////////////////////////////////////
//
// Dialog
//

SNAME DIALOG DISCARDABLE  0, 0, 150, 155
STYLE DS_MODALFRAME | WS_POPUP | WS_SYSMENU | WS_CAPTION | WS_BORDER
CAPTION "氏名の選択"
FONT 10, "MS 明朝"
BEGIN
    DEFPUSHBUTTON   "OK",DID_OK,30,124,30,20
    PUSHBUTTON      "CANCEL",DID_CANCEL,88,124,30,20
    LTEXT           "氏名",-1,57,32,110,11
    EDITTEXT        DID_SID,52,47,47,12,ES_AUTOHSCROLL
    PUSHBUTTON      "ALL",DID_ALL,53,73,47,14,0,WS_EX_STATICEDGE
END

LSTDLG DIALOG DISCARDABLE  0, 0, 350, 250
STYLE WS_CHILD | WS_CAPTION | WS_VISIBLE
CAPTION "氏名選択"
FONT 9, "MS Pゴシック"
BEGIN
    DEFPUSHBUTTON   "OK",ID_OK,20,205,50,20
    PUSHBUTTON      "Cancel",ID_CANCEL,90,205,50,20
    LISTBOX         IDC_LIST,12,12,300,200,LBS_MULTIPLESEL | LBS_MULTICOLUMN | 
                    LBS_EXTENDEDSEL | WS_HSCROLL
END

PRNSTOP DIALOG DISCARDABLE  100, 0, 125, 47
STYLE DS_MODALFRAME | WS_POPUP | WS_CAPTION | WS_SYSMENU
CAPTION "印刷中止"
FONT 9, "MS Pゴシック"
BEGIN
    PUSHBUTTON      "Cancel",IDCANCEL,37,26,50,14
    LTEXT           "Cancelボタンで印刷を中止します",IDC_STATIC,7,7,107,8
END

FORM DIALOG DISCARDABLE  0, 0, 202, 133
STYLE DS_MODALFRAME | WS_POPUP | WS_CAPTION | WS_SYSMENU
CAPTION "定型フォーム"
FONT 9, "MS Pゴシック"
BEGIN
    DEFPUSHBUTTON   "OK",ID_OK,130,7,50,14
    PUSHBUTTON      "Cancel",ID_CANCEL,130,24,50,14
    COMBOBOX        IDC_FORM,12,12,80,100,CBS_SIMPLE | CBS_SORT | 
                    WS_VSCROLL | WS_TABSTOP
END

ABOUTDLG DIALOG FIXED PURE  22, 17, 167, 64
STYLE DS_MODALFRAME | WS_VISIBLE | WS_CAPTION | WS_SYSMENU
CAPTION "About ADDRESS"
BEGIN
    DEFPUSHBUTTON   "OK",IDOK,132,2,32,14
    ICON            "ADDRESS",-1,2,3,1,1
    LTEXT           "CompanyName",400,30,2,100,8
    LTEXT           "FileDescription",401,30,10,82,8
    LTEXT           "ProductVersion",402,114,10,16,8
    LTEXT           "LegalCopyright ゥ",403,30,18,137,8
    LTEXT           "LegalTrademarks",404,30,34,136,27
    CONTROL         "",501,"Static",SS_BLACKRECT,28,31,138,1
END

/////////////////////////////////////////////////////////////////////////////
//
// Icon
//

ADDRESS             ICON    DISCARDABLE     "ADDRESS.ICO"

/////////////////////////////////////////////////////////////////////////////
//
// Menu
//

WORLDMENU MENU DISCARDABLE 
BEGIN
    POPUP "&Metafile"
    BEGIN
        MENUITEM "&Open",                       IDM_OPEN
        MENUITEM "E&xit",                       IDM_EXIT
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&About",                      IDM_ABOUT
    END
END

ADDRESS MENU DISCARDABLE 
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Open...",                    IDM_OPEN
        MENUITEM "&Close...",                   IDM_CLOSE
        MENUITEM "&Save",                       IDM_SAVE, GRAYED
        MENUITEM "Save &As...",                 IDM_SAVEAS, GRAYED
        MENUITEM SEPARATOR
        MENUITEM "&Preview...",                 IDM_PREVIEW
        MENUITEM "&Print...",                   IDM_PRINT
        MENUITEM "P&rint Setup...",             IDM_PRINTSETUP, GRAYED
        MENUITEM SEPARATOR
        MENUITEM "E&xit",                       IDM_EXIT
    END
    POPUP "&Edit"
    BEGIN
        MENUITEM "&INPUT\tCtrl+I",              IDM_INPUT
        MENUITEM SEPARATOR
        MENUITEM "&FONTS\tCtrl+F",              IDM_FONTS
        MENUITEM SEPARATOR
        MENUITEM "&FORM\tCtrl+X",               IDM_FORM
    END
    POPUP "&Option"
    BEGIN
        MENUITEM "&ToolBar",                    IDM_TOOLBAR
        MENUITEM "&StatusBar",                  IDM_STATUSBAR
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&Contents",                   IDM_HELPCONTENTS
        MENUITEM "&Search for Help On...",      IDM_HELPSEARCH
        MENUITEM "&How to Use Help",            IDM_HELPHELP
        MENUITEM SEPARATOR
        MENUITEM "&About ADRESS...",            IDM_ABOUT
    END
END

/////////////////////////////////////////////////////////////////////////////
//
// Bitmap
//

MYBMP   BITMAP  DISCARDABLE  "C:\\Program Files\\Microsoft Visual Studio\\MyProjects\\ADDRESS\\ADDRESS.bmp"

/////////////////////////////////////////////////////////////////////////////
//
// Accelerator
//

ADDRESS ACCELERATORS MOVEABLE PURE 
BEGIN
    VK_F1,          IDM_HELPCONTENTS,       VIRTKEY 
    "I",            IDM_INPUT,              VIRTKEY, CONTROL, NOINVERT
    "F",            IDM_FONTS,              VIRTKEY, CONTROL, NOINVERT
    "X",            IDM_FORM,               VIRTKEY, CONTROL, NOINVERT
    "?",            IDM_ABOUT,              ASCII,  ALT
    "/",            IDM_ABOUT,              ASCII,  ALT
END

///////////////////////////////////////////////////////////
//
// String Table for Tooltips
//

STRINGTABLE DISCARDABLE 
BEGIN
    IDS_INPUT          "入力"
    IDS_PREVIEW        "印刷プレビュー"
    IDS_PRINT          "印刷"
END

11.8 プログラム例

!*********************************************************************
!*    ADDRESS Windows program.
!*          2000.12.11   2002.02.27  Y.Akatsuka
!*********************************************************************
module ADDRESS_inc
  integer*4 ,parameter, public :: IDM_OPEN         =  101
  integer*4 ,parameter, public :: IDM_CLOSE        =  102
  integer*4 ,parameter, public :: IDM_PREVIEW      =  105
  integer*4 ,parameter, public :: IDM_PRINT        =  106
  integer*4 ,parameter, public :: IDM_EXIT         =  108
  integer*4 ,parameter, public :: IDM_INPUT        =  200
  integer*4 ,parameter, public :: IDM_FORM         =  201
  integer*4 ,parameter, public :: IDM_FONTS        =  206
  integer*4 ,parameter, public :: IDM_TOOLBAR      =  300
  integer*4 ,parameter, public :: IDM_STATUSBAR    =  301
  integer*4 ,parameter, public :: IDM_HELPCONTENTS =  400
  integer*4 ,parameter, public :: IDM_HELPSEARCH   =  401
  integer*4 ,parameter, public :: IDM_HELPHELP     =  402
  integer*4 ,parameter, public :: IDM_ABOUT        =  403
  integer*4 ,parameter, public :: DLG_VERFIRST     =  500
  integer*4 ,parameter, public :: DLG_VERLAST      =  501
  integer*4 ,parameter, public :: ID_TOOLBAR       =  601
  integer*4 ,parameter, public :: ID_STATUSBAR     =  602
  integer*4 ,parameter, public :: WM_MYLSTMSG      =  701
end module

module WININT
use dfwina
  type (T_RECT)   grc, grect, gchdrc    ! window rect
  type (T_CHOOSEFONT) gchf
  type (T_SCROLLINFO) gsih, gsiv
  type (T_LOGFONT) glf
  integer*4 gXoffset, gYoffset, gXMAX, gYMAX
  integer*4 ghFont, gColor, gPage, gMaxPage, gINTPRN
  integer*4 gwx,gwy, gvPos, ghPos, gnToolH, gnStatusH, gStatus
  integer*4 ghInst, ghParent, ghChdWnd, ghStatusWnd, ghPrvWnd, ghCancelDlg
  integer*4 ghWndDlg, ghLstDlg
  logical*4 gCancel
  character gSYID(200)*143
  integer*4 gSIDNO,gSQLDTNO,gIX,gLcount,gList(0:199),gFcount
end module

module DIALOG1
  integer, parameter, public :: DID_SID    =  901
  integer, parameter, public :: DID_ALL    =  903
  integer, parameter, public :: DID_OK     =  991
  integer, parameter, public :: DID_CANCEL =  992
end module DIALOG1

module DlgLst1
  integer, parameter, public :: ID_OK      =  891
  integer, parameter, public :: ID_CANCEL  =  892
  integer, parameter, public :: IDC_LIST   = 2002
  integer, parameter, public :: IDC_FORM   = 2003
  integer*4  hDlgLstinst
end module DlgLst1

!*********************************************************************
!  WinMain
!  This is the mail label printing system.
!  2001.03.19       Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WININT
!
interface
integer function MainWndProc ( hwnd, mesg, wParam, lParam )
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
type (T_WNDCLASS) wc
type (T_MSG)      mesg
!
integer hWnd,hmenu,hAccel,hInstance,hPrevInstance,lpszCmdLine,nCmdShow
logical b
character*100 lpszClassName, lpszIconName, lpszMenuName, lpszAppName
   lpszCmdLine  = lpszCmdLine
   nCmdShow     = nCmdShow
   lpszClassName="ADDRESS"C
   lpszAppName  ="ADDRESS"C
   lpszMenuName ="ADDRESS"C
   lpszIconName ="ADDRESS"C
   if(hPrevInstance .eq. 0) then
      wc%lpszClassName = LOC(lpszClassName)
      wc%lpfnWndProc   = LOC(MainWndProc)
      wc%style         = IOR(CS_VREDRAW, CS_HREDRAW)
      wc%hInstance     = hInstance
      wc%hIcon         = LoadIcon(hInstance, LOC(lpszIconName))
      wc%hCursor       = LoadCursor(NULL, IDC_ARROW)
      wc%hbrBackground = (COLOR_WINDOW +2 ) ! +1:white +2:black
      wc%lpszMenuName  = 0
      wc%cbClsExtra    = 0
      wc%cbWndExtra    = 0
      i = RegisterClass(wc)
   end if
   hmenu  = LoadMenu(hInstance, LOC(lpszMenuName))
   hAccel = LoadAccelerators(hInstance, LOC("ADDRESS"C))
   ghInst = hInstance   ! global valiable <== Instance Handle
   hWnd = CreateWindowEx(0,           &
            lpszClassName,            & ! Window class name
            lpszAppName,              & ! Window name
            INT(WS_OVERLAPPEDWINDOW), & ! Window style
            CW_USEDEFAULT,            & ! L/U x position
            CW_USEDEFAULT,            & ! L/U y position
            660+8,                    & ! Width
            480+56,                   & ! Height
            NULL,                     & ! Parent handle
            hmenu,                    & ! Menu handle
            hInstance,                & ! Window handle
            NULL)                       ! Message pointer to lParam
   i = ShowWindow(hWnd, SW_SHOWNORMAL)
   b = UpdateWindow(hWnd)
   ghParent = hWnd    ! ghParent : global variable

   do while (GetMessage(mesg, NULL, 0, 0))
     if (.NOT. TranslateAccelerator(hWnd, hAccel, mesg) .AND. &
         .NOT. IsDialogMessage(ghWndDlg, mesg)) then
       i = TranslateMessage(mesg)
       i = DispatchMessage(mesg)
     end if
   end do
   WinMain = mesg%wParam
end

!*********************************************************************
!    MainWndProc
!                2002.02.27    Y.AKATSUKA
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use ADDRESS_inc
use WININT

interface
integer*4 function AboutDlgProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_AboutDlgProc@16' :: AboutDlgProc
integer hWnd, mesg, wParam, lParam
end function
!
integer(4) function DlgLstProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgLstProc@16' :: DlgLstProc
integer hWnd, mesg, wParam, lParam
end function
!
integer(4) function DlgFrmProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgFrmProc@16' :: DlgFrmProc
integer hWnd, mesg, wParam, lParam
end function
!
integer(4) function DlgProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgProc@16' :: DlgProc
integer hWnd, mesg, wParam, lParam
end function
end interface

type (T_PAINTSTRUCT)  ps
type (T_TOOLTIPTEXT)  lptip
POINTER (ptr, lptip)

integer*4  hWnd, mesg, wParam, lParam
integer*4  hdc, hdcf, hgList, hDlg, hWndFrm
SAVE       hDlg
logical(4) b
character*20 lpszDlgName, lpszContents, lpszHeader
character Path*80, buf*80
   select case (mesg)
   case (WM_CREATE)
     b = SystemParametersInfo(SPI_GETWORKAREA,0,LOC(grc),0) ! work area size
     hdc = GetDC(hWnd)     ! Get the DC of the Window
     glf%lfHeight = -24
     glf%lfEscapement = 0  ! 300
     glf%lfCharSet= SHIFTJIS_CHARSET
     glf%lfFaceName = "MS 明朝"C
     ghFont= CreateFontIndirect(glf)
!   Selects an object into the specified DC and the new object replaces
!   the previous object of the same type.
     i = SelectObject(hdc, ghFont)
     gColor  = RGB(INT1(0), INT1(0), INT1(0))
     i = ReleaseDC(hWnd, hdc)
     gchf%iPointSize = 100  ! 10 Point
     gSIDNO   = 0
     gSQLDTNO = -1
     gnToolH  = 0
     gnStatusH= 0
     gFcount  = 0
     b = GetClientRect(hWnd, grect)
     call ChdWind(hWnd, mesg, wParam, lParam)
   case (WM_DESTROY)
     call ENDBMP(hWnd)
     b = DeleteObject(ghFont)
     call PostQuitMessage(0)
   case (WM_SIZE)
     b = GetClientRect(hWnd, grect)
     grect%top    = grect%top    + gnToolH
     grect%bottom = grect%bottom - gnStatusH
     call ToolBarSz(hWnd)
     call StatusBarSz(hWnd,0)
     b = MoveWindow(ghChdWnd,grect%left,grect%top, &
         grect%right-grect%left,grect%bottom-grect%top,.FALSE.)
   case (WM_KEYDOWN)
     b = PostMessage(ghChdWnd,mesg,wParam,lParam)
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case (IDM_OPEN)
       CALL OPNSID(hWnd)
     case (IDM_CLOSE)
       b = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
     case (IDM_PREVIEW)
       CALL PREVIEW(hWnd, mesg, wParam, lParam)
     case (IDM_PRINT)
       call StatusBarSz(hWnd,4)
       CALL PRINT(hWnd, mesg, wParam, lParam)
       call StatusBarSz(hWnd,1)
     case (IDM_EXIT)
       i = SendMessage(hWnd, WM_CLOSE, 0, 0)
     case (IDM_ABOUT)
       i = DialogBoxParam(ghInst,LOC("AboutDlg"C),hWnd,LOC(AboutDlgProc),0)
     case (IDM_INPUT)
       gSQLDTNO = -1
       gSIDNO = 0
       b = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
       ghWndDlg = CreateDialogParam(ghInst,LOC("SNAME"C),hWnd,LOC(DlgProc),0)
       i = ShowWindow(ghWndDlg, SW_SHOW)
     case (IDM_FONTS)       ! ==> Address.rc
       call StatusBarSz(hWnd,6)
       hdc = GetDC( hWnd )  ! Get the DC of the Window
       gchf%hDC = CreateCompatibleDC(hdc)  ! Make the compatible memory DC
       gchf%lStructSize = 60     ! sizeof(CHOOSEFONT)
       gchf%hwndOwner = hWnd
       gchf%lpLogFont = LOC(glf) ! glf:LOGFONT
       gchf%Flags     = IOR(CF_SCREENFONTS,IOR(CF_EFFECTS,CF_INITTOLOGFONTSTRUCT))
       gchf%rgbColors = RGB(INT1(0), INT1(0), INT1(0))
       gchf%lCustData = 0
       gchf%hInstance = ghInst
       gchf%lpszStyle = NULL
       gchf%nFontType = SCREEN_FONTTYPE
       gchf%nSizeMin  = 0
       gchf%nSizeMax  = 0
       gchf%lpfnHook  = NULL
       gchf%lpTemplateName = NULL
       gchf%iPointSize = 100     ! 10 Point
       if (ChooseFont(gchf) == TRUE) then  ! not canceled ?
         b = DeleteObject(ghFont)
         ghFont = CreateFontIndirect(glf)
         gColor = gchf%rgbColors
         i = SelectObject(hdc, ghFont)
       end if
       i = ReleaseDC(hWnd, hdc)  ! Release DC for another application
       call StatusBarSz(hWnd,1)
       b = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
       b = InvalidateRect(ghPrvWnd, NULL_RECT, .TRUE.)
     case (IDM_FORM)
       call StatusBarSz(hWnd,5)
       hWndFrm = CreateDialogParam(ghInst,LOC("FORM"C),hWnd,LOC(DlgFrmProc),0)
       i = ShowWindow(hWndFrm, SW_SHOW)
     case (IDM_TOOLBAR)
       call ToolBar(hWnd)        ! Set ToolBar or omit
       b = PostMessage(hWnd,WM_SIZE,0,0)
     case (IDM_STATUSBAR)
       call StatusBar(hWnd)
       b = PostMessage(hWnd,WM_SIZE,0,0)
     case (IDM_HELPCONTENTS)
       iPathLen = GetCurrentDirectory(80, Path)
       if (WinHelp(hWnd, Path(1:iPathLen)//"\\HELP\\ADDRESS.HLP"C,HELP_KEY, &
           LOC("CONTENTS"C)) .EQV. .FALSE.) then
         i = MessageBox(hWnd, "Unable to activate help"C, "ADDRESS"C, &
                     IOR(MB_SYSTEMMODAL, IOR(MB_OK, MB_ICONHAND)))
       end if
     case (IDM_HELPSEARCH)
       if (WinHelp(hWnd, "ADDRESS"C, HELP_PARTIALKEY, LOC(""C)) &
          .EQV. .FALSE.) then
         i = MessageBox(hWnd, "Unable to activate help"C, "ADDRESS"C,  &
                     IOR(MB_SYSTEMMODAL, IOR(MB_OK, MB_ICONHAND)))
       end if
     case (IDM_HELPHELP)
       if (WinHelp(hWnd, ""C, HELP_HELPONHELP, 0) .EQV. .FALSE.) then
         i = MessageBox(GetFocus(), "Unable to activate help"C, &
            "ADDRESS"C, IOR(MB_SYSTEMMODAL, IOR(MB_OK, MB_ICONHAND)))
       end if
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case (WM_NOTIFY)
     ptr = lParam
     select case (lptip%hdr%code)
     case (TTN_NEEDTEXT)
       lptip%hinst = ghInst
       lptip%lpszText = lptip%hdr%idFrom
     end select
   case DEFAULT
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
return
end

!*********************************************************************
!*  StatusBar Subroutine called by WM_STATUSBAR event.
!*        2001.03.22   2001.03.22   Y.AKATSUKA
!*********************************************************************
Subroutine StatusBar(hWnd)
use WININT
use ADDRESS_inc
use comctl32
integer*4 hWnd, hInst2, hMenu, StatusB/0/, sbSize(2)/100,200/
logical   b
character ST(7)*14/"       ","入力     ","印刷プレビュー", &
   "印刷中    ","フォーム選択 ","フォント選択 ","       "/
character buf*80
type (T_RECT) rcstatus
type (T_INITCOMMONCONTROLSEX) lpCtrls
    if (StatusB == 0)then
      lpCtrls%dwSize = SIZEOF(lpCtrls)
      lpCtrls%dwICC  = ICC_BAR_CLASSES
      call InitCommonControlsEx(lpCtrls)
    end if
    hMenu = GetMenu(hWnd)
    if (StatusB.eq.1)go to 1
    hInst2 = GetWindowLong(hWnd, GWL_HINSTANCE)
    ghStatusWnd = CreateWindowEx(0, STATUSCLASSNAME,"宛名印刷"C, &
      IOR(WS_CHILD,IOR(WS_VISIBLE,SBARS_SIZEGRIP)),0,0,0,0, &
      hWnd,ID_STATUSBAR,hInst2,NULL)
    i = SendMessage(ghStatusWnd, SB_SETPARTS, 2, LOC(sbSize))
    StatusB = 1
    ICOLD = 1
    i = CheckMenuItem(hMenu,IDM_STATUSBAR,IOR(MF_BYCOMMAND,MF_CHECKED))
    b = GetClientRect(hWnd, grect)
    b = GetWindowRect(ghStatusWnd, rcstatus)
    gnStatusH = rcstatus%bottom - rcstatus%top
    grect%top = grect%top + gnToolH
    grect%bottom = grect%bottom - gnStatusH
    b = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
    go to 9
  1 i = DestroyWindow(ghStatusWnd)
    StatusB = 2
    i = CheckMenuItem(hMenu,IDM_STATUSBAR,IOR(MF_BYCOMMAND,MF_UNCHECKED))
    gnStatusH = 0
    b = GetClientRect(hWnd, grect)
    b = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
  9 return
!
Entry StatusBarSz(hWnd,IC)
    if (StatusB.NE.1) return
    i = SendMessage(ghStatusWnd, WM_SIZE, 0, 0)  ! Adjust to the window
    if(IC > 0) ICOLD = IC
    i = SendMessage(ghStatusWnd, SB_SETTEXT, 1, LOC(ST(ICOLD)//""C))
    return
end

!*********************************************************************
!*  ToolBar Subroutine called by WM_TOOLBAR event.
!*        2001.02.13   2001.02.16   Y.AKATSUKA
!*********************************************************************
Subroutine ToolBar(hWnd)
use WININT
use ADDRESS_inc
use comctl32
type (T_TBBUTTON) tbb(3)  ! int  iBitmap,idCommand
                          ! BYTE fsState,fsStyle,bReserved(2)
                          ! DWORD dwData
                          ! int iString
type (T_TBADDBITMAP) tba  ! HINSTANCE hInst
                          ! UINT nID
type (T_RECT) rctool
type (T_INITCOMMONCONTROLSEX) lpCtrls
integer*4 hWnd
integer*4 hInst2, hToolWnd, hMenu, ToolB/0/
logical   b
character buf*120
save hToolWnd
    if (ToolB == 0)then
      lpCtrls%dwSize = SIZEOF(lpCtrls)
      lpCtrls%dwICC  = ICC_BAR_CLASSES
      call InitCommonControlsEx(lpCtrls)
    end if
    hMenu = GetMenu(hWnd)
    if (ToolB.eq.1)go to 1
    hInst2 = GetWindowLong(hWnd, GWL_HINSTANCE)
    tbb=(/T_TBBUTTON(STD_FILEOPEN,IDM_INPUT,TBSTATE_ENABLED,TBSTYLE_BUTTON,0,0,0), &
          T_TBBUTTON(STD_PRINTPRE,IDM_PREVIEW,TBSTATE_ENABLED,TBSTYLE_BUTTON,0,0,0), &
          T_TBBUTTON(STD_PRINT,IDM_PRINT,TBSTATE_ENABLED,TBSTYLE_BUTTON,0,0,0)/)
    hToolWnd = CreateToolbarEx(hWnd,IOR(WS_CHILD,IOR(WS_BORDER,IOR(WS_VISIBLE, &
          TBSTYLE_TOOLTIPS))),ID_TOOLBAR,0,hInst2,NULL,tbb,3,0,0,0,0,SIZEOF(tbb(1)))
    tba%hInst= HINST_COMMCTRL
    tba%nID  = IDB_STD_SMALL_COLOR
    istdid   = SendMessage(hToolWnd, TB_ADDBITMAP, 3, LOC(tba))
!   tbb(1)%iBitmap = tbb(1)%iBitmap + istdid
!   tbb(2)%iBitmap = tbb(2)%iBitmap + istdid
!   tbb(3)%iBitmap = tbb(3)%iBitmap + istdid
!   i = SendMessage(hToolWnd, TB_ADDBUTTONS, 3, LOC(tbb))
    ToolB = 1
    i = CheckMenuItem(hMenu,IDM_TOOLBAR,IOR(MF_BYCOMMAND,MF_CHECKED))
    b = GetClientRect(hWnd, grect)
    b = GetWindowRect(hToolWnd, rctool)
    gnToolH = rctool%bottom - rctool%top - 1
    grect%top = grect%top + gnToolH
    grect%bottom = grect%bottom - gnStatusH
    go to 9
  1 i = DestroyWindow(hToolWnd)
    ToolB = 2
    i = CheckMenuItem(hMenu,IDM_TOOLBAR,IOR(MF_BYCOMMAND,MF_UNCHECKED))
    gnToolH = 0
    b = GetClientRect(hWnd, grect)
    b = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
  9 return
!
Entry ToolBarSz(hWnd)
    if (ToolB.ne.1)go to 8
    i = SendMessage(hToolWnd, TB_AUTOSIZE, 0, 0)
  8 return
End

!*********************************************************************
!*  SetScrollRanges Subroutine called by WM_SIZE event.
!*        2000.07.06   2002.03.08   Y.AKATSUKA
!*********************************************************************
subroutine SetScrollRanges(hWnd, lParam)
use WININT
type (T_RECT) rc
integer*4 hWnd,wParam,lParam,dx,dy,RangeX,RangeY
logical b
character buf*80
    gvPos = 0
    gsiv%Size = SIZEOF(gsiv)     ! Size of Info structure
    gsiv%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    gsiv%Min = 0                 ! Minimum scrolling position
    gsiv%Max = gwy               ! Maximum scrolling position
    gsiv%Page= grect%bottom-grect%top ! Page scrolling size
    gsiv%Pos = gvPos             ! Position of the scroll box
    gsiv%TrackPos = 0
    RangeY  = gwy - gsiv%Page    ! Scrolling range
    i = SetScrollInfo (hWnd, SB_VERT, gsiv, .TRUE.)
!
    ghPos = 0
    gsih%Size = SIZEOF(gsih)     ! Size of Info structure
    gsih%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    gsih%Min = 0                 ! Minimum scrolling position
    gsih%Max = gwx               ! Maximum scrolling position
    gsih%Page= grect%right       ! Page scrolling size
    gsih%Pos = ghPos             ! Position of the scroll box
    gsih%TrackPos = 0
    RangeX  = gwx - gsih%Page    ! Scrolling range
    i = SetScrollInfo (hWnd, SB_HORZ, gsih, .TRUE.)
    return
!=====================================================================
!*  vScroolBar Entry Subroutine.
!=====================================================================
entry vScrollBar(hWnd, wParam, lParam)
    select case (LoWord(wParam))
    case (SB_LINEUP)
      dy = -30
    case (SB_LINEDOWN)
      dy = 30
    case (SB_PAGEUP)
      dy = -gsiv%Page
    case (SB_PAGEDOWN)
      dy = gsiv%Page
    case (SB_THUMBPOSITION)
      dy = HiWord(wParam) - gsiv%Pos
    case (SB_THUMBTRACK)
      dy = HiWord(wParam) - gsiv%Pos
    case default
      dy = 0
    end select
    dy = MAX(-gsiv%Pos, MIN(dy, RangeY - gsiv%Pos))
    if(dy /= 0) then
      gsiv%Pos = gsiv%Pos + dy
      gvPos = gsiv%Pos
      i = SetScrollInfo(hWnd, SB_VERT, gsiv, .TRUE.)
      i = ScrollWindowEx(hWnd, 0, -dy, grect, grect, 0, &
                         NULL_RECT, SW_INVALIDATE)
    end if
    return
!=====================================================================
!*  hScrollBar Subroutine Entry.
!=====================================================================
entry hScrollBar(hWnd, wParam, lParam)
    select case (LoWord(wParam))
    case (SB_LINELEFT)
      dx = -10
    case (SB_LINERIGHT)
      dx = 10
    case (SB_PAGELEFT)
      dx = -gsih%Page
    case (SB_PAGERIGHT)
      dx = gsih%Page
    case (SB_THUMBPOSITION)
      dx = HiWord(wParam) - gsih%Pos  ! wParam : current position
    case (SB_THUMBTRACK)
      dx = HiWord(wParam) - gsih%Pos
    case default
      dx = 0
    end select
    dx = MAX(-gsih%Pos, MIN(dx, RangeX - gsih%Pos))
    if(dx /= 0) then
      gsih%Pos = gsih%Pos + dx
      ghPos = gsih%Pos
      i = SetScrollInfo(hWnd, SB_HORZ, gsih, .TRUE.)
      i = ScrollWindowEx(hWnd, -dx, 0, NULL_RECT, grect, 0, &
                        NULL_RECT, SW_INVALIDATE)
    end if
return
end

!********************************************************************
!*  ChdWind child window create.
!*    2001.02.27   Y.AKATSUKA
!********************************************************************
subroutine ChdWind(hWnd, mesg, wParam, lParam)
use WININT

interface
integer(4) function ChdWndProc(hChdWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_ChdWndProc@16' :: ChdWndProc
integer hChdWnd, mesg, wParam, lParam
end function
end interface

type (T_WNDCLASS) wc
integer*4 hWnd, mesg, wParam, lParam, hInst
character*20 lpszClassName,lpszAppName,lpszMenuName,lpszIconName
character buf*80
     ID_CHILD = 1900
     hInst = GetWindowLong(hWnd, GWL_HINSTANCE)
     lpszClassName="ChdWind"C
     lpszAppName  ="ChdWind"C
     wc%lpszClassName = LOC(lpszClassName)
     wc%lpfnWndProc   = LOC(ChdWndProc)
     wc%style         = IOR(CS_VREDRAW, CS_HREDRAW)
     wc%hInstance     = hInst
     wc%hIcon         = NULL
     wc%hCursor       = LoadCursor(NULL, IDC_ARROW)
     wc%hbrBackground = (COLOR_WINDOW +2)    ! +1:white +2:black
     wc%lpszMenuName  = 0
     wc%cbClsExtra    = 0
     wc%cbWndExtra    = 0
     i = RegisterClass(wc)
     ghChdWnd = CreateWindowEx(0,lpszClassName, & ! Window Class name
                  lpszAppName,              & ! Window name
                  IOR(WS_CHILD,WS_VISIBLE), & ! Window style
                  0,0,                      & ! L/U x,y position
                  grect%right,              & ! Width
                  grect%bottom,             & ! Height
                  hWnd,                     & ! Parent Window handle
                  ID_CHILD,                 & ! Menu handle
                  hInst,                    & ! Instance handle
                  NULL)                       ! Message pointer to lParam
     i = UpdateWindow(ghChdWnd)
return
end
!
!*********************************************************************
!*  ChdWndProc Function.
!*        2000.12.22   2001.03.07   Y.AKATSUKA
!*********************************************************************
integer*4 function ChdWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_ChdWndProc@16' :: ChdWndProc
use WININT
use ADDRESS_inc

interface
integer(4) function DlgLstProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgLstProc@16' :: DlgLstProc
integer hWnd, mesg, wParam, lParam
end function
end interface

integer hWnd,mesg,wParam,lParam
logical b
character buf*80
    select case (mesg)
    case (WM_CREATE)
!     i = MessageBox(ghParent,"WM_CREATE"C,"ChdWndProc"C,MB_OK)
    case (WM_SIZE)
      b = GetClientRect(hWnd, grect)
      call SetScrollRanges(hWnd, lParam)
      if(ghLstDlg /= 0) i = MoveWindow(ghLstDlg, 0, 0, &
          grect%right-grect%left, grect%bottom-grect%top, TRUE)
    case (WM_PAINT)
      CALL GDISP(hWnd, mesg, wParam, lParam)
      call StatusBarSz(hWnd,0)
    case (WM_VSCROLL)
      call vScrollBar(hWnd, wParam ,lParam)
    case (WM_HSCROLL)
      call hScrollBar(hWnd, wParam ,lParam)
    case (WM_MYLSTMSG)
      ghLstDlg = CreateDialogParam(ghInst,LOC("LSTDLG"C),hWnd,LOC(DlgLstProc),0)
    case (WM_KEYDOWN)
      select case (wParam)
      case (VK_UP)
        b = SendMessage(hWnd,WM_VSCROLL,SB_LINEUP,0)
      case (VK_DOWN)
        b = SendMessage(hWnd,WM_VSCROLL,SB_LINEDOWN,0)
      case (VK_LEFT)
        b = SendMessage(hWnd,WM_HSCROLL,SB_LINEUP,0)
      case (VK_RIGHT)
        b = SendMessage(hWnd,WM_HSCROLL,SB_LINEDOWN,0)
      case (VK_RETURN)
        b = InvalidateRect(hWnd, NULL_RECT, .TRUE.) ! reflesh window
      case DEFAULT
        ChdWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
        return
      end select
    case (WM_CLOSE)
    case (WM_DESTROY)
      call StatusBarSz(hWnd,1)
      i = SetFocus(ghParent)
    case DEFAULT
      ChdWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
      return
    end select
end function ChdWndProc

!********************************************************************
!*  DlgProc function called from WinMainProc.
!*    Select 'INPUT' of Menu items.
!********************************************************************
integer*4 function DlgProc(hDlg, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgProc@16' :: DlgProc
use DIALOG1
use WININT
character  buf*80,SHID*16
logical(4) b
integer    hDlg, mesg, wParam, lParam
type (T_RECT) rectp
    lParam = lParam
!
    select case (mesg)
    case (WM_INITDIALOG)
!     i = MessageBox(ghParent, "DlgProc"C, "DlgProc"C, MB_OK)
      call StatusBarSz(hWnd,2)
      SHID = ""C
      gSQLDTNO = -1
      b = SetDlgItemText(hDlg, DID_SID, "カタカナ  "C)
      DlgProc = 1         ! TRUE
      return
    case (WM_DESTROY)
      ghWndDlg = 0
      DlgProc = 1
      return
    case (WM_COMMAND)
      select case (LOWORD(wParam))
      case (DID_ALL)        ! ALL key
        i = EndDialog(hDlg, DID_ALL)
        i = DestroyWindow(hDlg)
        gwx = MAX(640,(gSIDNO/25+1)*70+40)
        gwy = 450
        CALL GETSID         ! Fetch all data
        i = SendMessage(ghChdWnd, 701, 0, 0)  ! ==> DlgLstProc
        b = InvalidateRect(ghParent, NULL_RECT, .TRUE.)
        DlgProc = 1
        return
      case (DID_OK)         ! OK key
        CALL GETSID         ! Fetch all data
        i = GetDlgItemText(hDlg, DID_SID, SHID, 16)
        CALL ADDRESS(SHID)          ! ==> ADDRESS
        i = EndDialog(hDlg, DID_OK)
        i = DestroyWindow(hDlg)
        gwx = 640
        gwy = MAX(480, gSQLDTNO*30+41)
        call StatusBarSz(hWnd,1)
        b = InvalidateRect(ghParent, NULL_RECT, .TRUE.)
        DlgProc = 1
        return
      case (DID_CANCEL)     ! Cancel key
        i = EndDialog(hDlg, DID_CANCEL)
        i = DestroyWindow(hDlg)
        call StatusBarSz(hWnd,1)
        b = InvalidateRect(ghParent, NULL_RECT, .TRUE.)
        DlgProc = 1
        return
      end select  !/* wParam */
    case DEFAULT
      DlgProc = 0 ! FALSE
    end select    !/* message */
return
end function DlgProc
!
!********************************************************************
!*  DlgLstProc function called from ChdWndProc Posted by DlgProc.
!*    Selected as All of DataBase.
!********************************************************************
integer*4 function DlgLstProc(hDlg, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgLstProc@16' :: DlgLstProc
use DlgLst1
use WININT
character  buf*100
logical(4) b
integer    hDlg, mesg, wParam, lParam, hCtl
    lparam = lparam
!
    select case (mesg)
    case (WM_INITDIALOG)
      i = MoveWindow(hDlg, 0, 0, &
          grect%right-grect%left, grect%bottom-grect%top, TRUE)
      b = EnableScrollBar(ghChdWnd,SB_BOTH,ESB_DISABLE_BOTH)
      hCtl = GetDlgItem(hDlg, IDC_LIST)
      b = SendMessage(hCtl, LB_SETCOLUMNWIDTH, 120, 0)   ! 120:dot size
      do J = 1,gSIDNO    ! MIN(gSIDNO,120)
        b = SendMessage(hCtl,LB_INSERTSTRING,J-1,LOC(gSYID(J)(18:33)//""C))
      end do
      gSQLDTNO = -2
      DlgLstProc = 1     ! .TRUE.
      return
    case (WM_DESTROY)
      b = EnableScrollBar(ghChdWnd,SB_BOTH,ESB_ENABLE_BOTH)
      call StatusBarSz(hWnd,1)
      ghLstDlg = 0
      DlgLstProc = 1     ! .TRUE.
      return
    case (WM_COMMAND)
      select case (LOWORD(wParam))
      case (ID_OK)       ! OK key
        gLcount = MIN(SendMessage(hCtl,LB_GETSELCOUNT,0,0),900)
        gLcount = SendMessage(hCtl,LB_GETSELITEMS,gLcount,LOC(gList))
        gMaxPage = gLcount
        if(gLcount.EQ.0) gMaxPage = gSIDNO
        i = EndDialog(hDlg, ID_OK)
        i = DestroyWindow(hDlg)
        gSQLDTNO = 0
        DlgLstProc = 1
        return
      case (ID_CANCEL)   ! Cancel key
        i = EndDialog(hDlg, ID_CANCEL)
        i = DestroyWindow(hDlg)
        gSQLDTNO = -1
        DlgLstProc = 1
        return
      case default
        DlgLstProc = 0
        return
      end select   !/* wParam */
    case default
      DlgLstProc = 0 ! .FALSE.
    end select     !/* message */
return
end function DlgLstProc
!
!********************************************************************
!*  DlgFrmProc function called from WinMain.
!*    Select the size of envelope.
!********************************************************************
integer*4 function DlgFrmProc(hDlg, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgFrmProc@16' :: DlgFrmProc
use DlgLst1
use WININT
character  buf*100,Form(3)*10
logical(4) b
integer    hDlg, mesg, wParam, lParam, hCtl
data       Form/"定型長3号","定型外2号","定型外3号"/
    lParam = lParam   ! Unreferenced variables
!
    select case (mesg)
    case (WM_INITDIALOG)
      call StatusBarSz(hDlg,5)
      hCtl = GetDlgItem(hDlg, IDC_FORM)
      do J = 1,3
        b = SendMessage(hCtl,CB_INSERTSTRING,J-1,LOC(Form(J)//""C))
      end do
      b = SendMessage(hCtl,CB_SETCURSEL,gFcount,0)   ! Default edit control
      DlgFrmProc = 1
      return
    case (WM_COMMAND)
      select case (LOWORD(wParam))
      case (ID_OK)       ! OK key
        gFcount = SendMessage(hCtl, CB_GETCURSEL, 0, 0)
        i = EndDialog(hDlg, ID_OK)
        i = DestroyWindow(hDlg)
        b = InvalidateRect(ghParent, NULL_RECT, .TRUE.)
        b = InvalidateRect(ghPrvWnd, NULL_RECT, .TRUE.)
        call StatusBarSz(hWnd,1)
        DlgFrmProc = 1
        return
      case (ID_CANCEL)   ! Cancel key
        i = EndDialog(hDlg, ID_CANCEL)
        i = DestroyWindow(hDlg)
        b = InvalidateRect(ghParent, NULL_RECT, .TRUE.)
        call StatusBarSz(hWnd,1)
        DlgFrmProc = 1
        return
      end select  !/* wParam */
    end select    !/* message */
    DlgFrmProc = 0
return
end function DlgFrmProc
!
!********************************************************************
!*  PREVIEW child window create. Select 'PREVIEW' of Menu items.
!*    2001.02.19  IDM_PREVIEW ==> PREVIEW
!********************************************************************
subroutine PREVIEW(hWnd, mesg, wParam, lParam)
use WININT

interface
integer(4) function PrvWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_PrvWndProc@16' :: PrvWndProc
integer hWnd, mesg, wParam, lParam
end function
end interface

type (T_WNDCLASS) wc
integer*4 hWnd, mesg, wParam, lParam, hInst
character*20 lpszClassName,lpszAppName,lpszMenuName,lpszIconName
character buf*80
     hInst = ghInst   ! GetWindowLong(hWnd, GWL_HINSTANCE)
     lpszIconName    = "ADDRESS"C
     wc%lpszClassName= LOC("PREVIEW"C)
     wc%lpfnWndProc  = LOC(PrvWndProc)
     wc%style        = IOR(CS_VREDRAW, CS_HREDRAW)
     wc%hInstance    = hInst
     wc%hIcon        = LoadIcon(hInst, LOC(lpszIconName))  ! NULL
     wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
     wc%hbrBackground= DKGRAY_BRUSH
     wc%lpszMenuName = NULL
     wc%cbClsExtra   = 0
     wc%cbWndExtra   = 0
     i = RegisterClass(wc)
     ghPrvWnd = CreateWindow("PREVIEW"C, & ! Window Class name
                 "PREVIEW"C,             & ! Window name
                 IOR(WS_OVERLAPPED,IOR(WS_CAPTION,IOR(WS_THICKFRAME,  &
                   IOR(WS_SYSMENU,WS_MAXIMIZEBOX)))), & ! Window style
                 CW_USEDEFAULT,-29,      & ! L/U x,y position
                 IFIX(FLOAT(grc%bottom-29)*288.0/396.9), & ! Width
                 grc%bottom,             & ! Height
                 hWnd,                   & ! Parent Window handle
                 NULL,                   & ! Menu handle
                 hInst,                  & ! Instance handle
                 NULL)                     ! Message pointer to lParam
      i = ShowWindow(ghPrvWnd, SW_SHOW) ! SW_SHOW : Window Display Type
      i = UpdateWindow(ghPrvWnd)        ! Issue WM_PAINT message
return
end
!
!*********************************************************************
!*  PrvWndProc Function.
!*        Print Preview Procedure.
!*********************************************************************
integer*4 function PrvWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_PrvWndProc@16' :: PrvWndProc
use WININT
integer hWnd,mesg,wParam,lParam
logical b
character buf*80
    select case (mesg)
    case (WM_CREATE)
!     i = MessageBox(ghParent, "WM_CREATE"C, "PrvWndProc"C, MB_OK)
      call StatusBarSz(hWnd,3)
      gPage = 1
    case (WM_SIZE)
      b = GetClientRect(hWnd, gchdrc)
    case (WM_PAINT)
      CALL GDISP2(hWnd, mesg, wParam, lParam)
      write(buf,'(I5,1X,A)')gPage," ページ"C
      b = SetWindowText(ghPrvWnd,buf)
    case (WM_CLOSE)
      id = MessageBox(ghParent,"終了するよ"C,"プレビュー終了確認"C, &
                     IOR(MB_YESNO,MB_ICONQUESTION))
      if (id.eq.IDYES) i = DestroyWindow(hWnd)
    case (WM_KEYDOWN)
      select case (wParam)
      case (VK_RETURN)
        if(gPage.LT.gMaxPage) gPage = gPage + 1
        b = InvalidateRect(hWnd, NULL_RECT, .TRUE.) ! reflesh window
      case (VK_PRIOR)
        if(gPage.GT.1) gPage = gPage - 1
        b = InvalidateRect(hWnd, NULL_RECT, .TRUE.) ! reflesh window
      case (VK_NEXT)
        if(gPage.LT.gMaxPage) gPage = gPage + 1
        b = InvalidateRect(hWnd, NULL_RECT, .TRUE.) ! reflesh window
      case DEFAULT
        PrvWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
        return
      end select
    case (WM_DESTROY)
      call StatusBarSz(hWnd,1)
    case DEFAULT
      PrvWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
      return
    end select
end function PrvWndProc

!*********************************************************************
!*  GDISP SUBROUTINE    ChdWndProc(WM_PAINT) ==> GDISP
!*********************************************************************
      SUBROUTINE GDISP(hWnd, mesg, wParam, lParam)
      INTEGER*4  hWnd, mesg, wParam, lParam, hDC
      CALL GINT   (hWnd,hDC,mesg,wParam,lParam)
      CALL SHOWBMP(hWnd,hDC)
      CALL SIDDSP (hWnd,hDC)
      CALL TXTDSP (hWnd,hDC)
      CALL GEND
      RETURN
      END
!*********************************************************************
!*  GDISP2 ENTRY for PREVIEW  PrvWndProc(WM_PAINT) ==> GDISP2
!*********************************************************************
      SUBROUTINE GDISP2(hWnd, mesg, wParam, lParam)
      use WININT
      INTEGER*4  hWnd, mesg, wParam, lParam, hDC
      gXMAX = IFIX(FLOAT(grc%bottom-29)*2880.0/3969.0)
      gYMAX = grc%bottom-29
      gXoffset = (gchdrc%right-gXMAX)/2
      gYoffset = gchdrc%top
      CALL GINT (hWnd,hDC,mesg,wParam,lParam)
      CALL XINT (hWnd,hDC,0)    ! 0 : Display
      CALL XYSUB(hWnd,0)        ! ==> FORM1 ==> XVIEWP
      CALL XEND
      CALL GEND
      RETURN
      END
!*********************************************************************
!*  PRINT ENTRY   MainWndProc(WM_PRINT) ==> PRINT
!*********************************************************************
      SUBROUTINE PRINT(hWnd, mesg, wParam, lParam)
      use WININT
      INTEGER*4  hWnd, mesg, wParam, lParam, hDC
      IF(gSIDNO.EQ.0)GO TO 9
      CALL PINTS(hWnd,hDC,mesg,wParam,lParam)
      if(gINTPRN .LT. 0)GO TO 9 ! Printer error
      CALL XINT (hWnd,hDC,1)    ! 1 : Printer
      CALL XYSUB(hWnd,1)        ! ==> FORM1 ==> XVIEWP
      CALL XEND
      CALL PEND
    9 RETURN
      END

!*********************************************************************
!*  XYSUB SUBROUTINE called from GDISP2,PRINT
!*********************************************************************
SUBROUTINE XYSUB(hWnd,ID)
use WININT
integer hWnd,hDC
character buf*80
      nPage = 0
      IF(gSIDNO.EQ.0)GO TO 9       ! gSIDNO : number of source data
      IF(gSQLDTNO.NE.1)GO TO 1
      CALL FORM1(gIX)              ! ==> XVIEWP
      GO TO 9
    1 DO 20 N=1,gSIDNO
      if(gCancel)go to 9           ! Print Cancel ?
      IF(gLcount.EQ.0)GO TO 3      ! select all ?
      DO 10 J=0,gLcount-1
      IF(N-1.EQ.gList(J))GO TO 3
   10 CONTINUE
      GO TO 20
    3 nPage = nPage + 1
      IF(ID.EQ.0)GO TO 4           ! Display ?
      gSYID(N)(1:1) = "1"          ! print sign
      GO TO 5
    4 IF(nPage.NE.gPage)GO TO 20
    5 CALL FORM1(N)                ! ==> XVIEWP
      IF(ID.EQ.0)GO TO 20          ! Display ?
      write(buf,'(I5," ページ",A)')nPage,""C
      b = SetWindowText(hWnd,buf)
      hDC = GetDC(hWnd)            ! Get Display device context
      CALL SIDDSP(hWnd,hDC)        ! Change color of item
      b = ReleaseDC(hWnd, hDC)
      b = UpdateWindow(hWnd)
   20 CONTINUE
    9 RETURN
      END

!*********************************************************************
!*    OPNSID SUBROUTINE.  Open data file.
!*********************************************************************
 SUBROUTINE OPNSID(hWnd)
 use WININT
 use ADDRESS_inc
 type (T_OPENFILENAME) ofn
 integer hWnd
 logical b
 CHARACTER buf*80,NA*16,UTR*16
!character DSN*100/"E:\\Program Files\\DevStudio\\MyProjects\\WINDOW10\\ADDRESS.TXT"C/
 character DSN*100/"C:\\Program Files\\Microsoft Visual Studio\\MyProjects\\WINDOW10\\ADDRESS.TXT"C/
 character*100 :: filter = "TextFiles"C//"*.txt"C//"All Files"C//"*.*"C//""C
!
      ofn%lStructSize = SIZEOF(ofn)
      ofn%hwndOwner   = hWnd
      ofn%hInstance   = ghInst
      ofn%lpstrFilter = LOC(filter)
      ofn%lpstrCustomFilter = NULL
      ofn%nMaxCustFilter = 0
      ofn%nFilterIndex= 1              ! Specifies initial filter value
      ofn%lpstrFile   = LOC(DSN)
      ofn%nMaxFile    = SIZEOF(DSN)
      ofn%nMaxFileTitle = 0
      ofn%lpstrInitialDir = LOC("C:"C) ! (NULL:Windows default directry)
      ofn%lpstrTitle  = LOC(""C)
      ofn%Flags       = OFN_PATHMUSTEXIST
      ofn%lpstrDefExt = LOC("txt"C)
      ofn%lpfnHook    = NULL
      ofn%lpTemplateName = NULL
      b = GetOpenFileName(ofn)    ! Call GetOpenFileName and check status
      if (b) then
        len = INDEX(DSN, ""C) ! Get the length of file_spec
        if (DSN(len-3:len-1) == 'txt' .OR. DSN(len-3:len-1) == 'TXT') then
          i = SendMessage(hWnd, WM_COMMAND, IDM_INPUT, 0)   ! IDM_INPUT
          gSQLDTNO = -1
          gSIDNO = 0
        end if
      else
        i = MessageBox(hWnd, "No file name specified"C, "Open"C, MB_OK)
      end if
      RETURN
!=====================================================================
!*    GETSID ENTRY.  Read all data.  DlgProc ==> GETSID
!=====================================================================
      ENTRY GETSID
      gSQLDTNO = -1
      IF(gSIDNO.NE.0)GO TO 19
      OPEN(11,FILE=DSN,ACTION='READ',ERR=8,STATUS='OLD')
      GO TO 1
    8 i = MessageBox(NULL,"OPEN ERROR "//DSN//""C,"GETSID"C,MB_OK)
      GO TO 19
    1 gSIDNO = gSIDNO + 1
      gSYID(gSIDNO)(1:1) = ' '   ! print sign
      READ(11,'(A)',END=9)gSYID(gSIDNO)(2:143)
      GO TO 1
    9 gSIDNO = gSIDNO - 1
      CLOSE(11)
   19 RETURN
!=====================================================================
!*    ADDRESS ENTRY.   Get one of the data.
!=====================================================================
      ENTRY ADDRESS(NA)
      IF(NA(1:16).EQ.UTR(1:16))GO TO 99
      UTR(1:16)=NA(1:16)
      gSQLDTNO = -1       ! No Fetched data
      DO L = 1,16
       IF(NA(L:L).LE.CHAR(32))GO TO 2
      END DO
      L = 17
    2 L = L - 1
      DO 10 gIX=1,gSIDNO
      IF(NA(1:L).EQ.gSYID(gIX)(2:L+1))GO TO 3
   10 CONTINUE
      GO TO 99
    3 UTR(1:16)=gSYID(gIX)(2:17)
      gMaxPage = 1
      gSQLDTNO = 1        ! Fetched data
   99 RETURN
      END

!*********************************************************************
!   GINT,GEND SUBROUTINE
!         2000.03.20   2000.08.16   Y.AKATSUKA
!*********************************************************************
SUBROUTINE GINT(hWd, hDC, mesg, wParam, lParam)
use WININT
type (T_PAINTSTRUCT) ps
     INTEGER*4 hWnd, mesg, wParam, lParam, hWd, hDC
     logical(4) b
     hWnd = hWd            ! save for GEND
     hDC = BeginPaint(hWnd, ps)    ! ==> EndPaint
     b = SetViewportOrgEx(hDC,0,INT4(HiWord(lParam)),NULL_POINT)
     RETURN
!=====================================================================
!*  GEND ENTRY FOR GDISP SECTION.
!=====================================================================
ENTRY GEND
     b = EndPaint(hWnd, ps)        ! <== BeginPaint
     RETURN
     END
!
!*********************************************************************
!*   PINTS,PEND SUBROUTINE FOR WIN PRINT.
!*        V01L003  2002.03.13   Y.AKATSUKA
!*********************************************************************
SUBROUTINE PINTS(hWnd, DC, mesg, wParam, lParam)
use WININT
interface
integer(4) function MyPrnCancelProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyPrnCancelProc@16' :: MyPrnCancelProc
integer hWnd, mesg, wParam, lParam
end function MyPrnCancelProc

logical function MyAbortProc(hDC, Code)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyAbortProc@8' :: MyAbortProc
integer hDC, Code
end function MyAbortProc
end interface

integer  hWnd, mesg, wParam, lParam
INTEGER  HWD, hDCmem, hBmBuffer
INTEGER  hDC, DC     ! Define printer device context
SAVE     hDC, HWD
INTEGER  page_width, page_height, line_height ! pixelsx, pixelsy
LOGICAL(4) b
CHARACTER  buf*80
type (T_PRINTDLG) Pdlg
type (T_DEVMODE)  Dm
type (T_DOCINFO)  Di
type (T_BITMAPINFO) lpbi
   HWD = hWnd
   gINTPRN = -1
!  Initialize Pdlg structure.
   Pdlg%lStructSize = SIZEOF(Pdlg)
   Pdlg%hwndOwner = NULL
   Pdlg%hDevMode  = NULL
   Pdlg%hDevNames = NULL
   Pdlg%hDc       = NULL
   Pdlg%Flags     = IOR(PD_RETURNDC,IOR(PD_NOPAGENUMS,PD_NOSELECTION))
   Pdlg%nFromPage = 1
   Pdlg%nToPage   = 1
   Pdlg%nMinPage  = 1
   Pdlg%nMaxPage  = 1
   Pdlg%nCopies   = 1
   Pdlg%hInstance = NULL
   Pdlg%lCustData = NULL
   Pdlg%lpfnPrintHook = NULL
   Pdlg%lpfnSetupHook = NULL
   Pdlg%lpPrintTemplateName = NULL
   Pdlg%lpSetupTemplateName = NULL
   Pdlg%hPrintTemplate = NULL
   Pdlg%hSetupTemplate = NULL
   b = PrintDlg(Pdlg)      ! Show printer dialog box.
   if (.NOT. b) then       ! Nonzero return value is OK.
     i = CommDlgExtendedError()
     return
   end if
!  Bring up the Print dialog box and allow user to select printer.
   hDC = Pdlg%hDc
   DC  = hDC       ! Set subroutine parameter
!  ResetDC
   Dm%dmsize       = SIZEOF(Dm)
   Dm%dmFields     = IOR(DM_ORIENTATION,DM_PAPERSIZE)
   Dm%dmOrientation= DMORIENT_PORTRAIT
   Dm%dmPaperSize  = DMPAPER_A4
   hDC0 = ResetDC(hDC,Dm)
!* Create Cancel Dialog
   ghCancelDlg = CreateDialogParam(ghInst, LOC("PRNSTOP"C), HWD, &
                 LOC(MyPrnCancelProc), 0)
   i = ShowWindow(ghCancelDlg, SW_SHOW)
   i = EnableWindow(HWD,.FALSE.)   ! Unavailable Main Window
   i = SetAbortProc(hDC, LOC(MyAbortProc))
!* Initialize DOCINFO structure
   Di%cbSize = SIZEOF(Di)
   Di%lpszDocName = LOC("Address Document"C)
   Di%lpszOutput  = NULL
   Di%lpszDatatype= NULL
   Di%fwType      = 0
!* Start Print
   i = StartDoc(hDC, Di)   ! Return value is print job identifier (>0)
   if (i == SP_ERROR) then ! SP_ERROR = -1
     i = EnableWindow(HWD,.TRUE.)
     i = SetFocus(HWD)
     i = DestroyWindow(ghCancelDlg)
     return
   end if
!*  BitmapInfo (DUMMY)
   lpbi%bmiHeader%biSize         = SIZEOF(lpbi%bmiHeader)
   lpbi%bmiHeader%biWidth        = 10
   lpbi%bmiHeader%biHeight       = 10
   lpbi%bmiHeader%biPlanes       = 1
   lpbi%bmiHeader%biBitcount     = 1
   lpbi%bmiHeader%biCompression  = BI_RGB
   lpbi%bmiHeader%biSizeImage    = 0
   lpbi%bmiHeader%biXPelsPermeter= 0
   lpbi%bmiHeader%biYPelsPerMeter= 0
   lpbi%bmiHeader%biClrUsed      = 0
   lpbi%bmiHeader%biClrImportant = 0
   hDCmem = CreateCompatibleDC(hDC)
   hBmBuffer = CreateDIBSection(hDCmem,lpbi,DIB_RGB_COLORS,LOC(lpBits), &
               NULL,0)
   i = SelectObject(hDCmem, hBmBuffer)
!  Get various metrics for this printer.
   gXoffset = GetDeviceCaps(hDC,PHYSICALOFFSETX) ! 43
   gYoffset = GetDeviceCaps(hDC,PHYSICALOFFSETY) ! 43
   page_width  = GetDeviceCaps(hDC,HORZRES)      ! 2880
   page_height = GetDeviceCaps(hDC,VERTRES)      ! 3969
   gXMAX = page_width - gXoffset -1
   gYMAX = page_height- gYoffset -1
   gINTPRN = 0
   RETURN
!=====================================================================
!*  PSTART ENTRY FOR PRINT SECTION.
!=====================================================================
   ENTRY  PSTART
   IF(gINTPRN.GT.0) i = EndPage(hDC)        ! End the page
!* Start Page
   gINTPRN = StartPage(hDC) + gINTPRN       ! Start the page
   b = BitBlt(hDC,0,0,1,1,hDCmem,0,0,SRCCOPY)  ! DUMMY
   i = SendMessage(ghCancelDlg, 3001, 0, 0) ! ==> MyPrnCancelProc
   RETURN
!=====================================================================
!*  PEND ENTRY FOR PRINT SECTION.
!=====================================================================
   ENTRY  PEND
   i = EndPage(hDC)        ! End the page
   if (gCancel) then
     i = AbortDoc(hDC)
     i = MessageBox(NULL, "印刷をキャンセルしました"C, "PRINT"C, MB_OK)
   else
     i = EndDoc(hDC)       ! End the document
   end if
   i = EnableWindow(HWD,.TRUE.)
   i = SetFocus(HWD)
   i = DestroyWindow(ghCancelDlg)
   ghCancelDlg = 0
   b = DeleteDC(hDC)       ! Delete the device context
   b = InvalidateRect(HWD, NULL_RECT, .FALSE.)
   b = DeleteDC(hDCmem)    ! Delete the memory device context (DUMMY)
   i = DeleteObject(hBmBuffer)   ! (DUMMY)
   RETURN
   END
!
!*********************************************************************
!*  MyPrnCancelProc Function.
!*********************************************************************
integer*4 FUNCTION MyPrnCancelProc(hWnd,msg,wp,lp)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyPrnCancelProc@16' :: MyPrnCancelProc
use WININT
integer hWnd,msg,wp,lp, hDC
character buf*80
    lp = lp ! dummy
    select case ( msg )
    case (WM_INITDIALOG)
      i = SetFocus(hWnd)
      gCancel = .FALSE.
      MyPrnCancelProc = 1
      return
    case (3001)
      hDC = GetDC(hWnd)
      i = SetBkMode(hDC, TRANSPARENT)     ! TRANSPARENT | OPAQUE
      b = FillRgn(hDC,CreateRectRgn(20,26,60,46),GetStockObject(LTGRAY_BRUSH))
      write(buf,'(I4)')gINTPRN
      b = TextOut (hDC,20,26,buf,4)
      b = ReleaseDC(hWnd, hDC)
      i = SetFocus(hWnd)
      MyPrnCancelProc = 1
      return
    case (WM_COMMAND)
      if (LOWORD(wp) == IDCANCEL) then
        gCancel = .TRUE.
        MyPrnCancelProc = 1
        return
      end if
    case DEFAULT
    end select
    MyPrnCancelProc = 0
    RETURN
    END
!
!*********************************************************************
!*  MyAbortProc Function.
!*********************************************************************
logical FUNCTION MyAbortProc(hDC, Code)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MyAbortProc@8' :: MyAbortProc
use WININT
type (T_MSG) msg
integer hDC, Code
    do while(.NOT. gCancel .AND. PeekMessage(msg,NULL,0,0,PM_REMOVE))
      if(.NOT. IsDialogMessage(ghCancelDlg, msg)) then
        i = TranslateMessage(msg)
        i = DispatchMessage(msg)
      end if
    end do
    MyAbortProc = .NOT. gCancel
    RETURN
    END

!*********************************************************************
!*  SHOWBMP SUBROUTINE USED FOR INITIAL VIEW
!*********************************************************************
SUBROUTINE SHOWBMP(hWnd, hDC)
use WININT
type (T_BITMAP) bmp
    INTEGER*4 hWnd, hDC, hInst, hDCmem, hBitmap/0/
    LOGICAL*4 b
    character buf*80
    if (gSQLDTNO /= -1) RETURN
    if (hBitmaP /= 0)go to 1
    hInst = GetWindowLong(hWnd, GWL_HINSTANCE)
    hBitmap = LoadBitmap(hInst, LOC("MYBMP"C))
    i = GetObject(hBitmap, SIZEOF(bmp), LOC(bmp))
    gwx = bmp%bmWidth
    gwy = bmp%bmHeight
    hDCmem = CreateCompatibleDC(hDC)
    i = SelectObject(hDCmem, hBitmap)
  1 b = BitBlt(hDC,-ghPos,-gvPos+grect%top,gwx,gwy,hDCmem,0,0,SRCCOPY)
    return
!=====================================================================
!*  ENDBMP ENTRY  Release compatible DC memory.
!=====================================================================
    ENTRY ENDBMP(hWnd)
    b = DeleteDC(hDCmem)
    b = DeleteObject(hBitmap)
    hBitmap = 0
    RETURN
    END

!*********************************************************************
!*  TXTDSP SUBROUTINE.    GDISP ==> TXTDSP
!*  Display selected name and address.
!*********************************************************************
    SUBROUTINE TXTDSP(hWnd,hDC)
    USE WININT
    INTEGER  hWnd, hDC, hPenT, iCol, hFont
    LOGICAL  b
    character UD*142,buf*80
    if (gSQLDTNO /= 1)go to 9
    b = FillRect(hDC, grect, GetStockObject(BLACK_BRUSH))
    iCol = RGB(INT1(0),INT1(-1),INT1(-1))
    hPenT = CreatePen(PS_SOLID, 1, iCol)
    i = SelectObject(hDC, hPenT)
    b = MoveToEx(hDC, -ghPos, -gvPos, NULL_POINT) ! set position
    b = LineTo  (hDC, -ghPos, gwy-gvPos-1)        ! draw line to
    b = LineTo  (hDC, gwx-ghPos, gwy-gvPos-1)
    b = LineTo  (hDC, gwx-ghPos, -gvPos)
    b = LineTo  (hDC, -ghPos, -gvPos)
    b = DeleteObject(hPenT)
!
    hFont = CreateFont(24,12, 0, 0, 0, 0, 0, 0, SHIFTJIS_CHARSET, 0, &
            0, 0, IOR(INT(DEFAULT_PITCH), INT(FF_ROMAN)), "MS 明朝"C)
    i = SetTextColor(hDC, gColor)    ! define Fonts color
    i = SetBkMode(hDC, TRANSPARENT)  ! TRANSPARENT | OPAQUE
    i = SelectObject(hDC, hFont)
    UD(1:142) = gSYID(gIX)(2:143)
    i = RectanglX(hDC,40,10,500,300)
    b = TextOutX (hDC,50,40,UD( 33: 48),16)     ! AdrCd
    b = TextOutX (hDC,50,70,UD( 49:118),70)     ! Address
    buf(1:16)=UD(17:32)
    DO I=15,1,-2
    IF(buf(I:I+1).NE." ")GO TO 1
    END DO
    I=1
  1 buf(I+2:I+5)=" 様"
    b = TextOutX (hDC,70,120,buf(1:I+5),I+5)    ! Name
    b = TextOutX (hDC,50,160,UD(119:142),24)    ! Phone
    b = DeleteObject(hFont)
  9 return
    END
!
    logical function TextOutX(hDC,xp,yp,text,l)
    use WININT
    integer hDC,xp,yp,l
    character text*(*)
    TextOutX = TextOut(hDC,xp-ghPos,yp-gvPos,text,l)
    return
    end function
!
    integer function RectanglX(hDC,xl,yl,xu,yu)
    use WININT
    integer hDC,xl,yl,xu,yu
    logical b
    RectanglX = Rectangle(hDC,xl-ghPos,yl-gvPos,xu-ghPos,yu-gvPos)
    return
    end function

!*********************************************************************
!*  SIDDSP SUBROUTINE.
!*  Display seleted names.
!*********************************************************************
    SUBROUTINE SIDDSP(hWnd,hDC)
    USE WININT
    INTEGER  hWnd,hDC,hPenT,hFntS,hPenOld
    INTEGER  ICOL,ICOL1/#0000FF00/,ICOL2/#00FFFFFF/
    LOGICAL  b
    character buf*20
    if (gSIDNO == 0 .OR. gSQLDTNO /= 0)go to 9
    b = FillRect(hDC, grect, GetStockObject(BLACK_BRUSH))
    ICOL = ICOL1
    hPenT = CreatePen(PS_SOLID, 1, RGB(INT1(0),INT1(-1),INT1(-1)))
    hPenOld = SelectObject(hDC, hPenT)            ! Save old pen style
    i = SelectObject(hDC, hPenT)
    b = MoveToEx(hDC, -ghPos, -gvPos, NULL_POINT) ! set position
    b = LineTo  (hDC, -ghPos, gwy-gvPos-1)        ! draw line to
    b = LineTo  (hDC, gwx-ghPos, gwy-gvPos-1)
    b = LineTo  (hDC, gwx-ghPos, -gvPos)
    b = LineTo  (hDC, -ghPos, -gvPos)
    i = SelectObject(hDC, hPenOld)                ! Recover old pen style
    b = DeleteObject(hPenT)
!   Define font size
!   Height=24, Width=10, Escape=0/10, Orient=0/10, Weight=0, Italic=0,
!   Underline=0, StrikeOut=0, CharSet=ANSI_CHARSET, Precision=0,
!   ClipPrecision=CLIP_DEFAULT_PRECIS, Quality=DEFAULT_QUALITY,
!   Pitch=(DEFAULT_PITCH,FF_ROMAN),Face="Times New Roman"
    hFntS = CreateFont(14, 8, 0, 0, 0, 0, 0, 0, SHIFTJIS_CHARSET, 0, &
            0, 0, IOR(INT(DEFAULT_PITCH), INT(FF_ROMAN)), "MS 明朝"C)
    i = SetTextColor(hDC, RGB(INT1(0),INT1(-1),INT1(0)))
    i = SetBkMode(hDC, TRANSPARENT)  ! TRANSPARENT | OPAQUE
    i = SelectObject(hDC, hFntS)
    b = TextOutX (hDC,10, 10,"名前一覧",8)
    L = gLcount
    if(L.EQ.0)L = gSIDNO
    write(buf,'(I5,1X,A)')L,"件"
    b = TextOutX (hDC,200, 10,buf(3:8),6)
    N = 0
    NOW = 0
    LCOL=30
    LIN =16
  2 N = N + 1
    IF(N.GT.gSIDNO)GO TO 1
    IF(gLcount.EQ.0)GO TO 3
    DO 30 J=0,gLcount-1
    IF(N-1.EQ.gList(J))GO TO 3
 30 CONTINUE
    GO TO 2
  3 IF(LIN.LT.416)GO TO 4
    LCOL=LCOL+120
    LIN=16
  4 LIN = LIN+16
    IF(gSYID(N)(1:1).NE."1")GO TO 6
    NOW = N
    IF(ICOL.EQ.ICOL2)GO TO 8         ! white ?
    ICOL = ICOL2
    GO TO 7
  6 IF(ICOL.EQ.ICOL1)GO TO 8         ! green ?
    ICOL = ICOL1
  7 i = SetTextColor(hDC, ICOL)      ! define Fonts color
  8 b = TextOutX(hDC,LCOL,LIN,gSYID(N)(18:33),16)
    GO TO 2
  1 b = ReleaseDC(hWnd, hDC)
    i = SelectObject(hDC, ghFont)
    b = DeleteObject(hFntS)
  9 return
    END

! *****************************************************************
! *   FORM1 MAIN FORM     XYSUB ==> FORM1                         *
! *****************************************************************
      SUBROUTINE FORM1(N)
      USE WININT
      REAL*4 FORM(0:3)/0.708,1.0,0.834,1.0/
      CHARACTER UTR*142,W*70
      character buf*80
!     DATA UTR(1:16)/'タケウチ    '/, &
!     UTR( 17: 32)/'竹内 結子    '/, &
!     UTR( 33: 48)/'184−0021  '/, &
!     UTR( 49:118)/'埼玉県所沢市青葉台780−6 '/, &
!     UTR(119:142)/'0123−45−6789'/
      UTR(1:142) = gSYID(N)(2:143)
      CALL XVIEWP(0.0,0.0,19.3,26.5)
      CALL FRAME1(0.0,0.0,19.3,26.5)
      HS = FORM(gFcount)
      CALL FRAME(1.0,26.0-12.0*HS,16.6*HS,26.0)
      Point  = gchf%iPointSize    ! in units of 1/10 of a point
      HE = Point * 0.003528
! === ADDRESS ===
      YP=24.5
      CALL SPCHK(UTR(33:48),W,8,K)
      CALL JCHAR(1.8,YP,HE,W,0.0,K)               ! POST-NO
      CALL SPCHK(UTR(49:118),W,35,K)
      XP=1.8
      K2=K+K-1
      J=1
    1 DO 10 I=J,K2,2
      IF(W(I:I+1).NE.' ')GO TO 10
      YP=YP-HE*2.0
      CALL JCHAR(XP,YP,HE,W(J:I+1),0.0,(I-J)/2)   ! ADDRESS
      XP=2.4
      GO TO 2
   10 CONTINUE
      I=K2
      YP=YP-HE*2.0
      CALL JCHAR(XP,YP,HE,W(J:I+1),0.0,(I-J+2)/2) ! ADDRESS
    2 J=I+2
      IF(J.LT.K2)GO TO 1
! === NAME ===
    3 CALL SPCHK(UTR(17:32),W, 8,K)
      W(K*2+1:K*2+4)=' 様'
      YP=YP-HE*3.0
      H = HE
      IF(H*FLOAT(K+2).GT.15.0)H=15.0/FLOAT(K+2)
      CALL JCHAR(XP+HE,YP,H,W,0.0,K+2)            ! NAME
! === TEL ===
!     CALL SPCHKE(UTR(119:142),W,24,K)
!     CALL SYMBOL(3.0,15.0,0.35,W,0.0,K)          ! TEL
! =================================================================
      RETURN
      END

!*********************************************************************
!*  XINT SUBROUTINE FOR WIN PRINT.
!*        V01L001  2000.03.13
!*        V01L002  2001.01.11   Y.AKATSUKA
!*********************************************************************
SUBROUTINE XINT(WND,DC,IDSP)
use gdi32
use WININT   ! gXoffset,gYoffset,gXMAX,gYMAX
COMMON /S1COM/JOBNO(3),NDATE(8),JOBCLS,NBLOCK,NXX,NXSIZE,NTIME, &
    KFL(10),NgXMAX,NBMAX,MAXBUF,NBYTE,KPEN,NPEN,KFAC,JNEW,JOLD,IOPEN, &
    XL,XU,YL,YU,AXP,AYP,OLDX,OLDY,XX,YY,XP,YP,XOLD1,YOLD1,XMV,DUMMY, &
    FAC0,FAC,FACT,FSTEP,RTH,SRTH,CRTH,B0,A0,HI1,HI2,HI3,DI1,DI2, &
    DI3,HLIN,XU0,XL0,XHABA,YHABA,NKETA,D4,THA,DUM5(5),IBUFF(134)
INTEGER    WND,hWnd   ! Window handle of the dialog box
INTEGER    DC,hDC     ! Device context
SAVE       hWnd,hDC,IDP
INTEGER(4) hPenX,hPenOld,ITH(6)/1,8,14,1,8,14/,IST(6)/0,0,0,1,1,1/
integer*4  IP(8)/Z'00000000',Z'000000FF',Z'0000FF00',Z'00FF0000', &
                 Z'0000FFFF',Z'00FFFF00',Z'00FF00FF',Z'00FFFFFF'/
LOGICAL(4) b
type (T_RECT)   rc
CHARACTER  buf*100
CHARACTER  JSTR*(*),STR*(*) ! JCHAR,SYMBOL
DATA OLDTH,S,C/0.0,0.0,1.0/ ! JCHAR
     FX(X,Y)= (X*CRTH-Y*SRTH)*FAC+AXP
     FY(X,Y)= (Y*CRTH+X*SRTH)*FAC+AYP
     IFX(X) = (X-XL)*FAHV+gXoffset
     IFY(Y) = gYMAX-(Y-YL)*FAHV+gYoffset
!==================================================================
      hWnd = WND
      hDC  = DC
      IDP  = IDSP
!==================================================================
      FAC0=1.0
      FSTEP=80.0
      B0=1.0
      A0=1.0
      HI1=0.14
      HI2=0.21
      HI3=0.28
      DI1=0.38
      DI2=0.825
      DI3=0.178
      HLIN=0.2
      XU0=12.5
      XL0=-12.5
      XHABA=100.0
      YHABA=25.0
      NKETA=2
      D4  = 0.254
      THA = 0.0
      FTR = 1.0
      hPenX = 0
      RETURN
!=====================================================================
!*   XVIEWP ROUTINE ALTERNATE                                        *
!=====================================================================
ENTRY XVIEWP(XPL,YPL,XPU,YPU)
      IF(IDP.EQ.1)CALL PSTART   ! Printer start for only print
      XL=XPL
      YL=YPL
      XU=XPU
      YU=YPU
!     write(buf,*)XL,YL,XU,YU,gXMAX,gYMAX,""C
!     i = MessageBox(hWnd, buf, "XVIEWP"C, MB_OK)
      SX = FLOAT(gYMAX)/FLOAT(gXMAX)   ! 729/498
      SY = FLOAT(gXMAX)/FLOAT(gYMAX)
      XD=XU-XL
      YD=YU-YL
      IF(YD.LT.XD*SX)GO TO 4
      FAHV=gYMAX/YD
      XU=XL+AMIN1(XD*FTR,YD*SY)
      GO TO 5
    4 FAHV=gXMAX/XD
      YU=YL+AMIN1(YD*FTR,XD*SX)
    5 FACT=FTR
      FAC =FTR
      AXP=0.0
      AYP=0.0
      RTH=0.0
      SRTH=0.0
      CRTH=1.0
      NPEN=0
      JPEN=1
      LPEN=1
      IX1=IFX(XL)
      IY1=IFY(YL)
      IX2=IFX(XU)
      IY2=IFY(YU)
      X2=XL
      Y2=YL
      IG=1
      IF(hPenX.EQ.0)GO TO 6
      i = SelectObject(hDC, hPenOld)
      b = DeleteObject(hPenX)
    6 hPenX = CreatePen(IST(1), ITH(1), IP(1))
      hPenOld = SelectObject(hDC, hPenX)
      i = SetTextColor(hDC, gColor)     ! define Fonts color
!     i = SetTextColor(hDC, IP(1))      ! define Fonts color
      RETURN
!=====================================================================
!*   PLOT ROUTINE ALTERNATE                                          *
!*   2000.03.13      SCCISSORRING CHECK                              *
!=====================================================================
      ENTRY PLOT(PX,PY,MIPEN)
!     WRITE(buf,*)PX,PY,MIPEN,""C
!     i = MessageBox(NULL, buf, "PLOT"C, MB_OK)
      IF(MIPEN.EQ.999) GO TO 81
      XP=PX
      YP=PY
      IF(MIPEN)201,239,202
  201 AXP=FX(XP,YP)
      AYP=FY(XP,YP)
      XP=0.0
      YP=0.0
  202 XP1=FX(XP,YP)
      YP1=FY(XP,YP)
! === CODE =============================
      IC=0
      IF(XP1.GE.XL)GO TO 203
      IC=1
      GO TO 204
  203 IF(XP1.LE.XU)GO TO 204
      IC=2
  204 IF(YP1.GE.YL)GO TO 205
      IC=IC+4
      GO TO 206
  205 IF(YP1.LE.YU)GO TO 206
      IC=IC+8
! ======================================
  206 IF(IABS(MIPEN)-2)208,209,207
! ======================================
  207 IG=1
      IX1=IFX(XP1)
      IY1=IFY(YP1)
      GO TO 233
  208 IF(IG.EQ.1)GO TO 207
  209 X2=XP1
      DX=XP1-X1
      Y2=YP1
      DY=YP1-Y1
      ICB=IC
!     ICA=IA
! ======================================
  211 IF(ICA.EQ.0.AND.ICB.EQ.0)GO TO 231
      IF(IAND(ICA,ICB).NE.0)GO TO 232
! === COMPUTE NEW XY COORDINATE ========
      IW=ICB
      IF(ICA.NE.0)IW=ICA
      IF(IAND(IW,1).EQ.0)GO TO 212
      XW=XL
      GO TO 213
  212 IF(IAND(IW,2).EQ.0)GO TO 214
      XW=XU
  213 IF(ABS(DX).LT.0.0001)GO TO 239
      YW=(XW-X1)*DY/DX+Y1
      GO TO 221
  214 IF(IAND(IW,4).EQ.0)GO TO 215
      YW=YL
      GO TO 216
  215 YW=YU
  216 IF(ABS(DY).LT.0.0001)GO TO 239
      XW=(YW-Y1)*DX/DY+X1
! === RECODE ===========================
  221 IZ=0
      IF(XW.GE.XL)GO TO 222
      IZ=1
      GO TO 223
  222 IF(XW.LE.XU)GO TO 223
      IZ=2
  223 IF(YW.GE.YL)GO TO 224
      IZ=IZ+4
      GO TO 225
  224 IF(YW.LE.YU)GO TO 225
      IZ=IZ+8
! ======================================
  225 IF(IW.NE.ICA)GO TO 229
      X1=XW
      IX1=IFX(XW)
      Y1=YW
      IY1=IFY(YW)
      ICA=IZ
      IG=1
      GO TO 211
  229 X2=XW
      Y2=YW
      ICB=IZ
      GO TO 211
! === CLIPPING CHECK END ===============
  231 IXP=IFX(X2)
      IYP=IFY(Y2)
      IF(IG.EQ.1)GO TO 241
      IF(IXP.EQ.IX1.AND.IYP.EQ.IY1)GO TO 233
      GO TO 242
  241 b = MoveToEx(hDC,IX1,IY1,NULL_POINT) ! set position
  242 b = LineTo  (hDC,IXP,IYP)            ! draw line to
      IX1=IXP
      IY1=IYP
  232 IG=2
  233 X1=XP1
      Y1=YP1
!     IA=IC
      ICA=IC
  239 RETURN
!====================================================================
!*   NEWPEN ROUTINE ALTERNATE                                       *
!====================================================================
ENTRY CLRPEN(MIPEN)
ENTRY NLPPEN(MIPEN)
ENTRY NEWPEN(MIPEN)
      NPEN=IABS(MIPEN)
      NCPN=NPEN/10
      NPEN=NPEN-NCPN*10
      NPEN=MOD(NPEN-1,6)+1
      IF(NCPN.GT.7)NCPN=7
      IF(NPEN.EQ.JPEN)GO TO 28
      JPEN=NPEN
!     b = DeleteObject(hPenX)
!     hPenX = CreatePen(IST(NPEN), ITH(NPEN), IP(NCPN))
!     i = SelectObject(hDC, hPenX)
      i = SelectObject(hDC, hPenOld)
      b = DeleteObject(hPenX)
      hPenX = CreatePen(IST(NPEN), ITH(NPEN), IP(NCPN))
      hPenOld = SelectObject(hDC, hPenX)
   28 IF(NCPN.EQ.NCP0)GO TO 29
      NCP0=NCPN
      i = SetTextColor(hDC, IP(NCPN))     ! define Fonts color
   29 RETURN
!====================================================================
!*   FACTOR ROUTINE ALTERNATE                                       *
!====================================================================
ENTRY FACTOR(FATR)
      FAC=ABS(FATR)
      FACT=FAC/FAC0
      FSTEP=FACT*800.0/B0
      RETURN
!====================================================================
!*   FRAME1 ROUTINE ALTERNATE                                       *
!====================================================================
ENTRY FRAME1(PXL,PYL,PXU,PYU)
! Outlined by the current pen and filled by the current brush.
!     i = Rectangle(hDC,IFX(PXL),IFY(PYL),IFX(PXU),IFY(PYU))
      rc%left = IFX(PXL)
      rc%right= IFX(PXU)
      rc%top  = IFY(PYU)
      rc%bottom=IFY(PYL)
      i = FillRect(hDC, rc, GetStockObject(WHITE_BRUSH))
      RETURN
!====================================================================
!*   SYMBOL SUBROUTINE.  (SCALABLE FONT)                            *
!*   2000.06.14     V01L001 2000.06.14   Y.AKATSUKA                 *
!*                  V01L001 2000.06.14                              *
!====================================================================
ENTRY SYMBOL(PX,PY,HEIGHT,STR,THETA,N)
      H  = ABS(HEIGHT*1.2)
      TH = THETA
      glf%lfHeight = IFY(0) - IFY(H)
      glf%lfEscapement = THETA * 10.0
      glf%lfCharSet= DEFAULT_CHARSET
      glf%lfFaceName = "Times New Roman"C
      iFont= CreateFontIndirect(glf)
      IoldFont = SelectObject(hDC, iFont)
!     i = SetTextColor(hDC, gColor)     ! define Fonts color
      i = SetBkMode(hDC, TRANSPARENT)   ! TRANSPARENT | OPAQUE
      if(HEIGHT.LT.0)then
        iAline = SetTextAlign(hDC, IOR(TA_BOTTOM,TA_RIGHT))
      else
        iAline = SetTextAlign(hDC, IOR(TA_BOTTOM,TA_LEFT))
      end if
      PYH = PY - H * 0.1
      b = TextOut(hDC,IFX(FX(PX,PYH)),IFY(FY(PX,PYH)),STR,N)
      i = SelectObject(hDC, IoldFont)
      b = DeleteObject(iFont)
      RETURN
!====================================================================
!*   JCHAR  SUBROUTINE.  (SCALABLE KANJI FONT)                      *
!*   2000.05.25     V01L001 2000.05.25   Y.AKATSUKA                 *
!*                  V01L001 2000.06.01                              *
!====================================================================
ENTRY JCHAR(PX,PY,HEIGHT,JSTR,THETA,N)
      NN = MOD(N,1000)*2
      H  = ABS(HEIGHT)
      TH = THETA
      Point = gchf%iPointSize    ! in units of 1/10 of a point
      glf%lfHeight = IFY(0) - IFY(Point * 0.003528)
      glf%lfEscapement = THETA * 10.0
      iFont= CreateFontIndirect(glf)
      IoldFont = SelectObject(hDC, iFont)
!     i = SetTextColor(hDC, gColor)      ! define Fonts color
      i = SetBkMode(hDC, TRANSPARENT)    ! TRANSPARENT | OPAQUE
      if(HEIGHT.LT.0)then
        iAline = SetTextAlign(hDC, IOR(TA_BOTTOM,TA_RIGHT))
      else
        iAline = SetTextAlign(hDC, IOR(TA_BOTTOM,TA_LEFT))
      end if
      b = TextOut(hDC,IFX(FX(PX,PY)),IFY(FY(PX,PY)),JSTR,NN)
      i = SelectObject(hDC, IoldFont)
      b = DeleteObject(iFont)
      RETURN
!====================================================================
!*   XEND ROUTINE ALTERNATE                                         *
!====================================================================
ENTRY XEND
      i = SelectObject(hDC, hPenOld)
      b = DeleteObject(hPenX)
   81 RETURN
END

!********************************************************************
!*   FRAME ROUTINE                                                  *
!*          1998.08.31    Y.AKATSUKA                                *
!********************************************************************
SUBROUTINE FRAME(XL,YL,XU,YU)
      COMMON /S1COM/IDUM1(36),XL0,XU0,YL0,YU0,IDUM2(174)
      OPTIONAL :: XL,YL,XU,YU
      IF(PRESENT(XL))GO TO 1
      XL=XL0
      YL=YL0
      XU=XU0
      YU=YU0
    1 CALL PLOT(XL,YL,3)
      CALL PLOT(XL,YU,2)
      CALL PLOT(XU,YU,2)
      CALL PLOT(XU,YL,2)
      CALL PLOT(XL,YL,2)
      RETURN
      END

! *****************************************************************
! *   SPCHK SUBROUTINE                                            *
! *****************************************************************
      SUBROUTINE SPCHK(C,W,L,K)
      CHARACTER C*(*),W*(*)
      DO 10 I=1,L
      J=I*2-1
      W(J:J+1)=C(J:J+1)
   10 CONTINUE
      DO 20 K=L,1,-1
      J=K*2-1
      IF(W(J:J).EQ.' '.OR.W(J:J+1).EQ.' ')GO TO 20
      GO TO 1
   20 CONTINUE
    1 RETURN
!
      ENTRY SPCHKE(C,W,L,K)
      W(1:L)=C(1:L)
      DO 30 K=L,1,-1
      IF(C(K:K).NE.' ')GO TO 2
   30 CONTINUE
    2 RETURN
      END

!*********************************************************************
!   AboutDlgProc is called from WinMain.
!   Processes messages for "About" dialog box.
!
!   Display version information from the version section of the
!   application resource.
!   Wait for user to click on "Ok" button, then close the dialog box.
!*********************************************************************
integer*4 function AboutDlgProc(hDlg, message, uParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_AboutDlgProc@16' :: AboutDlgProc
use WININT
use ADDRESS_inc
integer    hDlg        ! window handle of the dialog box
integer    message     ! type of message
integer    uParam      ! message-specific information
integer    lParam
integer*4  hfontDlg
save       hfontDlg

integer    dwVerHnd, dwVerInfoSize, uVersionLen
character*256   szFullPath, szResult, szGetName, lpversion
integer*4  lpstrVffInfo, hMem
  lparam = lparam
  select case (message)
  case (WM_INITDIALOG)   ! message: initialize dialog box
     ! Create a font to use
     hfontDlg = CreateFont(14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
                IOR(INT(VARIABLE_PITCH), INT(FF_SWISS)), ""C)
     ! Get version information from the application
     i = GetModuleFileName(INT(ghInst), szFullPath, len(szFullPath))
     dwVerInfoSize = GetFileVersionInfoSize(szFullPath, LOC(dwVerHnd))
     if (dwVerInfoSize .NE. 0) then
       ! If we were able to get the information, process it:
       hMem = GlobalAlloc(GMEM_MOVEABLE, INT(dwVerInfoSize))
       lpstrVffInfo = GlobalLock(hMem)
       i = GetFileVersionInfo(szFullPath,dwVerHnd,dwVerInfoSize,lpstrVffInfo)
       ! Walk through the dialog items that we want to replace
       do j = DLG_VERFIRST, DLG_VERLAST
         ir = GetDlgItemText(hDlg, j, szResult, len(szResult))
         szGetName = "\\StringFileInfo\\040904E4\\"C
         i = lstrcat(szGetName,szResult)
         i = VersionQueryValue(lpstrVffInfo, LOC(szGetName), &
               LOC(lpVersion), LOC(uVersionLen))  ! For MIPS strictness
         if (ir .NE. 0) then
           ! Replace dialog item text with version info
           i = lstrcpy(szResult, lpVersion)
           i = SetDlgItemText(hDlg, j, szResult)
           i = SendMessage(GetDlgItem(hDlg, j), WM_SETFONT, hfontDlg, TRUE)
         end if
       end do
       i = GlobalUnlock(hMem)
       i = GlobalFree(hMem)
     end if
     AboutDlgProc = 1
     return
  case (WM_COMMAND)
     if ((LoWord(uParam).EQ.IDOK) .OR. (LoWord(uParam).EQ.IDCANCEL)) then
        i = EndDialog(hDlg, TRUE)
        i = DeleteObject(hfontDlg)
        AboutDlgProc = 1
        return
     end if
  end select
  AboutDlgProc = 0  ! Didn't process the message
  return
end

プログラムの解説

1) プログラムの概要

 このプログラムは,住所録を検索し必要な氏名を選択し宛名印刷を行うものです。プログラムを起動すると初期画面にビットマップ画像を表示します。 メニューのOptionでToolBarとStatusBarの項目を選択するとツールバーとステータスバーを表示します。

Optionメニュー

図11.2 Optionメニュー

 メニューからオープンするデータファイルを選択し,入力モードにするか,又は,ツールバーを表示しているときには”開く”ボタンをクリックすると,データベースを読み込み,氏名に相当するキーの入力を行うダイアログを表示します。このとき,ステータスバーを表示している場合には第2領域に「入力」と表示されます。

キー入力ダイアログ

図11.3 キー入力ダイアログ

 ここで特定のキーを入力するか,又は,全ての氏名一覧を表示するかを選択します。特定のキーをカナで入力すると,データベースを検索し該当するキーが存在したならば住所・氏名の情報を子ウィンドウに表示します。この段階で,メニューからプレビューを選択するとプレビューウィンドウが開き,プリンタに印刷したときの形式が確認できます。ステータスバーには「印刷プレビュー」と表示されます。

住所・氏名の情報とプレビュー画面

図11.4 住所・氏名の情報とプレビュー画面

 ALLを選択したときは,データベースに存在する氏名一覧を別のダイアログに表示します。

氏名選択ダイアログ

図11.5 氏名選択ダイアログ

 ダイアログの氏名一覧の中から宛名印刷をしたい氏名を選択すると,選択した氏名の一覧が子ウィンドウに表示されます。
 メニューからPrintを選択,又は,ツールバーの印刷アイコンをクリックするとプリンタに印刷を開始します。ステータスバーを表示している場合には「印刷中」と表示されます。
 また,メニューによって宛名ラベルの大きさや使用するフォントも選択できるようにしています。

2) 入力データの形式

 このプログラムで使用する入力データの形式を図11.6 に示します。本節ではツールバーやステイタスバーの使用法に重点を置いているので,データについてはFortranで簡単に扱える固定長形式のファイルを用いています。データは適当なエディタを用いて作成します。(氏名・住所はすべて架空のものです。)
 Accessなどのデータベースを利用する場合には,第1部の「10.データベースのアクセス」を参照してください。

入力データの形式

図11.6 入力データの形式

3) プログラムの説明

 では,プログラムを個々に見ていきましょう。ADDRESS_incというモジュール定義は,個々のプログラム単位で共通にインクルードして引用する定数を定義しています。
 モジュール定義WININTは,各プログラム単位で共通に用いる変数や構造体領域を定義しています。グローバル変数は先頭がgで始まるように命名しています。
 モジュール定義DIALOG1は,DlgProc関数で用います。DlgLst1は,DlgLstProc関数とDlgFrmProc関数で用いる定数を定義しています。

 WinMain関数は,今までのプログラムとほとんど同じでが,メッセージループにアクセラレータの処理を組み込んでいます。アクセラレータとは,メニューの項目を選択する代わりに特定のキーを入力することで同等の処理を行うようにするものです。ショートカットキーという言い方もあります。
 TranslateAccelerator関数は,キー入力をリソースファイルに記述されたコマンドに変換します。例えば,メニューの「入力」のショートカットキーを「コントロールキー+I」と定義するには,

   MENUITEM "&INPUT\tCtrl+I",      IDM_INPUT

のように記述します。

 MainWndProc関数は,各メッセージの処理を行います。
 WM_CREATEは,メインウィンドウが作成されたときに最初に実行します。SystemParametersInfo関数を用いて,デスクトップの作業領域の大きさを取得します。この関数を用いるとタスクバーを表示している場合には,その領域を除いた部分の大きさを取得することができます。取得した作業領域の大きさは,後でプレビューウィンドウを表示する時のウィンドウサイズを計算するのに用います。
 後はデフォルトフォントの設定,グローバル変数の初期値設定を行ったのち,子ウィンドウを作成するサブルーチンを実行します。
 WM_DESTROYでは,ENDBMPサブルーチンを実行し初期画像表示用バッファ等の返却を行い,ウィンドウのクローズ処理を行います。
 WM_SIZEでは,クライアント領域のサイズを取得し,ツールバーとステイタスバーのサイズを除いた領域を計算します。ToolBarSzとStatusBarSzサブルーチンを実行し,ツールバーとステイタスバーの再表示を行い,MoveWindow関数を用いて子ウィンドウの再表示を行います。
 WM_KEYDOWNでは,キー入力メッセージを子ウィンドウのプロシジャで処理できるようにPostMessage関数を用いて子ウィンドウにポストします。

 WM_COMMANDでは,入力されたメニューの処理を行います。
 IDM_OPENでは,OPNSIDサブルーチンを実行しデータベースファイルのオープンとデータの入力を行います。
 IDM_CLOSEでは,特に何もしていません。Accessなどのデータベースを用いるときにクローズ処理が必要になるかもしれません。
 IDM_PREVIEWでは,PREVIEWサブルーチンを実行し,選択されたデータの印刷プレビューを行います。
 IDM_PRINTでは,PRINTサブルーチンを実行し,選択されたデータの印刷処理を行います。前後にStatusBarSzサブルーチンを実行し,ステータスバーの第2領域に印刷開始時に印刷中の状態表示を行い,印刷が終了したら消去します。
 IDM_ABOUTでは,DialogBoxParam関数を実行し,ヘルプのAboutを表示します。
 IDM_INPUTでは,データベースからデータを選択する処理を行います。CreateDialogParam関数を実行し,データ入力のダイアログを表示します。
 IDM_FONTSでは,ChooseFont関数を用いて印刷時の文字フォントを選択し,CreateFontIndirect関数でフォントを作成します。処理の前後にはStatusBarSzサブルーチンを実行し,ステータスバーに「フォント選択」と状態表示します。選択されたフォントはInvalidateRect関数を実行し,プレビュー画面にも反映するようにします。
 IDM_FORMでは,CreateDialogParam関数を用いて印刷フォームを選択するダイアログを表示します。処理の前後にはStatusBarSzサブルーチンを実行し,ステータスバーに「フォーム選択」と状態表示します。
 IDM_TOOLBARでは,ToolBarサブルーチンを実行し,ツールバーのON/OFFの処理を行います。なお,PostMessage関数を用いてウィンドウサイズ変更をポストし,子ウィンドウの再表示を行います。
 IDM_STATUSBARでは,StatusBarサブルーチンを実行し,ステータスバーのON/OFFの処理を行います。なお,この時もPostMessage関数を用いてウィンドウサイズ変更をポストし,子ウィンドウの再表示を行います。
 IDM_HELPCONTENTSとIDM_HELPSEARCHでは,WinHelp関数を実行しヘルプ画面の表示を行います。WinHelp関数は旧Windows95タイプのヘルプを表示する関数です。Windows98以降ではHTMLタイプが標準になりましたので,ここでは説明は省略します。
 IDM_HELPHELPでは,WinHelp関数を実行しWindowsヘルプの表示を行います。
 WM_NOTIFYは,コントロールにイベントが発生したり、コントロールがある種の情報を必要としていることを親ウィンドウに通知するメッセージです。wParamはメッセージを送ってきたコントロールを,lParamはNMHDR構造体のポインタを示します。
 ツールチップの入力はTOOLTIPTEXT構造体に含まれるNMHDRのcodeを調べ,TTN_NEEDTEXTを捕らえます。
 TOOLTIPTEXT構造体のidFromを調べ,選択されたコントロールIDに対応するリソーステキストのID(コントロールIDと同じにしてあります)をlpszTextパラメータに設定します。

 StatusBarサブルーチンは,OptionメニューでStatusBarを選択したときに呼び出されます。
このサブルーチンが最初に呼ばれたときには,InitCommonControlsEx関数を実行してコモンコントロールを初期化します。
 CreateWindowEx関数を用いてステータスウィンドウを作成します。第2パラメータのウィンドウクラスには予め定義されているSTATUSCLASSNAMEを指定します。第3パラメータのウィンドウ名に文字列を指定すると第1領域に表示されます。第4パラメータのウィンドウスタイルには,WS_CHILD,WS_VISIBLE,SBARS_SIZEGRIPを指定しています。SBARS_SIZEGRIPパラメータはウィンドウ右下にサイズグリップを表示します。
 SendMessage関数を用いてステータスウィンドウにSB_SETPARTSメッセージを送り,領域の分割数とサイズを指定します。
 CheckMenuItem関数を用いてOptionメニューのStatusbarの項目にチェックを入れます。
 GetClientRect関数とGetWindowRect関数を用いて,子ウィンドウを表示できる領域を求めます。クライアント領域からステータスウィンドウを引いた領域を計算しグローバル変数にセットします。
 OptionメニューのStatusbarの項目が再度クリックされたときは,ステータスウィンドウを閉じ,メニューの当該項目のクリックを外します。

 StatusBarSzエントリーは,機会毎に呼び出され,ステータスウィンドウにWM_SIZEメッセージを発行します。
 SendMessage関数を用いてステータスウィンドウにSB_SETTEXTメッセージを発行し,ICパラメータの値によってステータスウィンドウの第2領域(順番は0から数えます)にプログラムの状態を説明する文字列を表示します。

 ToolBarサブルーチンは,OptionメニューでToolBarを選択したときに呼び出されます。
このサブルーチンが最初に呼ばれたときには,InitCommonControlsEx関数を実行してコモンコントロールを初期化します。既にステータスウィンドウを表示するときに実行していればパスしてもかまいません。
 ボタン3つ分のT_TBBUTTON構造体を用意し,予めシステムに用意されているSTD_FILEOPEN,STD_PRINTPRE,STD_PRINTのボタンをセットし,CreateToolbarEx関数を用いてツールバーを作成します。このとき第2パラメータのウィンドウスタイルにTBSTYLE_TOOLTIPSを指定するとツールチップスの表示が可能になります。
 TBADDBITMAP構造体にボタンイメージの情報をセットし,SendMessage関数を用いてツールバーウィンドウにTB_ADDBITMAPメッセージを送ります。IDB_STD_SMALL_COLORを指定し,小さいカラー標準ビットマップを追加します。
 ステータスウィンドウと同様に,CheckMenuItem関数を用いてOptionメニューのToolBarの項目にチェックを入れ,表示可能領域を再計算します。
 OptionメニューのToolBarの項目が再度クリックされたときは,ステータスウィンドウを閉じ,メニューの当該項目のクリックを外します。

 ToolBarSzエントリーは,ウィンドウサイズが変更されたときに呼び出されます。
 SendMessage関数を用いてTB_AUTOSIZEメッセージを発行します。親ウィンドウのサイズに合せてツールバーを再描画します。

 ChdWindサブルーチンは,メインウィンドウのクライアント領域からツールバーとステータスバーを除いた領域に子ウィンドウを作成します。
 ウィンドウの作成方法は,メインウィンドウを作成する方法に類似しています。CreateWindowEx関数を実行するときのウィンドウスタイルにWS_CHILDを指定し,メニューハンドルには適当な子ウィンドウのIDを設定します。

 ChdWndProc関数は,作成した子ウィンドウに対するメッセージの処理を行います。基本的な処理はメインウィンドウの処理と同様に行います。
 WM_SIZEメセージを処理するときは,ダイアログが表示されている場合にはMoveWindow関数を用いてダイアログを移動再表示しています。
 WM_PAINTでは,GDISPサブルーチンを呼んで画面表示を行い,StatusBarSzルーチンを実行してステータスバーの状態再表示を行います。
 WM_MYLSTMSGは,DlgProc関数の中から登録データの一覧表示を選択したときに発行されます。CreateDialogParam関数を実行して登録データの一覧表示ダイアログを表示します。
 WM_KEYDOWNでは,マウス操作の代わりに矢印キーを用いてウィンドウのスクロールを実現するための処理を記述しています。SendMessage関数は,メッセージキューを経由しないで処理されます。
 WM_DESTROYでは,ステータス表示をクリアし,フォーカスを親ウィンドウに与えます。
 このプロシジャで処理しないメッセージは,DefWindowProc関数に処理を任せます。

 DlgProc関数は,メニューでINPUTを選択したときにMainWndProc関数から呼び出されて実行する関数です。この関数は宛名印刷を行いたいデータをデータベースから選択するためのダイアログです。
 WM_INITDIALOGは,WM_CREATEに相当するメッセージでダイアログが作成されたときに最初に実行します。ダイアログ処理の初期設定を行い,ステータスバーには「入力」と状態表示します。ダイアログには氏名入力欄とALL,OK,CANCELの3つのボタンが表示されます。
 WM_COMMANDでは,押された3つのボタンについての処理を記述します。
 DID_ALLは,ALLボタンが押されたときの処理です。ダイアログを閉じGETSIDサブルーチンを実行してデータベースを読み込みます。SendMessage関数を用いて子ウィンドウのプロシジャにWM_MYLSTMSG(701)メッセージを送り,氏名一覧を表示するダイアログの表示を依頼します。
 DID_OKは,OKボタンが押されたときの処理です。GETSIDサブルーチンを実行しデータベースを読み込みます。GetDlgItemText関数を実行し,ダイアログに入力されたキーを読み取ります。ADDRESSサブルーチン(GETSIDのエントリ)を実行し,入力されたキーに対するレコードを共通領域に読み込みます。ダイアログを閉じ,ステータスバーの状態表示をクリアし,親ウィンドウの画面を再表示します。
 DID_CANCELは,Cancelボタンが押されたときの処理です。ダイアログを閉じ,ステータスバーの状態表示をクリアし,親ウィンドウの画面を再表示します。

 DlgLstProc関数は,データベースに登録されている全データを表示して,そのなかから印刷データを選択するためのダイアログです。DlgProc関数のDID_ALL処理でWM_MYLSTMSGメッセージを発行したときにChdWndProc関数から呼び出されます。
 WM_INITDIALOGは,ダイアログが作成されたときに実行します。MoveWindow関数を用いて表示位置を固定します。EnableScrollBar関数を用いて,子ウィンドウのスクロール機能を停止します。スクロールを停止しないと子ウィンドウの上に表示されているダイアログ自体がスクロールされてしまいます。
 GetDlgItem関数を実行し,氏名一覧を表示するリストボックスのコントロールハンドルを取得します。SendMessage関数を用いてLB_SETCOLUMNWIDTHメッセージでリストボックスに表示する1データあたりの桁数をドット単位に指定します。表示するデータは,SendMessage関数でLB_INSERTSTRINGメッセージを用いてデータの数だけ転送します。
 WM_DESTROYでは,EnableScrollBar関数を用いて禁止した親ウィンドウのスクロールを可能にした後,ステータスバーの状態表示をクリアします。
 WM_COMMANDのID_OKはOKボタンが押されたときの処理を行います。SendMessage関数を用いて,指定されたデータの数と項目のリストを共通領域に取得します。データの数はLB_GETSELCOUNTメッセージを,項目のリストはLB_GETSELITEMSメッセージを用いて取得します。不要になったダイログは閉じます。
 ID_CANCELはCancelボタンが押されたときに実行し,不要になったダイログを破棄します。

 DlgFrmProc関数は,メニューでFormを選択したときに起動する印刷フォームのサイズを選択するダイアログの処理を記述します。印刷封筒の大きさに合せて宛名印刷の大きさを選択する場合に用います。このプログラムでは3種類の封筒サイズが選択できるようにしてありますが,実用するには使用する封筒や葉書に合せて調節する必要があります。
 WM_INITDIALOGでは,ステータスバーに「フォーム選択」と表示した後,GetDlgItem関数でコントロールボックスのコントロールハンドルを取得します。SendMessage関数でCB_INSERTSTRINGメッセージを用いてコントロールボックスに表示する宛名サイズを表した文字列を設定します。このプログラムでは,定型長3号","定型外2号","定型外3号"という文字列を設定しています。同様にCB_SETCURSELメッセージをデフォルトの文字列を選択した状態にします。
 WM_COMMANDのID_OKはOKボタンが押されたときの処理を行います。SendMessage関数で,CB_GETCURSELメッセージを用いてコントロールボックスからカーソルで指定された項目の番号を取得します。ステータスバーの状態表示をクリアし,ダイアログを閉じます。
 ID_CANCELは,ステータスバーの状態表示をクリアし,ダイアログを閉じます。

 PREVIEWサブルーチンは,メニューでPreviewを選択したときに呼び出され,印刷と同等画面をディスプレイ表示します。スクリーンに入る大きさのオーバーラップウィンドウを作成し,メッセージ処理を行う手続き関数を設定します。ウィンドウのバックグラウウンドカラーにはDKGRAY_BRUSHを指定しています。

 PrvWndProc関数は,プレビューウィンドウに対する処理を記述します。
 WM_CREATEでは,ステータスバーに「印刷プレビュー」と表示し,表示ページを表す変数に1をセットします。
 WM_PAINTでは,GDISP2サブルーチンを実行し,印刷画面と同等の画面表示を行います。 WM_KEYDOWNでは,複数の表示ページがあるときに押されたキーによって表示ページを前後に移動する処理を記述します。
 VK_RETURNとVK_NEXTは,ENTERキーとPageDownキーを押された場合で表示ページを1ページ進める同じ処理を行います。
 VK_PRIORは,PageUpキーが押された場合で表示ページを1ページ前に戻す処理を行います。
 WM_DESTROYは,ウィンドウを閉じるときに実行し,ステータスバーの表示をクリアします。

 GDISPサブルーチンは,ChdWndProc関数からPAINTメッセージを処理するときに呼び出されます。 GINTとGENDサブルーチンでは画面表示の初期設定と後処理を行います。SHOWBMPサブルーチンは,ウィンドウの初期画面を表示します。SIDDSPサブルーチンは,氏名一覧ダイアログで選択した氏名の一覧を表示します。TXTDSPサブルーチンは,最初のダイアログで特定のキーを入力したときの住所・氏名の情報を表示します。いずれのサブルーチンもグローバル変数の値を調べ表示が必要なときのみ実行します。

 GDISP2サブルーチンは,プレビューウィンドウでPAINTメッセージを処理するときに呼び出され,印刷データを画面に表示します。印刷処理を行うサブルーチンを共有して用います。そのため,画面サイズをウィンドウのサイズに設定しておきます。

 PRINTサブルーチンは,印刷処理を実行します。PINTSとPENDで印刷処理の開始と終了処理を行います。印刷処理については,第10章の解説を参照してください。

 XYSUBサブルーチンは,PRINT又はGDISP2サブルーチンから呼ばれ,印刷又はプレビューするデータを制御します。印刷時には,グローバル変数のテーブルに印刷済みフラグをセットし,SetWindowText関数を用いてメインウィンドウのタイトルバーに印刷ページ数を表示します。SIDDSPサブルーチンを実行し,印刷氏名一覧を表示し,印刷済みの氏名は緑から白に変更して表示します。

 SIDDSPサブルーチンは,メニューで「Open」を選択したときにMainWndProc関数から呼び出されます。GetOpenFileName関数を用いてデータベースのファイル名を取得します。DSN変数にはデフォルトのファイル名をセットしておきます。
 GETSIDエントリーは,メニューで「Input」を選択したときに呼び出され,FortranのOPEN文を用いてデータベースをオープンし,全データをグローバル領域に読み込みます。
 ADDRESSエントリーは,氏名入力ダイアログを処理するDlgProc関数で個々の氏名を入力しOKボタンが押されたときに呼び出されます。既にグローバル変数領域に読み込まれた全データから入力されたキーに該当するデータを検索し,グローバル変数gIXにデータの位置を設定します。

 説明が長くなりましたが,その他の部分は既に今までの章で解説済みの部分がほとんどです。プログラムと対応させれば容易に理解できると思います。


目次 次の項目

12.データ入力(コモンダイアログ)


12.1 コモンダイアログによるデータ入力

 Windowsプログラムでは,Fortranの標準入出力を用いてデータを入出力することはできません。 データ入力用のコモンダイアログを用いるのが便利です。

図12.1 コモンダイアログ

 コモンダイアログは,既に今までのプログラムでも用いていましたが,数値の入力やチェックボックス,ボタンスイッチなどを用いる方法を紹介します。

 図12.1はコモンダイアログのサンプルです。文字や数値を入力するエディットボックス,項目を選択するチェックボックス,それに今までにも用いたボタンが4つ付いています。

 今回はコモンダイアログの使用法を解説するにあたり,画像ファイルの周期ノイズを除去するプログラムを作成します。

 折角入手したきれいなお姉さんの画像に周期的な横線又は縦線の縞模様状ノイズが入っていてがっかりした経験があるかも知れません。 使用したスキャナやデジカメによってはこうしたノイズが乗る可能性があります。 そこで,ノイズを消去することを考えるわけですが,一般の画像処理ソフトでは画像ファイルのノイズ消去にはメディアンフィルタが多く用いられています。 しかし,メディアンフィルタを用いて周期的なノイズを消去しようとすると画質の大幅な低下が避けられません。 フーリエ変換によって特定の周期成分のみを除去すれば,画質の低下を最小限に抑えることができます。

図12.2 周期ノイズ除去の例

 図12.2に周期ノイズを除去した例を示します。 元のサンプル画像にはほぼ水平方向にグリーン(グリーンには見えませんが,このプログラムを用いて緑色成分だけを表示してみると明確に分かります)の縞状ノイズが入っています。 それを今回作成したフーリエ変換によるノイズ除去プログラムを用いて右半分だけをノイズカットしたものです。 完全には除去できていませんが,随分と綺麗になったと思いませんか?

12.1 関連するAPI

・GetDlgItem関数
 GetDlgItem関数は,指定したダイアログボックス内のコントロールのハンドルを取得するのに用います。ここでは,チェックボックスのコントロールIDのハンドルを取得し,チェックボックスをON/OFFするのに用います。

    integer(4) function  GetDlgItem(hDlg, nIDDlgItem)
     integer hDlg        ! コントロールが入っているダイアログボックスのハンドル
     integer nIDDlgItem  ! 取得するControl ID
    end function GetDlgItem

   戻り値:成功時はコントロールのウィンドウハンドル,失敗時はNULL。

・CheckDlgButton関数
 CheckDlgButton関数は,ボタンコントロールのチェックマークをON/OFFするのに用います。

    logical(4) function CheckDlgButton(hDlg, nIDButton, uCheck )
     integer hDlg        ! ボタンが入っているダイアログボックスのハンドル
     integer nIDButton   ! 変更するチェックボックスの識別子
     integer uCheck      ! チェックの状態
    end function CheckDlgButton

  uCheckはチェック状態を指定し,=0でチェックOFF,≠0でチェックON。

  戻り値:成功時はTRUE,失敗時はFALSE。

・SetDlgItemText関数
 SetDlgItemText関数は,コントロールのタイトル又はテキストを設定します。

    logical(4) function SetDlgItemText(hDlg, nIDDlgItem, lpString) 
     integer       hDlg       ! ダイアログボックスのハンドル
     integer       nIDDlgItem ! コントロールの識別子
     character*(*) lpString   ! NULLで終わる文字列のポインタ
    end function SetDlgItemText

  戻り値:成功時はTRUE,失敗時はFALSE。

・IsDlgButtonChecked関数
 IsDlgButtonChecked関数は,チェックボックスコントロールのチェックマークの状態を判別します。

    integer(4) function IsDlgButtonChecked(hDlg, nIDButton)
     integer hDlg         ! ダイアログボックスのハンドル
     integer nIDButton    ! チェックボックスコントロールの識別子
    end function IsDlgButtonChecked

  戻り値:成功時は現在のチェックの状態。
  0 : チェックマークなし
    1 : チェックマークあり
    2 : 不定

12.2 リソーススクリプトファイルの定義

 リソーススクリプトファイルではプログラムで使用する次のリソースを定義します。

 (1) インクルードファイル
リソーススクリプトの中で用いる定数を定義したヘッダーファイルです。
 (2) メニュー
メニューバーに表示するメニューやプルダウンメニューを定義します。
 (3) アクセラレータ
メニューをマウスでクリックする代わりに特定のキーを押すことで同等の処理を行うようにするキー入力を定義します。
 (4) ダイアログ
ダイアログボックスの定義を行います。エディットボックス,チェックボックス,ボタンの設定を行います。
 (5) アイコン
ウィンドウのタイトルバーに表示するアイコンを定義します。アイコンの作り方は第7章を参照してください。
・リソースファイルの内容
/////////////////////////////////////////////////////////////////////////////
//
// Filter Resource description
//
// include file
//
#include "WINRES.H"

/////////////////////////////////////////////////////////////////////////////
//
// Menu
//

MYMENU MENU DISCARDABLE 
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Open...",                    101
        MENUITEM "&Save...",                    102
        MENUITEM "E&xit",                       109
    END
    POPUP "&Edit"
    BEGIN
        MENUITEM "&FFT\tCtrl+F",                201
        MENUITEM SEPARATOR
        MENUITEM "&Test\tCtrl+T",               203
        MENUITEM SEPARATOR
        MENUITEM "&Undo\tCtrl+Z",               205, GRAYED  // reserve
        MENUITEM "&Copy\tCtrl+C",               206, GRAYED  // reserve
        MENUITEM "&Paste\tCtrl+V",              207, GRAYED  // reserve
    END
END

/////////////////////////////////////////////////////////////////////////////
//
// Accelerator
//

FILTER  ACCELERATORS MOVEABLE PURE 
BEGIN
    "F",            201,              VIRTKEY, CONTROL, NOINVERT
    "T",            203,              VIRTKEY, CONTROL, NOINVERT
END

/////////////////////////////////////////////////////////////////////////////
//
// Dialog
//

MYDLG   DIALOG    DISCARDABLE  0, 0, 120, 90
STYLE DS_MODALFRAME | WS_POPUP | WS_CAPTION | WS_SYSMENU
FONT 10, "MS 明朝"
BEGIN
    EDITTEXT              801,10, 5,32,12,ES_AUTOHSCROLL
    EDITTEXT              802,10,20,32,12,ES_AUTOHSCROLL
    DEFPUSHBUTTON "Enter",909,10,40,30,16,NOT WS_TABSTOP
    PUSHBUTTON       "OK",901,10,60,30,20,NOT WS_TABSTOP
    PUSHBUTTON   "CANCEL",902,50,60,30,20,NOT WS_TABSTOP
    CONTROL  "Red",  903,"Button",BS_AUTOCHECKBOX|WS_TABSTOP,60, 4,37,10
    CONTROL  "Green",904,"Button",BS_AUTOCHECKBOX|WS_TABSTOP,60,16,37,10
    CONTROL  "Blue", 905,"Button",BS_AUTOCHECKBOX|WS_TABSTOP,60,28,37,10
    PUSHBUTTON  "再表示", 906,60,40,30,16,NOT WS_TABSTOP 
END


/////////////////////////////////////////////////////////////////////////////
//
// Icon
//

MYICON    ICON    DISCARDABLE     "MYICON.ico"

12.3 プログラム例

!*********************************************************************
!  Filtering Program by FFT.
!         V01L001  2002.05.26   Y.AKATSUKA
!*********************************************************************

!*********************************************************************
!  Module definition 
!*********************************************************************
module WINCOM
use dfwina
type (T_RECT) grc, grect, gcrect
type (T_POINTS) gpts, gpts0, gpts1
integer*4  ghinst, gwx, gwy, ghPos, gvPos, ghDlg, ghChdWnd
integer*4  ghDCmem,gM,gN,gRGB,gIH0,gIH1,gH,gIV0,gIV1,gV,gMM
integer*4  ghCsrA, ghCsrW
real*4  gFlt1, gFlt2
real*4, ALLOCATABLE :: A(:,:,:)
byte, ALLOCATABLE :: IRGB(:,:,:)
end module

!*********************************************************************
!  WinMain
!        2001.09.07  2001.10.04  Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WINCOM
!
interface
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu, hIcon, hAccel
character lpszClassName*10
type (T_WNDCLASSEXA) wc
type (T_MSG)       mesg
!
   lpszCmdLine = lpszCmdLine
   lpszClassName="FILTER"C
   if(hPrevInstance .eq. 0) then
      wc%cbSize       = SIZEOF(wc)
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = 0 !IOR(CS_VREDRAW, CS_HREDRAW)
      wc%hInstance    = hInstance
      wc%hIcon        = LoadImage(hInstance,"MYICON"C,IMAGE_ICON,0,0, &
                        LR_DEFAULTCOLOR)
      wc%hCursor      = LoadCursor(NULL,IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      wc%hIconSm      = 0
      i = RegisterClassEx(wc)     ! i : dummy
   end if
   hmenu  = LoadMenu(hInstance, LOC("MYMENU"C))
   hAccel = LoadAccelerators(hInstance, LOC("FILTER"C))
   ghinst = hInstance
   hWnd = CreateWindowEx(0, lpszClassName,  &
                  "FILTER"C,                &
                  IOR(WS_OVERLAPPEDWINDOW,WS_CLIPCHILDREN), &
                  CW_USEDEFAULT, 0,         &
                  CW_USEDEFAULT, 0,         &
                  NULL,                     &
                  hmenu,                    &
                  hInstance,                &
                  NULL)
   i = ShowWindow(hWnd, nCmdShow)
!
   do while (GetMessage(mesg, NULL, 0, 0))
     if (.NOT. TranslateAccelerator(hWnd, hAccel, mesg) .AND. &
         .NOT. IsDialogMessage(ghDlg, mesg)) then
       i = TranslateMessage(mesg)
       i = DispatchMessage(mesg)
     end if
   end do

   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!      Open----FFT (Matrix) --> ChildWind
!               :               DlgProc
!      Save<---Filter
!
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use WINCOM

interface
integer function DlgProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgProc@16' :: DlgProc
integer hWnd, mesg, wParam, lParam
end function
end interface

integer hWnd, mesg, wParam, lParam

type (T_PAINTSTRUCT) ps

integer hDC
logical b, bCap, cCap
character buf*80
!
   select case (mesg)
   case (WM_CREATE)
     b = SystemParametersInfo(SPI_GETWORKAREA,NULL,LOC(grc),NULL)
     ghCsrA = LoadCursor(NULL, IDC_ARROW)
     ghCsrW = LoadCursor(NULL, IDC_WAIT)
     bCap = .FALSE.
     cCap = .FALSE.
     gFlt = 1.0
   case (WM_CLOSE)
     call BMPCLS(hWnd)
     i = DestroyWindow(hWnd)
   case (WM_DESTROY)
     call PostQuitMessage(0)
   case (WM_SIZE)
     b = GetClientRect(hWnd, grect)
     call SetScrollRanges(hWnd)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)         ! ==> EndPaint
     call BMPDSP(hWnd,hDC)
     if (bCap) call CsrPnt(hWnd,hDC,IH,IV)
     if (cCap) call CsrSQR(hWnd,hDC)
     b = EndPaint(hWnd, ps)             ! <== BeginPaint
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case (101)  ! Open
       call BMPOPN(hWnd)
       call SetScrollRanges(hWnd)
       i = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
     case (102)  ! Save
       call BMPSAV(hWnd)
     case (109)  ! Exit
       i = SendMessage(hWnd, WM_CLOSE, 0, 0)
     case (201)  ! Subwindow
       i = SetCursor(ghCsrW)
       if (ghDlg == 0) then
         ghDlg = CreateDialogParam(ghinst,LOC("MYDLG"C),hWnd,LOC(DlgProc),0)
         i = ShowWindow(ghDlg, SW_SHOW)
       end if
       cCap = .FALSE.
       i = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
       call BMPWIN(hWnd, mesg, wParam, lParam)
       i = SetFocus(ghDlg)
       i = SetCursor(ghCsrA)
     case (203)  ! Test pattern
       i = SetCursor(ghCsrW)
       call BMPTST(hWnd)
       i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
       i = SetCursor(ghCsrA)
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case (WM_LBUTTONDOWN)
     IH = MIN(LOWORD(lParam),gwx-1)
     IV = MIN(HIWORD(lParam),gwy-1)
     gpts%x = IH + ghPos
     gpts%y = IV + gvPos
     gpts0 = gpts   ! gpts0%x,y = gpts%x,y
     cCap = .TRUE.
     bCap = .TRUE.
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_MOUSEMOVE)
     if (bCap) then
       IH = MIN(LOWORD(lParam),gwx-1)
       IV = MIN(HIWORD(lParam),gwy-1)
       gpts%x = IH + ghPos
       gpts%y = IV + gvPos
       i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
     end if
   case (WM_LBUTTONUP)
     gpts%x = MIN(LOWORD(lParam),gwx-1)  + ghPos
     gpts%y = MIN(HIWORD(lParam),gwy-1)  + gvPos
     bCap = .FALSE.
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case (WM_VSCROLL)
     call vScrollBar(hWnd, wParam)
   case (WM_HSCROLL)
     call hScrollBar(hWnd, wParam)
   case (WM_KEYDOWN)
     if(wParam == VK_LEFT) b=SendMessage(hwnd,WM_HSCROLL,SB_LINEUP,0)
     if(wParam == VK_RIGHT)b=SendMessage(hwnd,WM_HSCROLL,SB_LINEDOWN,0)
     if(wParam == VK_UP)   b=SendMessage(hwnd,WM_VSCROLL,SB_LINEUP,0)
     if(wParam == VK_DOWN) b=SendMessage(hwnd,WM_VSCROLL,SB_LINEDOWN,0)
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
     return
   end select
end

!*********************************************************************
!*  DlgProc Function
!*********************************************************************
integer function DlgProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DlgProc@16' :: DlgProc
use WINCOM
integer hWnd, mesg, wParam, lParam, hWndP
logical b
character Edit*10,buf*80
    select case (mesg)
    case (WM_INITDIALOG)
      gDisp = .FALSE.
      gRGB = 7
      i = SendMessage(GetDlgItem(hWnd,903),BM_SETCHECK,1,0)
      i = SendMessage(GetDlgItem(hWnd,904),BM_SETCHECK,1,0)
      i = SendMessage(GetDlgItem(hWnd,905),BM_SETCHECK,1,0)
      i = SetDlgItemText(hWnd,801,"0.0"C)
      i = SetDlgItemText(hWnd,802,"0.0"C)
      hWndP = GetParent(hwnd)
      DlgProc = 1
      return
    case (WM_COMMAND)
       select case (LOWORD(wParam))
       case (909)   ! INPUT EDIT FIELD
         i = SetCursor(ghCsrW)
         gFlt1 = 0.0
         i = GetDlgItemText(hWnd,801,Edit,5)
         if (i>0) READ(Edit(1:i),*)gFlt1
         gFlt2 = 0.0
         i = GetDlgItemText(hWnd,802,Edit,5)
         if (i>0) READ(Edit(1:i),*)gFlt2
         gRGB = IsDlgButtonChecked(hWnd,905)
         gRGB = IsDlgButtonChecked(hWnd,904)*2 + gRGB
         gRGB = IsDlgButtonChecked(hWnd,903)*4 + gRGB
         call BMPFLT(hWndP)
         i = InvalidateRect(ghChdWnd, NULL_RECT, .FALSE.)
         i = SetCursor(ghCsrA)
         DlgProc = 1
         return
       case (901)    ! OK
         call BMPOK(hWndP)
         i = DestroyWindow(ghDlg)
         ghDlg = 0
         b = PostMessage(ghChdWnd,WM_CLOSE,0,0)
         i = InvalidateRect(hWndP, NULL_RECT, .FALSE.)
         DlgProc = 1
         return
       case (902)    ! CANCEL
         i = SetCursor(ghCsrW)
         call CANCEL(hWndP)
         i = InvalidateRect(ghChdWnd, NULL_RECT, .FALSE.)
         i = SetCursor(ghCsrA)
         DlgProc = 1
         return
       case (906)    ! 再表示
         i = SetCursor(ghCsrW)
         gRGB = IsDlgButtonChecked(hWnd,905)
         gRGB = IsDlgButtonChecked(hWnd,904)*2 + gRGB
         gRGB = IsDlgButtonChecked(hWnd,903)*4 + gRGB
         CALL DISPA
         i = InvalidateRect(ghChdWnd, NULL_RECT, .FALSE.)
         i = SetCursor(ghCsrA)
         DlgProc = 1
         return
       case default
         DlgProc = 0
         return
       end select
    case (WM_CLOSE)
      i = DestroyWindow(ghDlg)
      ghDlg = 0
      if (ghChdWnd /= 0)i = DestroyWindow(ghChdWnd)
      ghChdWnd = 0
      DlgProc = 1
      return
    case default
      DlgProc = 0
      return
    end select
end

!*********************************************************************
!*  BMPOPN SUBROUTINE called by Open menu.
!*********************************************************************
subroutine BMPOPN(hWnd)
use WINCOM

integer*4 hWnd, mesg, wParam, lParam, hDC, hF

type (T_OPENFILENAME) ofn
type (T_BITMAPFILEHEADER) Bf

type (T_BITMAPINFO) Bi
pointer (pBi, Bi)

type (T_RGBTRIPLE) rgbdt, rgbdb
pointer (prgbdt, rgbdt), (prgb, rgbdb)

type (T_SECURITY_ATTRIBUTES), pointer :: NULL_S

character, ALLOCATABLE, SAVE :: Buffer(:)
logical*4  b
character  filename*100, filename2*100
character*80 :: filter = "BMP Files"C//"*.BMP"C
integer    isize/0/
character  buf*80
    if (isize /= 0) then
      DEALLOCATE (Buffer,A,IRGB)
      isize = 0
    end if
    filename="TEST.BMP"C
    ofn%lStructSize = SIZEOF(ofn)
    ofn%hwndOwner   = hWnd
    ofn%hInstance   = ghInst
    ofn%lpstrFilter = LOC(filter)
    ofn%lpstrCustomFilter = NULL
    ofn%nMaxCustFilter = 0
    ofn%nFilterIndex= 1             ! Specifies initial filter value
    ofn%lpstrFile   = LOC(fileName)
    ofn%nMaxFile    = SIZEOF(fileName)
    ofn%nMaxFileTitle = 0
    ofn%lpstrInitialDir = &  ! (NULL:Windows default directry)
      LOC("C:\\Program Files\\DevStudio\\Project\\Filter"C)
    ofn%lpstrTitle  = LOC(""C)
    ofn%Flags       = OFN_PATHMUSTEXIST
    ofn%lpstrDefExt = LOC("bmp"C)
    ofn%lpfnHook    = NULL
    ofn%lpTemplateName = NULL
    istat = GetOpenFileName(ofn)
    if (istat == 0) then
      i = MessageBox(hWnd, "No file name specified"C, "Open"C, MB_OK)
      return
    end if
!...Open File
    hF = CreateFile(fileName,GENERIC_READ,0,null_security_attributes, &
         OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,NULL)
    if (hF == INVALID_HANDLE_VALUE) then
      i = MessageBox(hWnd, "File Open Error"C, "Open"C, MB_OK)
      return
    end if
!...Read BITMAPFILEHEADER
    ISZBf = SIZEOF(Bf)
    b = ReadFile(hF,LOC(Bf),ISZBf,LOC(iR),null_overlapped)
!...Alloc Memory, Read BITMAPINFO and Image Data
    isize = Bf%bfSize - ISZBf
    ALLOCATE (Buffer(isize))
    b = ReadFile(hF,LOC(Buffer),isize,LOC(iR),null_overlapped)
    b = CloseHandle(hF)
    pBi = LOC(Buffer)
    gwx = Bi%bmiHeader%biWidth
    gwy = Bi%bmiHeader%biHeight
!...Resize the window
    MX = gwx + 9
    MY = gwy + 9
    if (MY > grc%bottom) MX = MX + 16 ! Scroll Bar size
    if (MX > grc%right)  MY = MY + 16
    b = MoveWindow(hWnd,0,0,MIN(MX,grc%right),MIN(MY,grc%bottom),.TRUE.)
!...if not 24 bits color, return
    if (Bi%bmiHeader%biBitCount /= 24) then
      i = MessageBox(hWnd, "Not 24 bits color data"C, "Open"C, MB_OK)
      DEALLOCATE (buffer)
      isize = 0
      return
    end if
    prgbdt = LOC(Buffer)+Bf%bfOffBits-ISZBf
!   Allocate Matrix A()
    ALLOCATE (A(gwy,gwx,3),IRGB(3,gwy,gwx))
    IH = ((gwx*3+3)/4)*4
    DO 310 KRGB=1,3
    DO 320 I=1,gwy
    prgb = (I-1)*IH + prgbdt + KRGB - 1
    DO 330 J=1,gwx
    L = rgbdb%rgbtBlue
    IRGB(KRGB,I,J) = L
    IF(L.LT.0)L = L + 256
    prgb = prgb + 3
330 CONTINUE
320 CONTINUE
310 CONTINUE
    return
!=====================================================================
!   ENTRY BMPDSP  called by WM_PAINT
!=====================================================================
entry BMPDSP(hWnd,hDC)
    if (isize == 0) return
    i = SetDIBitsToDevice(hDC, -ghPos,-gvPos, gwx,gwy, 0,0, 0,gwy, &
        LOC(Buffer)+Bf%bfOffBits-ISZBf, Bi, DIB_RGB_COLORS)
    return
!=====================================================================
!   ENTRY BMPTST  called by 203
!=====================================================================
entry BMPTST(hWnd)
    if (isize == 0) return
    DO 210 KRGB=1,3
    DO 220 J=1,gwy
    prgb = (J-1)*IH + prgbdt + KRGB - 1
    DO 230 I=1,gwx
    L = 78
    IF(MOD(J+I/32,16).LE.8) L = 178
    L = MAX(MIN(L,255),0)
    IF(L.GT.127)L = L - 256
    rgbdb%rgbtBlue = L
    prgb = prgb + 3  
230 CONTINUE
220 CONTINUE
210 CONTINUE
    return
!=====================================================================
!   ENTRY BMPSAV  called by 102
!=====================================================================
entry BMPSAV(hWnd)
    if (isize == 0) return
    filename2="*.BMP"C
    ofn%lStructSize = SIZEOF(ofn)
    ofn%hwndOwner   = hWnd
    ofn%hInstance   = ghInst
    ofn%lpstrFilter = LOC(filter)
    ofn%lpstrCustomFilter = NULL
    ofn%nMaxCustFilter = 0
    ofn%nFilterIndex = 1             ! Specifies initial filter value
    ofn%lpstrFile   = LOC(fileName2)
    ofn%nMaxFile    = SIZEOF(fileName2)
    ofn%nMaxFileTitle = 100
    ofn%lpstrInitialDir = &          ! (NULL:Windows default directry)
      LOC("C:\\Program Files\\Microsoft Visual Studio\\MyProjects\\Filter"C)
    ofn%lpstrTitle  = LOC(""C)
    ofn%Flags       = OFN_PATHMUSTEXIST
    ofn%lpstrDefExt = LOC("BMP"C)
    ofn%lpfnHook    = NULL
    ofn%lpTemplateName = NULL
    istat = GetSaveFileName(ofn)
    if (istat == 0) then
      i = MessageBox(hWnd, "No file name specified"C, "Open"C, MB_OK)
      return
    end if
!...Open File
    hF = CreateFile(FileName2, GENERIC_WRITE, 0, NULL_S, OPEN_ALWAYS, &
         FILE_ATTRIBUTE_NORMAL, NULL)
    if (hF == INVALID_HANDLE_VALUE) then
      i = MessageBox(hWnd, "File Open Error"C, "Save"C, MB_OK)
      return
    end if
!...Write BITMAPFILEHEADER,INFOHEADER,ImageData
    b = WriteFile(hF,LOC(Bf),SIZEOF(Bf),LOC(iR),null_overlapped)
    b = WriteFile(hF,LOC(Buffer),isize,LOC(iR),null_overlapped)
    b = CloseHandle(hF)
    return
!=====================================================================
!   ENTRY BMPWIN  called by 201
!=====================================================================
entry BMPWIN(hWnd, mesg, wParam, lParam)
    if (isize == 0) return
    DO 30 KRGB=1,3
    DO 10 I=1,gwy
    prgb = (I-1)*IH + prgbdt + KRGB - 1
    DO 10 J=1,gwx
    L = rgbdb%rgbtBlue
    IRGB(KRGB,I,J) = L
    IF (L.LT.0) L = L + 256
    A(I,J,KRGB)   = L
    prgb = prgb + 3
 10 CONTINUE
    gIH0 = MIN(gpts1%x,gpts0%x) + 1
    gIH1 = MAX(gpts1%x,gpts0%x) + 1
    gH = gIH1 - gIH0 + 1
    gIV0 = gwy - MAX(gpts1%y,gpts0%y)
    gIV1 = gwy - MIN(gpts1%y,gpts0%y)
    gV = gIV1 - gIV0 + 1
 30 CONTINUE
!=== Child Window =============================
    call ChildWind(hWnd, mesg, wParam, lParam)
    return
!=====================================================================
!   ENTRY BMPFLT  called by 202
!=====================================================================
entry BMPFLT(hWnd)
    IF(gFlt2 .EQ. 0.0) gFlt2 = gFlt1
    IF(MAX(gFlt1,gFlt2) .LE. 2.0) GO TO 121
    Mh  = gM / 2             ! 256/2=128
    IVA = gIV0-1             ! 0
    IVB = IVA+Mh             ! 128
    PS1 = FLOAT(gM)/MAX(gFlt1,gFlt2) ! 256/2=128
    PS2 = FLOAT(gM)/MIN(gFlt1,gFlt2)
    DO 110 KRGB = 1,3
    IF(IAND(gRGB,2**(KRGB-1)) == 0) GO TO 110
!=== Fourier Analysis =========================
    CALL FFT2DV(A(gIV0,gIH0,KRGB+3),gwy,gMM,gH,0,ILL)
    DO 120 J=gIH0,gIH1
    A(IVB+1,J,KRGB) = 0.0    ! 129
    DO 140 K=1,6
    KP1 = PS1*FLOAT(K)+1.0   ! 128+1.0=129
    KP2 = PS2*FLOAT(K)+1.0
    DO 150 KP=KP1,KP2
    IF(KP.GT.Mh) GO TO 120   ! 129 > 128
    A(KP+IVA,J,KRGB) = 0.0   ! 129+0=129
    A(KP+IVB,J,KRGB) = 0.0   ! 129+128=257
150 CONTINUE
140 CONTINUE
120 CONTINUE
!=== Inverse Fourier Transform ================
    CALL FFT2DV(A(gIV0,gIH0,KRGB),gwy,gMM,gH,1,ILL)
110 CONTINUE
    CALL DISPA
    return
!
121 DO 190 KRGB=1,3
    if(IAND(gRGB,2**(KRGB-1)) == 0) GO TO 190
    DO 170 J=gIH0,gIH1
    DO 170 I=gIV0+1,gIV1-1
    if(ABS(A(I-1,J,KRGB)-A(I,J,KRGB)) < 50.0) then
    A(I,J,KRGB)=(A(I-1,J,KRGB)+A(I,J,KRGB)*2.0+A(I+1,J,KRGB))*0.25
    end if
170 CONTINUE
190 CONTINUE
    CALL DISPA
    RETURN
!=====================================================================
!   ENTRY BMPOK  called by 901
!=====================================================================
entry BMPOK(hWnd)
    DO 470 KRGB=1,3
    DO 470 I=1,gwy
    prgb = (I-1)*IH + prgbdt + KRGB - 1
    DO 470 J=1,gwx
    L = MAX(MIN(IFIX(A(I,J,KRGB)),255),0)
    IF(L.GE.128)L = L - 256
    IRGB(KRGB,I,J) = L 
    rgbdb%rgbtBlue = L
    prgb = prgb + 3
470 CONTINUE
    return
!=====================================================================
!   ENTRY CANCEL  called by 902
!=====================================================================
entry CANCEL(hWnd)
    if (isize == 0) return
    DO 510 KRGB=1,3
    DO 510 J=gIH0,gIH1
    DO 510 I=gIV0,gIV1
    L = IRGB(KRGB,I,J)
    IF(L.LT.0)L = L + 256
    A(I,J,KRGB) = L
510 CONTINUE
    CALL DISPA
    return
!=====================================================================
!   ENTRY CLSBMP  called by WM_DESTROY
!=====================================================================
entry BMPCLS(hWnd)
    if (isize /= 0) DEALLOCATE (Buffer,A,IRGB)
    return
end

!*********************************************************************
!*  SetScroolRanges subroutine.
!*********************************************************************
subroutine SetScrollRanges(hWnd)
use WINCOM 
type (T_SCROLLINFO) sih, siv
integer*4 hWnd, wParam, dx, dy, RangeX, RangeY
logical b
    gvPos = 0
    siv%Size = SIZEOF(siv)    ! Size of Info structure
    siv%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    siv%Min = 0               ! Minimum scrolling position
    siv%Max = gwy             ! Maximum scrolling position
    siv%Page= grect%bottom - grect%top ! Page scroll size 
    siv%Pos = 0               ! Position of the scroll box
!   siv%TrackPos = 0
    RangeY  = gwy - siv%Page  ! Scrolling range
    i = SetScrollInfo (hWnd, SB_VERT, siv, .TRUE.)
!
    ghPos = 0
    sih%Size = SIZEOF(sih)    ! Size of Info structure
    sih%Mask = IOR(IOR(SIF_POS, SIF_RANGE), SIF_PAGE)
    sih%Min = 0               ! Minimum scrolling position
    sih%Max = gwx             ! Maximum scrolling position
    sih%Page = grect%right - grect%left ! Page scroll size
    sih%Pos = 0               ! Position of the scroll box
    RangeX  = gwx - sih%Page  ! Scrolling range
    i = SetScrollInfo (hWnd, SB_HORZ, sih, .TRUE.)
    return
!=====================================================================
!*  vScroolBar Entry subroutine.   HiWord(wParam):current position
!=====================================================================
entry vScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINEUP)
      dy = -5
    case (SB_LINEDOWN)
      dy = 5
    case (SB_PAGEUP)
      dy = -siv%Page
    case (SB_PAGEDOWN)
      dy = siv%Page
    case (SB_THUMBTRACK)
      dy = HiWord(wParam) - siv%Pos
    case (SB_THUMBPOSITION)
      dy = HiWord(wParam) - siv%Pos
    case default
      dy = 0
    end select
    dy = MAX(-siv%Pos, MIN(dy, RangeY - siv%Pos))
    if(dy /= 0) then
      siv%Pos = siv%Pos + dy
      gvPos = siv%Pos
      i = SetScrollInfo(hWnd, SB_VERT, siv, .TRUE.)
      i = ScrollWindowEx(hWnd, 0, -dy, grect, grect, 0, &
                         NULL_RECT, SW_INVALIDATE)
    end if
    return
!=====================================================================
!*  hScrollBar Subroutine Entry.   HiWord(wParam):current position
!=====================================================================
entry hScrollBar(hWnd, wParam)
    select case (LoWord(wParam))
    case (SB_LINELEFT)
      dx = -10
    case (SB_LINERIGHT)
      dx = 10
    case (SB_PAGELEFT)
      dx = -sih%Page
    case (SB_PAGERIGHT)
      dx = sih%Page
    case (SB_THUMBTRACK)
      dx = HiWord(wParam) - sih%Pos
    case (SB_THUMBPOSITION)
      dx = HiWord(wParam) - sih%Pos
    case default
      dx = 0
    end select
    dx = MAX(-sih%Pos, MIN(dx, RangeX - sih%Pos))
    if(dx /= 0) then
      sih%Pos = sih%Pos + dx
      ghPos = sih%Pos
      i = SetScrollInfo(hWnd, SB_HORZ, sih, .TRUE.)
      i = ScrollWindowEx(hWnd, -dx, 0, NULL_RECT, grect, 0, &
                        NULL_RECT, SW_INVALIDATE)
    end if
    return
end

!*********************************************************************
!*  ChildWind SUBROUTINE called from BMPFFT.
!*********************************************************************
subroutine ChildWind(hWnd, mesg, wParam, lParam)
use WINCOM

interface 
integer function ChildWndProc(hChdWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_ChildWndProc@16' :: ChildWndProc 
integer hChdWnd, mesg, wParam, lParam 
end function 
end interface
!
type (T_WNDCLASS) wc
!
integer*4 hWnd, mesg, wParam, lParam
integer*4 hInst, hChdWnd
   if(ghChdWnd /= 0) return 
   hInst = GetWindowLong(hWnd, GWL_HINSTANCE)
   wc%lpszClassName= LOC("FFTWIN"C)
   wc%lpfnWndProc  = LOC(ChildWndProc)
   wc%style        = IOR(CS_VREDRAW, CS_HREDRAW)
   wc%hInstance    = hInst
   wc%hIcon        = NULL
   wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
   wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
   wc%lpszMenuName = NULL
   wc%cbClsExtra   = 0
   wc%cbWndExtra   = 0
   i = RegisterClass(wc)
!
   ghChdWnd = CreateWindowEx(0,        &
               "FFTWIN"C,              & ! Window class name
               "FFTWIN"C,              & ! Window name
               WS_OVERLAPPEDWINDOW,    & ! Window style
               CW_USEDEFAULT,          & ! x position
               CW_USEDEFAULT,          & ! y position
               MIN(gH+8,grc%right),    & ! Width
               MIN(gV+27,grc%bottom),  & ! Height
               hWnd,                   & ! Parent handle
               0,                      & ! Menu handle
               hInst,                  & ! Instance
               NULL)                     ! Message pointer to lParam
   i = ShowWindow(ghChdWnd, SW_SHOWNORMAL)
   return
end

!*********************************************************************
!    ChildWndProc
!*********************************************************************
integer function ChildWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_ChildWndProc@16' :: ChildWndProc
use WINCOM

type (T_PAINTSTRUCT) ps
type (T_POINTS) pts

integer*4 hWnd, mesg, wParam, lParam
integer*4 hDC, hBmBuffer
logical   b
character buf*80
!
   select case (mesg)
   case (WM_CREATE)
     hDC = GetDC(hWnd)     ! Get the DC of the Window
     ghDCmem = CreateCompatibleDC(hDC)
     hBmBuffer = CreateCompatibleBitmap(hDC, gH, gV)
     write(buf,'(I4,"x",I4,A)')gH,gV,""C
     b = SetWindowText(hWnd,buf)
     i = SelectObject(ghDCmem, hBmBuffer)
     CALL DISPA
   case (WM_CLOSE)
     i = DeleteDC(ghDCmem)
     i = DeleteObject(hBmBuffer)
     i = DestroyWindow(hWnd)
     ghChdWnd = 0
     if (ghDlg /= 0)i = DestroyWindow(ghDlg)
     ghDlg = 0
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)         ! ==> EndPaint
     b = BitBlt(hDC,0,0, gH, gV, ghDCmem, 0, 0, SRCCOPY)
!    b = StretchBlt(hDC,0,0,gH*2,gV*2,ghDCmem,0,0,gH,gV,SRCCOPY)
     b = EndPaint(hWnd, ps)             ! <== BeginPaint
   case (WM_LBUTTONDOWN)
     pts%x = LOWORD(lParam)
     pts%y = HIWORD(lParam)
     CALL AFECT(pts%x, pts%y)
     i = InvalidateRect(hWnd, NULL_RECT, .FALSE.)
   case default
     ChildWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
     return
   end select
end

!*********************************************************************
!*  DISPA SUBROUTINE called by WM_CREATE.
!*********************************************************************
subroutine DISPA
use WINCOM
integer*4 ICOL(3)
logical*4 b
character buf*80
    DO 60 J = gIH0,gIH1
    J1 = J - gIH0
    DO 60 I = gIV0,gIV1
    I1 = gIV1-I
    DO 80 KRGB=1,3
    ICOL(KRGB)=0
    IF(IAND(gRGB,2**(KRGB-1)) == 0)GO TO 80
    ICOL(KRGB) = MAX(MIN(IFIX(A(I,J,KRGB)),255),0)
 80 CONTINUE
    b = SetPixelV(ghDCmem,J1,I1,RGB(ICOL(3),ICOL(2),ICOL(1)))
 60 CONTINUE
    return
!=====================================================================
!*  AFECT subroutine ENTRY display values
!=====================================================================
entry AFECT(IH, IV)
    write(buf,'(2I4,1X,A)')IH,IV,""C
    b = TextOut(ghDCmem,50, gIV1-gIV0-20, buf, 9)
    return
end

!*********************************************************************
!*  CsrPnt SUBROUTINE called by Paint.
!*********************************************************************
subroutine CsrPnt(hWnd,hDC,IH0,IV0)
use WINCOM
integer hWnd, hDC
byte    Red,Green,Blue
character buf*80
logical b
    MCOL  = GetPixel(hDC,IH0,IV0)
    iRed  = MOD(GetRedValue(MCOL)+256,256)
    iGreen= MOD(GetGreenValue(MCOL)+256,256)
    iBlue = MOD(GetBlueValue(MCOL)+256,256)
    write(buf,'(5I4,1X)')gpts%x,gpts%y,iRed,iGreen,iBlue
    b = TextOut(hDC,30, grect%bottom-40, buf,21)
    return
!==============================================================
!   CsrSQR
!==============================================================
entry CsrSQR(hWnd,hDC)
    KS = gpts%y - gpts0%y
    gM = 2048
    do gMM = 11,0,-1
      if(IABS(KS)+1.GE.gM)go to 1   ! 2002.05.23
      gM = gM / 2
    end do
  1 gpts%y  = gpts0%y + ISIGN(gM-1,KS)
    gpts1 = gpts  ! gpts1%x,y = gpts%x,y
    ix0 = MIN(MAX(gpts0%x-ghPos,0),gwx-1)
    ix1 = MIN(MAX(gpts%x -ghPos,0),gwx-1)
    iy0 = MIN(MAX(gpts0%y-gvPos,0),gwy-1)
    iy1 = MIN(MAX(gpts%y -gvPos,0),gwy-1)
    do IV = iy0,iy1,ISIGN(1,iy1-iy0)
      MCOL = GetPixel(hDC,ix0,IV)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b    = SetPixelV(hDC,ix0,IV,RGB(Red,Green,Blue))
      MCOL = GetPixel(hDC,ix1,IV)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b    = SetPixelV(hDC,ix1,IV,RGB(Red,Green,Blue))
    end do
    do IH = ix0,ix1,ISIGN(1,ix1-ix0)
      MCOL = GetPixel(hDC,IH,iy0)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b    = SetPixelV(hDC,IH,iy0,RGB(Red,Green,Blue))
      MCOL = GetPixel(hDC,IH,iy1)
      Red  = GetRedValue(MCOL)  + Z"80"
      Green= GetGreenValue(MCOL)+ Z"80"
      Blue = GetBlueValue(MCOL) + Z"80"
      b    = SetPixelV(hDC,IH,iy1,RGB(Red,Green,Blue))
    end do
    return
end

!**********************************************************
!*    FFT2DV  VERTICAL DIRECTION
!**********************************************************
      SUBROUTINE FFT2DV(A,KA,M,N,INV,ILL)
      DIMENSION A(KA,1)
      IF(M.LE.1) GO TO 99
      IF(INV.EQ.1)GO TO 2
      DO 10 J=1,N
      CALL FFTR (A(1,J),M,ILL)
   10 CONTINUE
      GO TO 9
    2 DO 20 J=1,N
      CALL FFTRI(A(1,J),M,ILL)
   20 CONTINUE
      GO TO 9
   99 ILL=30000
    9 RETURN
      END
!**********************************************************
!*    FFTR                REVISED ON 1991-10-05
!*    A  :in  f(x(1))...f(x(2**M))
!*        out A(k+1)=Ck  A(N/2+k+1)=Sk
!*    M  :in  2**M
!*    ILL:condition code =0 normal end
!**********************************************************
      SUBROUTINE FFTR(A,M,ILL)
      DIMENSION A(1)
      REAL*8 DC(32),DS(32),SS
      DATA DC( 1)/0.707106781186547531D+00/
      DATA DC( 2)/0.923879532511286752D+00/
      DATA DC( 3)/0.980785280403230444D+00/
      DATA DC( 4)/0.995184726672196887D+00/
      DATA DC( 5)/0.998795456205172391D+00/
      DATA DC( 6)/0.999698818696204222D+00/
      DATA DC( 7)/0.999924701839144545D+00/
      DATA DC( 8)/0.999981175282601137D+00/
      DATA DC( 9)/0.999995293809576177D+00/
      DATA DC(10)/0.999998823451701907D+00/
      DATA DC(11)/0.999999705862882213D+00/
      DATA DC(12)/0.999999926465717850D+00/
      DATA DC(13)/0.999999981616429293D+00/
      DATA DC(14)/0.999999995404107320D+00/
      DATA DC(15)/0.999999998851026833D+00/
      DATA DC(16)/0.999999999712756701D+00/
      DATA DC(17)/0.999999999928189179D+00/
      DATA DC(18)/0.999999999982047291D+00/
      DATA DC(19)/0.999999999995511826D+00/
      DATA DC(20)/0.999999999998877953D+00/
      DATA DC(21)/0.999999999999719488D+00/
      DATA DC(22)/0.999999999999929876D+00/
      DATA DC(23)/0.999999999999982472D+00/
      DATA DC(24)/0.999999999999995615D+00/
      DATA DC(25)/0.999999999999998904D+00/
      DATA DC(26)/0.999999999999999722D+00/
      DATA DC(27)/0.999999999999999931D+00/
      DATA DC(28)/0.999999999999999986D+00/
      DATA DC(29)/0.100000000000000000D+01/
      DATA DC(30)/0.100000000000000000D+01/
      DATA DC(31)/0.100000000000000000D+01/
      DATA DC(32)/0.100000000000000000D+01/
      DATA DS( 1)/0.707106781186547531D+00/
      DATA DS( 2)/0.382683432365089768D+00/
      DATA DS( 3)/0.195090322016128262D+00/
      DATA DS( 4)/0.980171403295606036D-01/
      DATA DS( 5)/0.490676743274180141D-01/
      DATA DS( 6)/0.245412285229122881D-01/
      DATA DS( 7)/0.122715382857199263D-01/
      DATA DS( 8)/0.613588464915447527D-02/
      DATA DS( 9)/0.306795676296597625D-02/
      DATA DS(10)/0.153398018628476561D-02/
      DATA DS(11)/0.766990318742704540D-03/
      DATA DS(12)/0.383495187571395563D-03/
      DATA DS(13)/0.191747597310703308D-03/
      DATA DS(14)/0.958737990959773447D-04/
      DATA DS(15)/0.479368996030668847D-04/
      DATA DS(16)/0.239684498084182193D-04/
      DATA DS(17)/0.119842249050697064D-04/
      DATA DS(18)/0.599211245264242774D-05/
      DATA DS(19)/0.299605622633466084D-05/
      DATA DS(20)/0.149802811316901114D-05/
      DATA DS(21)/0.749014056584715715D-06/
      DATA DS(22)/0.374507028292384129D-06/
      DATA DS(23)/0.187253514146195347D-06/
      DATA DS(24)/0.936267570730980836D-07/
      DATA DS(25)/0.468133785365490931D-07/
      DATA DS(26)/0.234066892682745532D-07/
      DATA DS(27)/0.117033446341372770D-07/
      DATA DS(28)/0.585167231706863850D-08/
      DATA DS(29)/0.292583615853431935D-08/
      DATA DS(30)/0.146291807926715968D-08/
      DATA DS(31)/0.731459039633579864D-09/
      DATA DS(32)/0.365729519816789906D-09/
      N2=1
      IF(M-1) 99,9,1
    1 CALL BITREV(A,M,ILL)
      N=2**M
      F=2./FLOAT(N)
      DO 20 L=1,N,2
      P=A(L+1)
      A(L+1)=(A(L)-P)*F
      A(L)=(A(L)+P)*F
   20 CONTINUE
      N1=1
      N2=2
      N3=4
      N4=8
      IF(M.LT.3) GO TO 9
      DO 70 I=1,M-2
      DO 30 L=1,N,N3
      L1=L+N2
      P=A(L)
      A(L)=P+A(L1)
      A(L1)=P-A(L1)
   30 CONTINUE
      C=DC(I)
      S=DS(I)
      SS=DS(I)+DS(I)
      CO=1.0
      SO=0.0
      DO 50 K=1,N1-1
      N3K=N3-K
      N2K=N2-K
      DO 40 J=1,N,N4
      L0=J+K
      L2=L0+N3
      L1=J+N3K
      L3=L1+N3
      P=C*A(L2)-S*A(L3)
      Q=S*A(L2)+C*A(L3)
      A(L2)=Q-A(L1)
      A(L3)=Q+A(L1)
      A(L1)=A(L0)-P
      A(L0)=A(L0)+P
      L1=L0+N2
      L3=L1+N3
      L0=J+N2K
      L2=L0+N3
      P=A(L2)*S-A(L3)*C
      Q=A(L2)*C+A(L3)*S
      A(L2)=Q-A(L1)
      A(L3)=Q+A(L1)
      A(L1)=A(L0)-P
      A(L0)=A(L0)+P
   40 CONTINUE
      CN=CO-SS*S
      SN=SS*C+SO
      CO=C
      C=CN
      SO=S
      S=SN
   50 CONTINUE
      DO 60 J=1,N,N4
      L0=J+N1
      L2=L0+N3
      L1=L2-N2
      L3=L1+N3
      P=A(L2)*S-A(L3)*C
      Q=A(L2)*C+A(L3)*S
      A(L2)=Q-A(L1)
      A(L3)=Q+A(L1)
      A(L1)=A(L0)-P
      A(L0)=A(L0)+P
   60 CONTINUE
      N1=N2
      N2=N3
      N3=N4
      N4=N4+N4
   70 CONTINUE
      L0=N2+2
      L1=N
      DO 80 J=2,N1
      P=A(L0)
      A(L0)=A(L1)
      A(L1)=P
      L0=L0+1
      L1=L1-1
   80 CONTINUE
    9 A(1)=(A(1)+A(N2+1))*0.5
      A(N2+1)=A(1)-A(N2+1)
   91 ILL=0
      RETURN
   99 IF(M.EQ.0) GO TO 91
      ILL=30000
      RETURN
!==========================================================
!*    FFTRI               REVISED ON 1991-10-05
!*    A  :in  A(K+1)=cK  A(N/2+K+1)=sK
!*        out f(x(1))...f(x(2**M))
!*    M  :in  2**M
!*    ILL:condition code =0 normal end
!==========================================================
      ENTRY FFTRI(A,M,ILL)
      IF(M.LE.0) GO TO 999
      N=2**M
      N4=N
      N3=N/2
      N2=N3/2
      N1=N2/2
      P=A(1)
      A(1)=P+A(N3+1)
      A(N3+1)=P-A(N3+1)
      IF(M-2) 191,31,11
   11 L0=N3+2
      L1=N
      DO 120 J=2,N2
      P=A(L0)
      A(L0)=A(L1)
      A(L1)=P
      L0=L0+1
  120 L1=L1-1
   31 DO 180 I=M-2,0,-1
      DO 140 L=1,N,N3
      L1=L+N2
      P=A(L)
      A(L)=P+A(L1)
      A(L1)=P-A(L1)
  140 CONTINUE
      IF(N1.EQ.0) GO TO 191
      C=DC(I)
      S=DS(I)
      SS=DS(I)+DS(I)
      CO=1.0
      SO=0.0
      DO 160 K=1,N1-1
      N3K=N3-K
      N2K=N2-K
      DO 150 J=1,N,N4
      L0=J+K
      L2=L0+N3
      L1=J+N3K
      L3=L1+N3
      P=A(L0)-A(L1)
      Q=A(L2)+A(L3)
      A(L0)=A(L0)+A(L1)
      A(L1)=A(L3)-A(L2)
      A(L2)=C*P+S*Q
      A(L3)=C*Q-S*P
      L1=L0+N2
      L3=L1+N3
      L0=J+N2K
      L2=L0+N3
      P=A(L0)-A(L1)
      Q=A(L2)+A(L3)
      A(L0)=A(L0)+A(L1)
      A(L1)=A(L3)-A(L2)
      A(L2)=S*P+C*Q
      A(L3)=S*Q-C*P
  150 CONTINUE
      CN=CO-SS*S
      SN=SS*C+SO
      CO=C
      C=CN
      SO=S
      S=SN
  160 CONTINUE
      DO 170 J=1,N,N4
      L0=J+N1
      L2=L0+N3
      L1=L2-N2
      L3=L1+N3
      P=A(L0)-A(L1)
      Q=A(L2)+A(L3)
      A(L0)=A(L0)+A(L1)
      A(L1)=A(L3)-A(L2)
      A(L2)=P*S+Q*C
      A(L3)=Q*S-P*C
  170 CONTINUE
      N4=N3
      N3=N2
      N2=N1
      N1=N1/2
  180 CONTINUE
  191 CALL BITREV(A,M,ILL)
      RETURN
  999 ILL=30000
      RETURN
      END
!**********************************************************
!*    BITREV              REVISED ON 1984-11-30
!**********************************************************
      SUBROUTINE BITREV(A,L,ICON)
      DIMENSION A(1),ITEST(20),INC(20)
      IF(L.LE.0.OR.L.GT.23) GO TO 8000
      NN=0
      NR=0
      I=L-1
      M=2**I
      K=2
      IF(I-2) 60,30,10
   10 I=I-1
      ITEST(I-1)=M-K
      K=K+K
      INC(I-1)=K-ITEST(I-1)
      IF(I-3) 30,10,10
   20 NR=INC(I)+NR
   30 MR=M+NR
      IF(NR-NN) 50,50,40
   40 W=A(NN+1)
      A(NN+1)=A(NR+1)
      A(NR+1)=W
      MN=M+NN
      W=A(MN+2)
      A(MN+2)=A(MR+2)
      A(MR+2)=W
   50 NN=NN+2
      W=A(NN)
      A(NN)=A(MR+1)
      A(MR+1)=W
      NR=K+NR
   60 MR=M+NR
      IF(NR-NN) 80,80,70
   70 W=A(NN+1)
      A(NN+1)=A(NR+1)
      A(NR+1)=W
      MN=M+NN
      W=A(MN+2)
      A(MN+2)=A(MR+2)
      A(MR+2)=W
   80 NN=NN+2
      W=A(NN)
      A(NN)=A(MR+1)
      A(MR+1)=W
      I=1
      IF(NN-M) 100,110,110
   90 I=I+1
  100 IF(NR-ITEST(I)) 20,90,90
  110 ICON=0
      RETURN
 8000 ICON=30000
      RETURN
      END

プログラムの解説

1) プログラムの概要

 このプログラムは,画像データに含まれる周期ノイズを除去するものです。 周期ノイズの方向は水平から45°以内とします。それ以上の場合は適当なツールを用いて90°回転させてから実行します。 フーリエ変換を用いて特定の周期成分を除去した後,フーリエ逆変換を用いて画像を再生します。 ダイアログは除去する波長の範囲や色成分を指定するのに用います。 フーリエ変換は数学ライブラリNUMPACから実高速フーリエ変換FFT(Fast Fourier Transform)と逆変換のルーチンを引用しています。
 プログラムを起動すると,FILTERというタイトルのメインウィンドウが開きます。 FileメニューのOpenを選択し,ノイズ除去したいBMP形式の画像を選択すると,メインウィンドウに画像が表示されます。
 ノイズ除去したい矩形領域をマウスポインタを用いて指定します。 矩形領域の左上にマウスを移動し,左クリックを押しながら右下の位置へ移動します。このとき第9章で紹介した矩形カーソルが表示されます。 スクロールが必要なときは矢印キーを併用します。 ただし,FFTを用いる関係でY方向のビット幅は2のべき乗に調節されます。
 領域選択をした後,EditメニューのFFTを選択すると,選択した範囲を表示するサブウィンドウと図12.1のような入力ダイアログが表示されます。 RGBのチェックボックスのチェックをONにし,再表示ボタンを押すと,図12.3のようにチェックされた成分のみがサブウィンドウに表示されるのでノイズを含むRGB成分を特定します。

図12.3 サブウィンドウの表示

 ノイズを含むRGB成分が特定できたらノイズの周期を特定します。 ダイアログのエディットボックスにノイズ消去する波長を入力します。 サブウィンドウ内のノイズ部分をマウスで左クリックすると座標位置が表示されるので,それを目安にY方向の波長をドットサイズを基準に小数点以下第1位まで入力します。 2つあるエディットボックスには範囲を指定します。 当初は少し広めに範囲を設定し,Enterキーを押すかEnterボックスをクリックすると,指定された範囲の波長成分を除去した画像がサブウィンドウに表示されます。 やり直しをする場合はCancelボタンをクリックします。 できるだけ狭い範囲でノイズが軽減されたならば,OKボタンをクリックすると原画像に反映されます。 効果が期待できる範囲は2.0〜10.0くらいですが,周期ノイズは1種類だけとは限りません。 上のエディットボックスに2.0以下の値を指定し,下のエディットボックスに0.0を指定した場合は,フーリエ変換を行わず平滑化によってノイズを除去します。
 ノイズ除去できるY方向範囲は2のべき乗に限られるため,必要に応じて再度範囲を設定しこれらの操作を繰り返します。 ただし,一度ノイズ消去した領域にオーバーラップして再度領域を設定したり,もともとノイズのない領域を設定して周期成分を除去すると,返ってモアレ状のノイズが発生する場合があります。
 ノイズ消去の終わった画像は,FileメニューのSaveを選択すると,保存するファイル名の入力ダイアログが表示されるので,適当な名前を付けて画像を保存します。


JPG形式の画像ファイル

画像ファイルの形式には,本稿で用いているBMP形式以外にJPG形式やGIF形式が広く用いられています。 BMP形式の画像ファイルは,Windows標準の形式になっています。 1画素を24ビットで表現するフルカラー画像は,圧縮を行わないので画質の劣化はありません。
 JPG形式の画像ファイルは,写真などの画像を高効率で圧縮することができます。 圧縮は8×8ドットの矩形領域単位に人目に区別しにくい程度の近似処理を施しています。 従って,サンプルのような周期ノイズも8×8ドットの範囲に分散されてしまいます。 このことはノイズの周期が一定でなくなることを意味し,周期ノイズ除去を困難にしている原因でもあります。
 GIF形式の画像ファイルは,256色までのカラー画像を圧縮した形式で保存します。 JPGと異なり復元したときの画質の劣化がないので,図表のように輪郭や色の明確な画像を保存するのに適しています。


2) プログラムの説明

 このプログラムは前章までのプログラムの応用ですので,基本的なウィンドウ操作については省略します。

 モジュール定義WINCOMでは,グローバル変数の定義を行います。グローバル変数は先頭がgになるように命名しています。 画像データを扱う変数AとIRGBだけは,画像データの大きさによって確保する領域の大きさが異なりますので,ALLOCATABLE属性にしています。変数Aは画像データをフーリエ変換するので,実数型にしています。 それぞれ色の3原色を扱うので3次元の配列になっています。

 MainWndProc関数の中では,bCapとcCapという2つの論理変数を用いていますが,bCapはマウスでポイントした点の座標表示,cCapはカーソルによる領域表示を行うか否かの指標に用いています。 カーソル表示については第9章を参照してください。

 WM_COMMANDの(201)は,表示画像からマウスで矩形領域を選択した後,メニューのFFTを選択したときに実行します。 CreateDialogParam関数を実行し,本章の主題であるコモンダイアログを表示してノイズ周期の値を入力したり,RGBを選択するチェックボックスを表示します。
 入力された値を基にBMPWINサブルーチン(エントリー)を実行し,画像データをフーリエ変換を行うために実数領域にセットします。 指定された画像データの座標をグローバル変数にセットし,サブウィンドウに指定領域の画像を表示します。

 (203)はメニューのTestを選択したときに実行します。 BMPTSTサブルーチン(エントリー)を実行し,縞状のテストパターン画像を作成します。 テストパターンは本プログラム作成に当たりノイズ消去が有効に動作することを確認するためのもので,特に必須な処理ではありません。

 WM_LBUTTONDOWNからWM_LBUTTONUPは,マウス入力した座標値を画像の位置座標に換算してグローバル変数に設定します。 そのため画面のスクロールした分も考慮する必要があります。 これは画面で選択した矩形領域と画像データの位置を対応させるためです。

 WM_KEYDOWNでは,キーボードの矢印キーを押したときに,対応するスクロールバーを操作したのと同等の処理を行うように,SendMessage関数を用いてスクロールメッセージを発行しています。 PostMessage関数を用いるとメッセージがポストキューを経由するので若干応答が遅くなります。

 DlgProc関数は,メニューのFFTを選択したときにMainWndProc関数からCreateDialogParam関数を実行して作成されたダイアログを処理するプロシジャです。
 WM_INITDIALOGは,ダイアログの初期設定を行います。 SendMessage関数を用いて,表示するRGB成分に対応して3つあるチェックボックスをONに設定します。 SetDlgItemText関数を用いて,周期成分の範囲を入力するために2つあるエディットボックスの初期値に0.0を設定します。

 WM_COMMANDの(909)は,Enterキー又はEnterボックスが押されたときに実行します。 処理に少し時間が掛かりますので,SetCursor関数を用いてカーソルを時計マークにします。 GetDlgItemText関数とREAD文を用いてエディットボックスに入力された値を実数データとしてgFlt1とgFlt2にそれぞれ読み込みます。 この値が除去したい周期ノイズの周波数の範囲になります。 IsDlgButtonChecked関数を用いてチェックボックスのチェックの有無を調べ処理すべきRGB成分の情報をgRGB変数に格納します。 BMPFLTサブルーチン(エントリー)を実行し,フィルタリングの処理を行います。 InvalidateRect関数を実行し画面の再表示を行った後,カーソルを通常の矢印に戻します。

 (901)はOKボタンが押されたときに実行します。 BMPOKサブルーチン(エントリー)を実行し,ノイズ除去した画像をオリジナル画像に反映させます。 ダイアログを破棄し,サブウィンドウを閉じます。

 (902)はCancelボタンが押されたときに実行します。 CANCELサブルーチン(エントリー)を実行し,サブウィンドウに表示された画像をオリジナル画像に復元します。 ただし,OKボタンが押された場合にはその時点の画像になります。

(906)は再表示ボタンが押されたときに実行します。 IsDlgButtonChecked関数を用いて3つあるチェックボックスのチェック状態を取得し,対応するRGBの成分を合成した画像をDISPAサブルーチンを実行しサブウィンドウに再表示します。

 BMPOPNサブルーチンは,画像ファイルを読み込むサブルーチンです。 メニューのOpenが選択されたときに,MainWndProc関数から呼び出されて実行します。 領域AとIRGBは,読み込んだ画像データの大きさに応じてALLOCATE文を用いて動的に確保します。

 BMPDSPサブルーチン(エントリー)は,画面表示が必要なときにMainWndProc関数から呼び出されて実行します。 SetDIBitsToDevice関数を用いてオリジナル画像データをディスプレイDCに転送します。

 BMPTSTサブルーチン(エントリー)は,メニューのTestが選択されたときに,MainWndProc関数から呼び出されて実行します。 入力されたオリジナル画像と同じ大きさのテストパターンを作成します。 これはプログラムのデバッグを兼ねたテスト用です。

 BMPSAVサブルーチン(エントリー)は,メニューのSaveが選択されたときに,MainWndProc関数から呼び出されて実行します。 ノイズ除去処理された画像データをファイルに出力します。

 BMPWINサブルーチン(エントリー)は,メニューのFFTが選択されたときに,MainWndProc関数から呼び出されて実行します。 指定された領域の画像データを実数型配列Aにセットします。 ChildWindサブルーチンを実行し,サブウィンドウを開きデータ入力用ダイアログと共に指定された領域の画像を表示します。

 BMPFLTサブルーチン(エントリー)は,メニューのFilterが選択されたときに,MainWndProc関数から呼び出されて実行します。 画像データをフーリエ変換し,周期成分を除去するこのプログラムの心臓部分の処理を行います。
 FFT2DVサブルーチンは,1次元の実フーリエ変換サブルーチンFFTRを用いて2次元的に実行するサブルーチンです。 画像データの縦方向のデータが配列Aの第1要素に入るようにしているのは,実はこのフーリエ変換のサブルーチンに先頭の要素をそのまま与えることができるようにするためです。(Fortranでは,配列の第1要素は連続したメモリーに割り当てられます。)
 フーリエ変換された周期成分は,配列の第1要素から直流成分,Cosin成分とその高調波,そしてSin成分とその高調波の順に格納されます。
 エディットボックスに入力された波長の値をもとに,配列内のCosin成分の位置とSin成分の位置を計算し,同時に各高調波の成分位置を計算し,該当する周期成分の値を0にしています。 これを指定されたRGBの成分に対して実行します。 FFT2DVサブルーチンを実行しフーリエ逆変換を行い,ノイズ成分が除去された周期成分から画像データを再生します。 DISPAサブルーチンを用いて再生した画像をサブウィンドウに表示します。
 なお,入力された波長の値が2.0以下のときは,フーリエ変換よりもノイズ除去に効果的な平滑化処理を行います。

 FFTについては,福井大学で公開しているNUMPACのページを参照してください。





目次 次の項目

13.ヘルプの作成


13.1 ヘルプ(HELP)の作成

 プログラムがひととおりできあがったら,ヘルプを作成しましょう。 ヘルプは使用者にプログラムの使用法を伝えるばかりでなく,プログラムの作成者にとっては仕様書の役割も果たすものです。 ヘルプはWindows95ではWinHelpと呼ばれる形式のものでしたが,Windows98以降はHTML HelpというWebとのインターフェースをとったものがMicrosoftの推奨となりました。 図13.1はHTML Help WorkshopをインストールしたときにC:\Windows\HELPにインストールされるヘルプファイルのAPI.CHMを表示したものです。 左側の目次やキーワードが表示されている部分をナビゲーションペイン,右側の内容が表示されている部分をトピックペインといいます。

 今回作成するヘルプはウィンドウのHelpメニューを選択したときに,サブメニューとして,Contents,Index,Aboutの3種類を作成します。 ContentsとIndexは実際には同じものですが,ヘルプを表示したときのナビゲーションペインのデフォルトが目次になるかキーワードの入力状態になるかの違いです。Aboutはプログラムのバージョン等を表示するダイアログを表示します。

 説明の都合でHelp Contentsの作成方法は後で解説し,HELPを表示するプログラムの解説を先に行います。 実際,プログラムの作成に当たっては既存の適当なヘルプファイルを表示するようにし,プログラムが完成してから,あるいはプログラムの作成と平行してそのプログラム用のHelp Contentsを作成します。

図13.1 HTML HELPの例

13.2 HELP作成の準備

 HELPを作成するには,HTML Help Workshopをインストールします。 HTML Help Workshopは,Microsoftから無料でダウンロードできます。 ダウンロードしたhtmlhelp.exeを実行するとインストールが行われます。 同時にプログラムから実行するために用いるAPIもHTMLHELP.LIBという名前でインストールされます。 ついでにhtmlhelpj.exeもダウンロードしてインストールすると,HTML Help Workshopの日本語版オンライン解説ヘルプが利用できるようになります。 標準でインストールするとC:\Windows\HELPディレクトリのなかにHTMLHELP.CHMというコンパイル済みのヘルプファイルが作成されるので,エクスプローラからダブルクリックすると見ることができます。

13.3 関連するAPI関数

 HTML Helpに関係するAPIは,以下のHtmlHelpA関数とHtmlHelpW関数の2種類です。HtmlHelpA関数はANSIコード用,HtmlHelpW関数はUnicode用です。 Fortranでは明確に区別して用いますが,ここでは,HtmlHelpA関数のみを用います。

・HtmlHelpA関数
 ・HtmlHelpA関数は,HTML Helpを実行します。 パラメータに指定するコマンドによって複数の機能を選択します。 このAPI関数はHTML Help WorkShopをインストールすると,HTMLHELP.LIBの中に含まれています。

    integer(4) HtmlHelpA(hWnd, pszFile, uCommand, dwData)
     integer hWnd       ! Window Handle
     integer pszFile    ! Pointer to HTML file
     integer uCommand   ! HTML help command
     integer dwData     ! Data of uCommand

    hWnd
      ヘルプを表示するオーナーWindowのハンドル。
    pszFile
      表示するHTMLヘルプファイル又はコンパイル済みヘルプファイルの名前のアドレス。
    uCommand
      関数に指定するコマンドで,主なものは13.4で解説します。
    dwData
      uCommandに基づくデータを指定します。
    
    戻り値:成功したときはHelp Windowのハンドル,失敗したときは0が返ります。

13.4 HtmlHelpのコマンド

・HH_INITIALIZE (#0000001C)
他のコマンドを実行する前に最初に実行し,Helpシステムを初期化します。
     HtmlHelpA (NULL, NULL,HH_INITIALIZE, LOC(dwCookie))
         HH_INITIALIZE    ! Initialize command
         dwCookie         ! Cookie returned by Hhctrl.ocx.
・HH_UNINITIALIZE (#0000001D)
Helpを終了するときに実行し,Helpシステムを正常にシャットダウンします。
     HtmlHelpA (NULL, NULL, HH_UNINITIALIZE, LOC(dwCookie))
         HH_UNINITIALIZE  ! shutdown command
         dwCookie         ! Cookie same as HH_INITIALIZE.
・HH_DISPLAY_TOC (#00000001)
指定されたWindowにHelpトピックを開き,目次タブを選択します。
     HtmlHelpA (hWndL, LOC(szFile), HH_DISPLAY_TOC, NULL)
         hWnd             ! Window handle
         szFile           ! Compiled help file, or topic within a compiled help file
         HH_DISPLAY_TOC   ! Opens a help topic
・HH_DISPLAY_TOPIC (#00000000)
指定されたWindowにHelpトピックを開きます。
前回開いたときと同じ目次タブ又はキーワードタブが選択されます。
     HtmlHelpA (hWnd, LOC(szFile), HH_DISPLAY_TOPIC, NULL)
         hWnd             ! Window handle
         szFile           ! Compiled help file, or topic within a compiled help file
         HH_DISPLAY_TOPIC ! Opens a help topic
・HH_DISPLAY_INDEX (#00000002)
指定されたWindowにHelpトピックを開き,指定されたKeywordを検索します。
     HtmlHelpA (hWndL, LOC(szFile), HH_DISPLAY_INDEX, LOC(Keyword))
         hWnd             ! Window handle
         szFile           ! Compiled help file, or topic within a compiled help file
         HH_DISPLAY_INDEX ! Opens a help topic
         Keyword          ! Specified Keyword
・HH_CLOSE_ALL (#00000012)
開いているすべてのHelp Windowを閉じます。
     HtmlHelpA (NULL, NULL, HH_CLOSE_ALL, 0)
         HH_CLOSE_ALL     ! Close all windows opened

13.5 リソーススクリプトファイルの定義

 リソーススクリプトファイルはプログラムで使用する次のリソースを定義します。 前章のリソーススクリプトファイルからヘルプを表示するために必要な部分のみを記述しています。

・インクルードファイル
・メニュー
・アイコン
・ビットマップ
・ダイアログ
・リソースファイルの内容
/////////////////////////////////////////////////////////////////////////////
// Include file
//
#include "winres.h"

/////////////////////////////////////////////////////////////////////////////
//
// Menu
//
MYMENU MENU DISCARDABLE 
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Open...",                    101
        MENUITEM "&Save...",                    102
        MENUITEM "E&xit",                       109
    END
    POPUP "&Edit"
    BEGIN
        MENUITEM "&FFT\tCtrl+F",                201
        MENUITEM SEPARATOR
        MENUITEM "&Test\tCtrl+T",               203
        MENUITEM SEPARATOR
        MENUITEM "&Undo\tCtrl+Z",               205, GRAYED
        MENUITEM "&Copy\tCtrl+C",               206, GRAYED
        MENUITEM "&Paste\tCtrl+V",              207, GRAYED
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&Contents",                   701
        MENUITEM SEPARATOR
        MENUITEM "&Index",                      702
        MENUITEM SEPARATOR
        MENUITEM "&About",                      703
    END
END

/////////////////////////////////////////////////////////////////////////////
//
// Icon
//
MYICON    ICON    DISCARDABLE     "HTMLHELP.ico"

/////////////////////////////////////////////////////////////////////////////
//
// BMP
//
MYBMP   BITMAP  DISCARDABLE "C:\\Program Files\\Microsoft Visual Studio\\MyProjects\\HTMLHELP\\LOGO.BMP"

/////////////////////////////////////////////////////////////////////////////
//
// About Dialog
//
ABOUTDLG DIALOG FIXED PURE  22, 17, 167, 64
STYLE DS_MODALFRAME | WS_VISIBLE | WS_CAPTION | WS_SYSMENU
CAPTION "About Filter"
BEGIN
    CONTROL        "MYBMP",IDC_STATIC,"Static",SS_BITMAP,0,0,13,14
    DEFPUSHBUTTON  "OK",IDOK,132,2,32,14
    ICON           "Filter",-1,2,3,1,1
    LTEXT          "Noise reduction filter",400,40, 2, 80,8
    LTEXT          "Author Y.Akatsuka",     401,40,10, 80,8
    LTEXT          "ProductVersion V01L001",402,40,18, 80,8
    LTEXT          "Create 2002.06.17",     404,40,26, 80,8
    CONTROL        "",501,"Static",SS_BLACKRECT,30,36,138,1
    LTEXT          "Copyright Y.Akatsuka",  403,40,40, 80,8
END

 特に解説の必要はないと思いますが,ビットマップの定義はAboutダイアログの中に表示するビットマップを指定しています。

13.6 プログラムサンプル

!*********************************************************************
!  HTMLHELP sample 
!        2002.06.25  2002.06.25  Y.AKATSUKA
!*********************************************************************

!*********************************************************************
!  Global variable definition 
!*********************************************************************
module WINCOM
use dfwina

interface
integer function HtmlHelpA(hWnd, pszFile, uCommand, dwData)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_HtmlHelpA@16' :: HtmlHelpA
integer hWnd, pszFile, uCommand, dwData
end function
end interface

integer, parameter :: HH_DISPLAY_TOPIC = #00000000
integer, parameter :: HH_HELP_FINDER   = #00000000 ! WinHelp equivalent
integer, parameter :: HH_DISPLAY_TOC   = #00000001
integer, parameter :: HH_DISPLAY_INDEX = #00000002
integer, parameter :: HH_DISPLAY_SEARCH= #00000003
integer, parameter :: HH_CLOSE_ALL     = #00000012
integer, parameter :: HH_INITIALIZE    = #0000001C ! Initializes the help system.
integer, parameter :: HH_UNINITIALIZE  = #0000001D ! Uninitializes the help system.
integer, parameter :: HH_PRETRANSLATEMESSAGE = #000000fd ! Pumps messages.

integer*4 ghInst
end module

!*********************************************************************
!  WinMain 
!        2002.06.25  2002.06.25  Y.AKATSUKA
!*********************************************************************
integer function WinMain(hInstance,hPrevInstance,lpszCmdLine,nCmdShow)  
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
use WINCOM

interface 
integer function MainWndProc (hwnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
integer hwnd, mesg, wParam, lParam
end function
end interface
!
integer hInstance, hPrevInstance, lpszCmdLine, nCmdShow
integer hWnd, hmenu
character lpszClassName*10
type (T_WNDCLASS)  wc
type (T_MSG)       mesg
!
   ghInst = hInstance
   lpszCmdLine = lpszCmdLine
   nCmdShow = nCmdShow
   lpszClassName="HTMLHELP"C
   if(hPrevInstance .eq. 0) then
      wc%lpszClassName= LOC(lpszClassName)
      wc%lpfnWndProc  = LOC(MainWndProc)
      wc%style        = IOR(CS_VREDRAW ,CS_HREDRAW)
      wc%hInstance    = hInstance
      wc%hIcon        = LoadIcon(hInstance, LOC("MYICON"C))
      wc%hCursor      = LoadCursor(NULL, IDC_ARROW)
      wc%hbrBackground= (COLOR_WINDOW +2) ! +1:white +2:black
      wc%lpszMenuName = 0
      wc%cbClsExtra   = 0
      wc%cbWndExtra   = 0
      i = RegisterClass(wc)     ! i : dummy
   end if

   hmenu  = LoadMenu(hInstance, LOC("MYMENU"C))
   hWnd = CreateWindowEx(0, lpszClassName,    &
                    "HTMLHELP"C,              &
                    INT(WS_OVERLAPPEDWINDOW), &
                    CW_USEDEFAULT,            &
                    0,                        &
                    CW_USEDEFAULT,            &
                    0,                        &
                    NULL,                     &
                    hmenu,                    &
                    hInstance,                &
                    NULL)
   i = ShowWindow(hWnd, SW_SHOWNORMAL)

   do while (GetMessage(mesg, NULL, 0, 0) .NEQV. .FALSE.)
       i = TranslateMessage(mesg)
       i = DispatchMessage(mesg)
   end do
   WinMain = mesg.wParam
end

!*********************************************************************
!    MainWndProc
!*********************************************************************
integer function MainWndProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_MainWndProc@16' :: MainWndProc
use WINCOM

interface
integer*4 function AboutDlgProc(hWnd, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_AboutDlgProc@16' :: AboutDlgProc
integer hWnd, mesg, wParam, lParam
end function
end interface

integer hWnd, mesg, wParam, lParam
type (T_PAINTSTRUCT) ps
integer hInst, hBitmap, hDC, hmdc
integer ih/0/, dwCookie
character helpfile*80/"C:\\Windows\\HELP\\API.CHM"C/
logical b

   select case (mesg)
   case (WM_CREATE)
   case (WM_PAINT)
     hDC = BeginPaint(hWnd, ps)             ! ==> EndPaint
     i = TextOut(hDC,20,30,"HTMLHELP"C,8)
     b = EndPaint(hWnd, ps)                 ! <== BeginPaint
   case (WM_DESTROY)
     if (ih /= 0) then
       i = HtmlHelpA(NULL, NULL, HH_CLOSE_ALL, 0)
     end if
     call PostQuitMessage(0)
   case (WM_COMMAND)
     select case (INT4(LOWORD(wParam)))
     case (101)  ! Open
       i = InvalidateRect(hWnd, NULL_RECT, .TRUE.)
     case (109)  ! Exit
       i = SendMessage(hWnd, WM_CLOSE, 0, 0)
     case (701)  ! Help Contents
       if (ih == 0) then
         ih = HtmlHelpA(NULL, NULL, HH_INITIALIZE, LOC(dwCookie))
       end if
       i = HtmlHelpA(hWnd,LOC(helpfile),HH_DISPLAY_TOC,NULL)
     case (702)  ! Help Index
       if (ih == 0) then
         ih = HtmlHelpA(NULL, NULL, HH_INITIALIZE, LOC(dwCookie))
       end if
       i = HtmlHelpA(hWnd,LOC(helpfile),HH_DISPLAY_INDEX,LOC(""C))
     case (703)  ! Help About
       i = DialogBoxParam(ghInst,LOC("AboutDlg"C),hWnd,LOC(AboutDlgProc),0)
     case DEFAULT
       MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
       return
     end select
   case default
     MainWndProc = DefWindowProc(hWnd, mesg, wParam, lParam)
   end select
end

!*********************************************************************
!   AboutDlgProc is called from MainWndProc.
!*********************************************************************
integer*4 function AboutDlgProc(hDlg, mesg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_AboutDlgProc@16' :: AboutDlgProc
use WINCOM
integer*4  hDlg, mesg, wParam, lParam
integer*4  hfontDlg

  lParam = lParam
  select case (mesg)
  case (WM_INITDIALOG)   ! message: initialize dialog box
    ! Create a font to use
    hfontDlg = CreateFont(12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
               IOR(INT(VARIABLE_PITCH),INT(FF_ROMAN)), "Times New Roman"C)
    AboutDlgProc = 1
    return
  case (WM_COMMAND)
    select case (INT4(LOWORD(wParam)))
    case (IDOK)
      i = EndDialog(hDlg, TRUE)
      i = DeleteObject (hfontDlg)
      AboutDlgProc = 1
      return
    end select
  end select
  AboutDlgProc = 0  ! Didn't process the message
  return
end

プログラムの解説

1) プログラムの概要

 このプログラムは,前章のノイズ消去プログラムにヘルプを組み込むことを想定していますが,サンプルプログラムはヘルプ表示に最低限必要な機能のみで構成しています。 プログラムを実行すると,画面には”HTMLHELP"と表示されます。 メニューの"Help"をクリックすると,"Contents","Index","About"のサブメニューが表示され,"Contents"又は"Index"をクリックすると,HTML形式のHelpが表示されます。 "About"をクリックすると,プログラムのバージョン情報などを含むダイアログが表示されます。

図13.2 About画面の例

2) プログラムの説明

 グローバル変数を定義するモジュール定義WINCOMでは,interface文を用いてHTML Help用API関数を定義しています。 また,HtmlHelpA関数のコマンドとして引用する定数も定義しています。 ここで使用するコマンドはHTML Help WorkshopがインストールされているINCLUDEディレクトリの中にあるHTMLHELP.Hというヘッダーファイルを参照すると分かります。 このヘッダーファイルは,Fortranからは直接用いることができないので必要な項目のみを拾い出してFortranの定数定義に置き換えます。 このサンプルプログラムでは,WinMainProc関数からしか引用していないので,特にグローバル領域で定義する必要はありませんが,他のサブルーチンや関数から引用する可能性があるので本プログラムではここで定義しています。

 WinMain関数は特に説明の必要はありません。 ただし,キー入力可能な状態でヘルプ表示を行うような場合には,メッセージループの途中でHH_PRETRANSLATEMESSAGEコマンドを実行する必要がありますが,ここでは省略しています。

 MainWndProc関数では,以下の処理を行います。

・WM_DESTROY
HtmlHelpA関数を用いてHH_CLOSE_ALLコマンドを実行し,開いているヘルプウィンドウをすべてクローズします。
・(701)
メニューの"Contents"が選択されたときに実行します。 最初にヘルプを表示するときには,HtmlHelpA関数を用いてHH_INITIALIZEコマンドを実行し,HELPシステムを初期化します。 続いて,HH_DISPLAY_TOCコマンドを実行し,helpfile変数で設定したヘルプファイルを表示します。 プログラムサンプルでは,API.CHMを引用していますが,プログラム用のHELPコンテンツを作成したらそれに置き換えます。
・(702)
メニューの"Index"が選択されたときに実行します。 (701)と同様に,最初にヘルプを表示するときには,HH_INITIALIZEコマンドを実行し,HELPシステムを初期化します。 続いて,HH_DISPLAY_INDEXコマンドを実行し,helpfile変数で設定したヘルプファイルを表示します。 このときHtmlHelpA関数の第4パラメータには,検索するキーのデフォルトを設定できますが,ここではNULLにしてあります。 キーワードの処理をプログラムで行う場合には意味がありそうですが,通常はHelpシステムにまかせれば十分でしょう。
・(703)
メニューの"About"が選択されたときに実行します。 既に何度も用いているDialogBoxParam関数を実行し,リソースファイルに定義してあるダイアログ情報を表示します。

 AboutDlgProc関数は,Aboutダイアログのメッセージを処理する手続きです。 表示するフォントを定義し,OKボタンが押されたときにダイアログを閉じるよう記述しています。

13.7 HELPコンテンツの作成

 HELPコンテンツを作成するには,HTML Help Workshopを用い, 以下の手順に従って作成します。 なお,詳しい解説は,HTML Help Workshopの日本語オンラインヘルプを参照してください。

(1) トピックファイルの作成
(2) プロジェクトの作成
(3) プロジェクトにトピックを追加
(4) 目次の設定
(5) 索引(キーワード)の設定
(6) コンパイル

図13.3 FilterプログラムのHELPの例

1) トピックファイルの作成

 トピックファイルは,ヘルプの本文でWebで用いるHTML形式のファイルで作成します。 HTML Help Workshopを用いて作成することもできますが,普段用いるエディタを用いて作成してもかまいません。 HTML Help Workshopのプロジェクトを作成したら,これに登録します。

 ・トピックファイルの例

 <html>
 <head>
 <title>Filterプログラム</title>
 </head>
 <body background="CLOUD.jpg">
 <center><h1>Filterプログラム</h1></center>
 <a name="プログラムの概要">
 <h2>1) プログラムの概要</h2>
 <p> 折角入手したきれいなお姉さんの画像に周期的な横線又は縦線の縞模様状
 ノイズが入っていてがっかりした経験があるかも知れません。 使用したスキャナ
 やデジカメによってはこうしたノイズが乗る可能性があります。 そこで,ノイズ
 を消去することを考えるわけですが,一般の画像処理ソフトでは画像ファイルのノ
 イズ消去にはメディアンフィルタが多く用いられています。 しかし,メディアン
 フィルタを用いて周期的なノイズを消去しようとすると画質の大幅な低下が避けら
 れません。 フーリエ変換によって特定の周期成分のみを除去すれば,画質の低下
 を最小限に抑えることができます。</p>
 <p> このプログラムは,画像データに含まれる周期ノイズを除去するものです。
  周期ノイズの方向は水平から45°以内とします。それ以上の場合は適当なツール
 を用いて90°回転させてから実行します。 フーリエ変換を用いて特定の周期成分
 を除去した後,フーリエ逆変換を用いて画像を再生します。</p>
 <p><center><img src="FILTER02.jpg" WIDTH="400" HEIGHT="512">
 </center></p>
 <a name="プログラムの使用方法">
 <h2>2) プログラムの使用方法</h2>
 <p> プログラムを起動すると,FILTERというタイトルのメインウィンドウが開
 きます。 FileメニューのOpenを選択し,ノイズ除去したいBMP形式の画像を選択
 すると,メインウィンドウに画像が表示されます。<br>
  ノイズ除去したい矩形領域をマウスポインタを用いて指定します。 矩形領域の
 左上にマウスを移動し,左クリックを押しながら右下の位置へ移動します。このと
 き矩形カーソルが表示されます。 スクロールが必要なときは矢印キーを併用しま
 す。 ただし,FFTを用いる関係でY方向のビット幅は2のべき乗に調節されます。
 <br>
  領域選択をした後,EditメニューのFFTを選択すると,選択した範囲を表示する
 サブウィンドウと図2 のような入力ダイアログが表示されます。 RGBのチェッ
 クボックスのチェックをONにし,再表示ボタンを押すと,図2 のようにチェックさ
 れた成分のみがサブウィンドウに表示されるのでノイズを含むRGB成分を特定し
 ます。</p>
 <p><center><img SRC="FILTER03.jpg" WIDTH="477" HEIGHT="438"></p>
 <p>図2 サブウィンドウの表示</center></p>
 <p> ノイズを含むRGB成分が特定できたらノイズの周期を特定します。 ダ
 イアログのエディットボックスにノイズ消去する波長を入力します。 サブウィン
 ドウ内のノイズ部分をマウスで左クリックすると座標位置が表示されるので,それ
 を目安にY方向の波長をドットサイズを基準に小数点以下第1位まで入力します。
  2つあるエディットボックスには範囲を指定します。 当初は少し広めに範囲を
 設定し,Enterキーを押すかEnterボックスをクリックすると,指定された範囲の波
 長成分を除去した画像がサブウィンドウに表示されます。 やり直しをする場合は
 Cancelボタンをクリックします。 できるだけ狭い範囲でノイズが軽減されたなら
 ば,OKボタンをクリックすると原画像に反映されます。 効果が期待できる範囲は
 2.0〜10.0くらいですが,周期ノイズは1種類だけとは限りません。 上のエディ
 ットボックスに2.0以下の値を指定し,下のエディットボックスに0.0を指定した場
 合は,フーリエ変換を行わず平滑化によってノイズを除去します。<br>
  ノイズ除去できるY方向範囲は2のべき乗に限られるため,必要に応じて再度範
 囲を設定しこれらの操作を繰り返します。 ただし,一度ノイズ消去した領域にオ
 ーバーラップして再度領域を設定したり,もともとノイズのない領域を設定して周
 期成分を除去すると,返ってモアレ状のノイズが発生する場合があります。<br>
  ノイズ消去の終わった画像は,FileメニューのSaveを選択すると,保存するファ
 イル名の入力ダイアログが表示されるので,適当な名前を付けて画像を保存します。
 </p>
 <a name="備考">
 <h2>3) 備考</h2>
 <p> フーリエ変換は数学ライブラリNUMPACから実高速フーリエ変換FFT(Fast 
 Fourier Transform)と逆変換のルーチンを引用しています。</p>
 </body>
 </html>

 トピックファイルを作成するときに,後で目次にすべき項目は<h1></h1>,<h2></h2>,<h3></h3>というタグで囲むようにします。 HTML Help Workshopの目次を自動で作成する機能を用いる場合には,これらのタグで囲まれた項目が目次として用いられます。

2) プロジェクトの作成

 HTML Help Workshopを起動し,プロジェクトを作成します。 FileメニューのNewを選択すると,Newダイアログが表示されるのでProjectを選択しOKをクリックします。  New Project--Destinationダイアログが表示されたら,プロジェクト名を入力します。 指定されたプロジェクト名からプロジェクトファイル(.hhp)が作成されます。

3) プロジェクトにトピックを追加

 New Project--Existing Filesダイアログが表示されたら,HTML files(.htm)の項目にチェックをし,次へをクリックします。 New Project--HTML FilesダイアログでAddをクリックし,開くダイアログが表示されたら,1)で作成したトピックファイルの名前を指定します。 New Project--HTML Filesダイアログのウィンドウに指定したファイル名が表示されます。 トピックファイルが複数ある場合はこの操作を繰り返します。 次へをクリックし,完了をクリックすると,図13.4のような画面が表示されます。

図13.4 HTML Help Workshopの画面の例

4) 目次の設定

 目次(Table of Contents)(.hhc)ファイルは,プロジェクト作成と同様に作成します。 図13.4の画面でContentsを選択すると,目次ファイルがない場合には問い合わせが出るので,ここで作成することもできます。 Projectメニューの下にあるPropertiesボタンを押すと,目次項目のプロパティを設定できます。 目次項目の頭に付くアイコンを本のマークに変更したりすることができます。
 Projectメニューの2つ下のInsert a headingボタンを押して目次項目を一つ一つ登録することもできますが,トピックファイルに<h*>タグで目次項目が設定されている場合には,目次ファイルの内容を自動で作成することができます。
 目次を自動で作成するには,ProjectメニューのChange project optionsを選択し,OptionsダイアログのFilesを選択すると,Automatically create contents file(.hhc) when compilingの項目が表示されるのでチェックを入れます。 同時にMaximum head levelの値を目次の最大レベルの値に設定しておきます。 目次はCompile操作をしたときに作成されます。 目次(.hhc)ファイルもHTML形式のファイルです。 後でエディタを用いて項目を追加したりトピックファイルとの対応をとるように変更を加えます。

 ・目次(Table of Contents)(.hhc)ファイルの例

<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<HTML>
<HEAD>
 <meta name="GENERATOR" content="Microsoft® HTML Help Workshop 4.1">
 <!-- Sitemap 1.0 -->
</HEAD>
<BODY>
<OBJECT type="text/site properties">
 <param name="Window Styles" value="0xc00225">
 <param name="ImageType" value="Folder">
</OBJECT>
<UL>
 <LI><OBJECT type="text/sitemap">
 <param name="Name" value="Filterプログラム">
 <param name="Local" value="HTMLHELP01.htm">
 <param name="ImageNumber" value="1">
 </OBJECT>
 <UL>>
  <LI><OBJECT type="text/sitemap">
  <param name="Name" value="1) プログラムの概要">
  <param name="Local" value="HTMLHELP01.htm#プログラムの概要">
  <param name="ImageNumber" value="1">
  </OBJECT>
  <LI><OBJECT type="text/sitemap">
  <param name="Name" value="2) プログラムの使用方法">
  <param name="Local" value="HTMLHELP01.htm#プログラムの使用方法">
  <param name="ImageNumber" value="1">
  </OBJECT>
  <LI><OBJECT type="text/sitemap">
  <param name="Name" value="3) 備考">
  <param name="Local" value="HTMLHELP01.htm#備考">
  <param name="ImageNumber" value="1">
  </OBJECT>
 </UL>
</UL>
</BODY>
</HTML>

5) 索引(キーワード)の設定

 索引(.hhk)ファイルは,索引用のキーワード項目を含むHTMLファイルです。 索引(.hhk)ファイルもプロジェクト作成と同様に作成します。 図13.4の画面でIndexを選択すると,索引ファイルがない場合には問い合わせが出るので,ここで作成することもできます。 既にいくつかの索引が表示されている場合には,そのうちのどれかを選択した後,Insert a keywordボタンをクリックするとIndex Entryダイアログが表示されるので,Keywordの欄に項目を入力します。 Project fileにプロジェクトファイル名,File or URLにキーワードを含むトピックファイル名を設定し,OKをクリックします。 目次ファイルと同様に後でエディタを用いて項目を追加したりトピックファイルとの対応をとるように変更を加えます。

 ・索引(.hhk)ファイルの例

<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<HTML>
<HEAD>
<meta name="GENERATOR" content="Microsoft® HTML Help Workshop 4.1">
<!-- Sitemap 1.0 -->
</HEAD>
<BODY>
<UL>
<LI><OBJECT type="text/sitemap">
 <param name="Name" value="FFT">
 <param name="Local" value="HTMLHELP01.htm#プログラムの使用方法">
 </OBJECT>
<LI><OBJECT type="text/sitemap">
 <param name="Name" value="NUMPAC">
 <param name="Local" value="HTMLHELP01.htm#備考">
 </OBJECT>
<LI><OBJECT type="text/sitemap">
 <param name="Name" value="RGB">
 <param name="Local" value="HTMLHELP01.htm#プログラムの使用方法">
 </OBJECT>
<LI><OBJECT type="text/sitemap">
 <param name="Name" value="フーリエ変換">
 <param name="Local" value="HTMLHELP01.htm">
 </OBJECT>
<LI><OBJECT type="text/sitemap">
 <param name="Name" value="メディアンフィルタ">
 <param name="Local" value="HTMLHELP01.htm#プログラムの概要">
 </OBJECT>
</UL>
</BODY>
</HTML>

6) コンパイル

 コンパイルは,プロジェクトに登録されたトピックファイルや目次,索引ファイルからHTML Help形式(.chm)のファイルに変換します。 コンパイルをする前にDefault fileの設定と全文検索機能の追加を設定しておきます。 Default fileはヘルプを表示したときに最初に表示される画面を設定します。 また,全文検索は指定したキーワードをトピックファイルから検索し,該当個所があればキーワードをハイライト表示してくれる機能です。 Default fileの設定は,ProjectメニューのChange Project Optionsをクリックし,Generalを選択すると表示されるダイアログに設定します。 同時にヘルプウィンドウに表示されるタイトルも必要に応じて設定します。 全文検索を有効にするには,ProjectメニューのChange Project Optionsをクリックし,Compilerを選択すると表示されるCompile full-text search informationの項目をチェックしておきます。 ついでに,Create a binary Indexの項目もチェックしておきます。

 さて,これで準備は整いました。 ツールバーの左から3つ目にあるCompile HTML fileボタンをクリックするとコンパイルが実行されエラーがなければ,(.chm)ファイルが作成されます。 ツールバーのめがねのボタンをクリックするとコンパイルされたHTML Helpファイルの内容が表示されます。 なお,一度コンパイルすると先に説明した目次(.hhc)ファイルに目次の内容が書き込まれます。 これをエディタで修正したり追加した場合には,必ずOptionsダイアログのAutomatically create contents file(.hhc) when compilingの項目のチェックを外しておくことを忘れないようにしてください。 これを怠ると次回コンパイルをしたときに,折角修正した内容が元に戻ってしまいます。

13.8 プログラムへの組み込み

 HTML Helpファイルができたら,プログラムから表示できるようにプログラムの中に定義してあるHELPファイルの名前(先のプログラムでは"C:\\Windows\\HELP\\API.CHM"Cになっていました)を,ここで作成したコンパイル済みのHTML Helpファイルに変更します。 これでヘルプ機能も備えたWindowsプログラムが一応完成しました。