home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Graphics / Graphics.zip / os2apipm.zip / PMEXAM / HELLO / HELPHELL.ADB < prev    next >
Text File  |  1996-08-12  |  7KB  |  192 lines
  1. with text_io;
  2. with builtin; use builtin;
  3. with os2; use os2;
  4. with os2.bse ; use os2.bse ;
  5. with os2.pmwb; use os2.pmwb;
  6. with os2.pmcp; use os2.pmcp;
  7. with os2.pmwd; use os2.pmwd;
  8. with os2.pmsc; use os2.pmsc;
  9. with os2.Gpi; use os2.Gpi;
  10. package body helphell is
  11.  
  12. err_info     :aliased ERRINFO;
  13. pErrInfoBlk  :PERRINFO:=err_info'access  ;
  14. pszOffSet    :PSZ       ;
  15. rc : apiret;
  16. mp :mparam := 0       ;
  17. ermsg:constant astring:=  "Error Msg" & nul_char;
  18.  
  19. function GoOut(Frame,Client:HWND) return BOOL32 is
  20.  
  21. begin
  22. rc:=      DosBeep(100,10);
  23. pErrInfoBlk:= WinGetErrorInfo(ha);
  24. if  err_info.idError /= 0  then
  25.  pszOffSet:= err_info.offaoffszMsg'address;
  26.  pszErrMsg:= err_info.offaoffszMsg'address;
  27. --        pszErrMsg:= ((PSZ)pErrInfoBlk) + *((PSHORT)pszOffSet);
  28. end if;
  29.  
  30. if Frame/=0 and Client/=0   then
  31.  
  32.  
  33. rcul:=  WinMessageBox(1           , -- Parent window is desk top  HWND_DESKTOP HWND
  34.                       hwndFrame,    -- Owner window is our frame      HWND
  35.                       pszErrMsg,    -- PMWIN Error message            PSZ
  36.                       ermsg(1)'address,   -- Title bar message        PSZ
  37.                       1001    ,           -- Message identifier MSGBOXID ULONG
  38.                       16#4046#            -- 4000 40 6
  39.                  --   MB_MOVEABLE | MB_CUACRITICAL | MB_CANCEL -- Flags  ULONG
  40.                       ); -- Ulong
  41. end if;
  42. rcb32:=   WinFreeErrorInfo(pErrInfoBlk);
  43.  
  44. rcb32:= WinPostMsg(Client,  -- HWND
  45.                    WM_QUIT   ,  -- ULONG
  46.                    mp        ,  -- MPARAM
  47.                    mp           -- MPARAM
  48.                    );           -- BOOL32
  49. return rcb32;
  50. End GoOut;
  51.  
  52. function MyWindowProc(hwn:HWND   ;
  53.                       msg:ULONG  ;
  54.                       mp1:Mparam ;
  55.                       mp2:Mparam )return Ulong is
  56.  
  57. hp  :HPS    ;                        -- Presentation Space handle
  58. Paint  :aliased RECTL  ;             -- Rectangle coordinates
  59. pt     :aliased POINTL ;             -- String screen coordinates
  60. begin
  61.  
  62. Text_io.New_line; put_edit("Start MyWindowProc msg=>",integer(msg),4);
  63. case  msg is
  64.  when  WM_CREATE   =>
  65.         text_io.put(" Wm_Create");
  66. --         * Window initialization is performed here in WM_CREATE processing
  67. --         * WinLoadString loads strings from the resource file.
  68.   rcl  := WinLoadString( ha                     , --   HAB
  69.                          0                      , --   HMODULE
  70.                          IDS_HELLO              , --   ULONG
  71.                          STRINGLENGTH           , --   LONG
  72.                          szHello(1)'address     --   PSZ
  73.   );                                   --   LONG
  74. put_edit(" LoadStr 0=>",integer(rcl),4);
  75.   rcl  := WinLoadString(ha ,0   ,IDS_1  , STRINGLENGTH, sz1(1)'address );
  76. put_edit(" LoadStr 1=>",integer(rcl),4);
  77.   rcl  := WinLoadString(ha ,0   ,IDS_2  , STRINGLENGTH, sz2(1)'address );
  78. put_edit(" LoadStr 2=>",integer(rcl),4);
  79.   rcl  := WinLoadString(ha ,0   ,IDS_3  , STRINGLENGTH, sz3(1)'address );
  80. put_edit(" LoadStr 3=>",integer(rcl),4);
  81.   szString:=szHello ;                      -- Copy text Hello into szString
  82.  
  83.  when  WM_COMMAND =>
  84.         text_io.put(" Wm_Command");
  85.  
  86.   --  * When the user chooses option 1, 2, or 3 from the Options pull-
  87.   --  * down, the text string is set to 1, 2, or 3, and
  88.   --  * WinInvalidateRegion sends a WM_PAINT message.
  89.   --  * When Exit is chosen, the application posts itself a WM_CLOSE
  90.   --  * message.
  91.  
  92.      case mp1  is
  93.       when  ID_OPTION1  =>  szString:= sz1 ;
  94.        rcb:=     WinInvalidateRegion( hwn ,   -- HWND
  95.                                       0   ,   -- HRGN
  96.                                       0       -- BOOL32
  97.        );                                     -- BOOL
  98.  
  99.       when ID_OPTION2  =>  szString:=sz2 ;
  100.        rcb:=     WinInvalidateRegion( hwn , 0 , 0     );
  101.  
  102.       when  ID_OPTION3  => szString:=sz3 ;
  103.        rcb:=     WinInvalidateRegion( hwn , 0, 0 );
  104.  
  105.        when ID_EXITPROG   =>
  106.         rcb32:=     WinPostMsg( hwn     ,  -- HWND
  107.                               WM_CLOSE  ,  -- ULONG
  108.                                 mp      ,  -- MPARAM
  109.                                 mp         -- MPARAM
  110.                                );
  111.  
  112.       when others =>
  113.        rcb32 := WinDefWindowProc( hwn,   -- HWND
  114.                                   msg,   -- ULONG
  115.                                   mp1,   -- Mparam
  116.                                   mp2    -- Mparam
  117.                                   );
  118.        return  ulong(rcb32);
  119.       end case;
  120.  
  121.     when WM_ERASEBACKGROUND  =>
  122.  
  123.         text_io.put(" Wm_Erasebackground");
  124.      --  * Return TRUE to request PM to paint the window background
  125.      --  * in SYSCLR_WINDOW.
  126.  
  127.     return one;
  128.  
  129.     when WM_PAINT  =>
  130.         text_io.put(" Wm_Paint");
  131.  
  132.      --  * Window contents are drawn here in WM_PAINT processing.
  133.  
  134.                          -- Create a presentation space
  135.  
  136.       hp := WinBeginPaint( hwn        ,           -- HWND
  137.                            0          ,           -- HPS
  138.                            Paint'unchecked_access -- PRECL
  139.                           );                      -- HPS
  140.  
  141.       pt.x:= 50; pt.y:= 50;             -- Set the text coordinates,
  142.  
  143.       -- colour of the text,
  144.       rcb  :=  GpiSetColor( hp ,         -- HPS
  145.                             CLR_NEUTRAL  -- LONG
  146.                );                        -- BOOL
  147.  
  148.       rcb  :=  GpiSetBackColor( hp ,0 );  -- its background and CLR_BACKGROUND
  149.  
  150.       rcb  :=  GpiSetBackMix( hp ,2);      -- BM_OVERPAINT how it mixes,
  151.  
  152.       rcl:= GpiCharStringAt(hp                 ,  -- HPS
  153.                             pt'unchecked_access,  -- PPOINL
  154.                             STRINGLENGTH       ,  -- LONG
  155.                             szString(1)'address   -- PCH
  156.                      );                           -- LONG
  157.  
  158.  
  159.       rcb32:=  WinEndPaint( hp  );   -- Drawing is complete
  160.  
  161.     when 16#29# =>   -- WM_CLOSE
  162.         text_io.put(" Wm_Close");
  163.  
  164.    --  * This is the place to put your termination routines
  165.  
  166.       rcb32:=   WinPostMsg( hwn    ,    -- HWND
  167.                            WM_QUIT ,    -- ULONG
  168.                             mp     ,    -- MPARAM
  169.                             mp          -- MPARAM
  170.                  );-- Cause termination  -- BOOL32
  171.  
  172.     when others =>
  173.         text_io.put(" Null");
  174.  
  175.   --   * Everything else comes here.  This call MUST exist
  176.   --   * in your window procedure.
  177.   --
  178.   --
  179.      rcb32 := WinDefWindowProc( hwn ,    -- HWND
  180.                                 msg,     -- ULONG
  181.                                 mp1,     -- Mparam
  182.                                 mp2      -- Mparam
  183.                                );
  184.      return Ulong(rcb32);
  185.  end case;
  186.  put_edit(" End myWindowProc msg=>",integer(msg),4);
  187.  return zero ;
  188.  
  189. End MyWindowProc;
  190.  
  191. end helphell;
  192.