home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Graphics / Graphics.zip / os2apipm.zip / PMEXAM / HELLO / HELLO.ADB next >
Text File  |  1996-08-13  |  8KB  |  201 lines
  1. with text_io; use text_io;
  2. with builtin; use builtin;
  3. with os2; use os2;
  4. with os2.pmwb; use os2.pmwb;
  5. with os2.pmsc; use os2.pmsc;
  6. with os2.pmcp; use os2.pmcp;
  7. with os2.pmer; use os2.pmer;
  8. with helphell;use helphell;
  9.  
  10. --  /*************** Hello Sample Program Source Code File (.adb) ************
  11. --   *
  12. --   * PROGRAM NAME: HELLO
  13. --   * -------------
  14. --   *  Presentation Manager Standard Window Ada-95 Sample Program
  15. --   *
  16. --   * REVISION LEVEL: 1.0
  17. --   * ---------------
  18. --   *
  19. --   * WHAT THIS PROGRAM DOES:
  20. --   * -----------------------
  21. --   *  This program displays a standard window containing the text "Hello".
  22. --   *  The action bar contains a single choice, Options.
  23. --   *  The Options pull-down contains three choices that each
  24. --   *  paint a different string in the window.
  25. --   *
  26. --   * WHAT THIS PROGRAM DEMONSTRATES:
  27. --   * -------------------------------
  28. --   *  This program demonstrates how to create and display a standard window,
  29. --   *  and how to use resources defined in a resource script file.
  30. --   *
  31. --   * WHAT YOU NEED TO COMPILE THIS PROGRAM:
  32. --   * --------------------------------------
  33. --   *
  34. --   *  REQUIRED FILES:
  35. --   *  ---------------
  36. --   *
  37. --   *    HELLO.adb     - Source code  helphell.ads helphell.adb
  38. --   *    HELLO.ICO     - Icon file
  39. --   *    HELLO.RC      - Resource file
  40. --   *
  41. --   *  REQUIRED LIBRARIES:
  42. --   *  -------------------
  43. --   *
  44. --   *    OS2.A     - Presentation Manager/OS2 library
  45. --   *
  46. --   *  REQUIRED PROGRAMS:
  47. --   *  ------------------
  48. --   *    GNAT Ada-95 Compiler  3.05
  49. --   *    Resource Compiler
  50. --   *
  51. --   *      DISCLAIMER OF WARRANTIES.  The following [enclosed] code is
  52. --   *      sample code created by IBM Corporation. This sample code is not
  53. --   *      part of any standard or IBM product and is provided to you solely
  54. --   *      for  the purpose of assisting you in the development of your
  55. --   *      applications.  The code is provided "AS IS", without
  56. --   *      warranty of any kind.  IBM shall not be liable for any damages
  57. --   *      arising out of your use of the sample code, even if they have been
  58. --   *      advised of the possibility of such damages.                                                    *
  59. --   ******************************************************************************/
  60.  
  61. procedure hello is
  62.  
  63. --  --*************************************************************************
  64. --   *
  65. --   *
  66. --   *  Description: Initializes the process for OS/2 PM services and
  67. --   *               process the application message queue until a
  68. --   *               WM_QUIT message is received.  It then destroys all
  69. --   *               OS/2 PM resources and terminates.
  70. --   *
  71. --   *  Concepts   : - obtains anchor block handle and creates message
  72. --   *                   queue
  73. --   *               - creates the main frame window which creates the
  74. --   *                   main client window
  75. --   *               - polls the message queue via Get/Dispatch Msg loop
  76. --   *               - upon exiting the loop, exits
  77. --   *                                        Package
  78. --   *                                        -------
  79. --   *  API's      :   WinInitialize          OS2.PMwb
  80. --   *                 WinCreateMsgQueue      OS2.PMwb
  81. --   *                 WinTerminate           OS2.PMwb
  82. --   *                 WinSetWindowPos        OS2.PMwb
  83. --   *                 WinSetWindowText       OS2.PMwb
  84. --   *                 WinRegisterClass       OS2.PMwb
  85. --   *                 WinCreateStdWindow     OS2.PMsc
  86. --   *                 WinGetMsg              OS2.PMwb
  87. --   *                 WinGetLastError        OS2.PMcp
  88. --   *                 WinDispatchMsg         OS2.PMwb
  89. --   *                 WinDestroyWindow       OS2.PMwb
  90. --   *                 WinDestroyMsgQueue     OS2.PMwb
  91. --   *
  92. --   ************************************************************************
  93.  
  94. str_hel:astring(1..12):="Open window" & nul_char;
  95. point: PSZ  :=str_hel'address;
  96. print:file_type;
  97.  
  98. rcId    : ErrorId;
  99. pfl     : pulong;
  100. pClient : PHWND;
  101.  package int is new modular_io(ErrorId);
  102. begin
  103. create(file=>print,name=>"hello.prn",mode=>out_file);
  104. set_output(print);
  105. hello_txt(13):=nul_char;
  106. ha := WinInitialize(0);        -- Initialize PM
  107. if ha = 0 then
  108.   rcb32:=GoOut(hwndFrame, hwndClient); -- Terminate the application
  109.   goto fin;
  110. end if;
  111. put_edit(" Ha=",integer(ha),4);
  112. mq:= WinCreateMsgQueue( ha, 0 ); -- Create a msg queue
  113. if mq=0 then
  114.     rcb32:=GoOut(hwndFrame, hwndClient); -- Terminate the application
  115.     goto fin;
  116. end if;
  117. put_edit(" Mq=",integer(mq),4);
  118.  
  119.  pproc      :=MyWindowProc'address;   -- Address of window procedure
  120.  new_line;
  121.  rcb32:= WinRegisterClass(   -- Register window class
  122.            ha   ,         -- Anchor block handle            HAB
  123.            pwin ,         -- Window class name              PSZ
  124.            pproc,         -- Address of window procedure    PFNWP
  125.   CS_SIZEREDRAW ,         -- Class style  CS_SIZEREDRAW     ULONG
  126.            0              -- No extra window words          ULONG
  127.            ) ;
  128.  new_line; put_edit(" RegisterClass=",integer(rcb32),5);
  129.  
  130.   if  rcb32= 0 then                                    -- BOOL32
  131.         rcb32:=GoOut(hwndFrame, hwndClient); -- Terminate the application
  132.    put("Error 3");goto fin;
  133.   end if;
  134.  
  135. flCreate := 1 + 2 + 16#30# + 8 + 16#800# + 4 + 16#8000# ;
  136.  
  137.  put(" flCreate =>"); int.put(item=>ErrorId(flCreate),base=>16);
  138.  pfl:=flCreate'access;
  139.  pClient:=hwndClient'access;
  140.  hwndFrame:= WinCreateStdWindow(      -- return          HWND
  141.              HWND_DESKTOP,   -- Desktop window is parent HWND
  142.              0,              -- STD. window styles       ULONG
  143.              pfl ,           -- Frame control flag       PULONG
  144.              pwin,           -- Client window class name  PSZ
  145.              point,          -- No window text           PSZ
  146.              0   ,           -- No special class style   ULONG
  147.              0   ,           -- Resource is in .EXE file HMODULE
  148.              ID_WINDOW  ,    -- Frame window identifier  ULONG
  149.              pClient         -- Client window handle     PHWND
  150.  );
  151.  new_line;
  152.  put_edit(" hwndFrame=",integer(hwndFrame),4);
  153. if hwndFrame=0 then
  154.  rcId:=WinGetLastError(ha);
  155.  put("Error number =>");
  156.  case rcId is
  157.  when  PMERR_INVALID_HWND           => put(" PMERR_INVALID_HWND ");
  158.  when  PMERR_INVALID_FLAG           => put(" PMERR_INVALID_FLAG ");
  159.  when  PMERR_INVALID_INTEGER_ATOM   => put(" PMERR_INVALID_INTEGER_ATOM");
  160.  when  PMERR_ATOM_NAME_NOT_FOUND    => put(" PMERR_ATOM_NAME_NOT_FOUND");
  161.  when  PMERR_INVALID_ATOM_NAME      => put(" PMERR_INVALID_ATOM_NAME ");
  162.  when  others => put("Nonstandard"); int.put(item=>rcId,base=>16);
  163.  end case;
  164.   rcb32:=GoOut(hwndFrame, hwndClient); -- Terminate the application
  165.   put("Error 4") ;   goto fin;
  166.  end if;
  167.      rcb:=   WinSetWindowText(hwndFrame,              --  HWND
  168.                               hello_txt(1)'address    --  PSZ
  169.                                );                     --  BOOL
  170. new_line; put_edit(" SetWindText=",integer(rcb),4);
  171. --
  172.     rcb:= WinSetWindowPos( hwndFrame,   -- Shows and activates frame    HWND
  173.                           HWND_TOP,     -- window at position 100, 100, HWND
  174.                           100,          -- x Long
  175.                           100,          -- y Long
  176.                           200,          -- cx Long
  177.                           200,          -- cy Ulong
  178.                        16#8B#           -- SWP_SIZE | SWP_MOVE | SWP_ACTIVATE | SWP_SHOW
  179.                        );               --        1          2             80   8
  180. new_line; put_edit(" SetWindPos=",integer(rcb),4);
  181. if rcb  = 0 then
  182.      rcb32:=GoOut(hwndFrame, hwndClient); -- Terminate the application
  183.       goto fin;
  184. end if;
  185. --
  186. --  --   * Get and dispatch messages from the application message queue
  187. --  --   * until WinGetMsg returns FALSE, indicating a WM_QUIT message.
  188.  
  189. loop
  190. rcb32:=WinGetMsg( ha, msg'access, 0, 0, 0 ) ;
  191. exit when rcb32 = 0 ;
  192. rcmr := WinDispatchMsg( ha,              -- HAB
  193.                        msg'access       -- PQMSG
  194.                        );
  195. end loop;
  196. <<fin>> null; new_line; Put("End");
  197. rcb32:=WinDestroyWindow(hwndFrame);    -- Tidy up...  HWND
  198. rcb32:=WinDestroyMsgQueue( mq  );      -- Tidy up...  HMQ
  199. rcb32:=WinTerminate( ha );             -- Terminate the application HAD
  200. end hello;
  201.