Center a window to the working area

A window is not automatically centered to the screen, but is cascaded.
This procedure takes the widget-handle of a window as input parameter and centers the window to the 'working area'.
The working area is the portion of the screen not overlapped by the taskbar. So the result will differ when you move the taskbar to either of the 4 edges of the screen.
Windows 98 and Windows 2000 support multiple monitors. The monitors share a virtual desktop but each monitor has its own working area. This procedure is improved to center the window to the monitor where it is positioned at that time. That is, if the window is positioned somewhere on the secondary monitor it will be centered to the secondary monitor too.
The window will not dynamically stay centered using this procedure: if the size of the window changes or if the size/position of the taskbar changes, you will have to run this procedure again.

 
{windows.i}
 
PROCEDURE CenterWindow :
/*------------------------------------------------------------------------------
  Purpose:     centers window to the working area.
               ("working area" is portion of screen not obscured by taskbar)
  Parameters:  winhandle : progress widget-handle of a window widget
  Notes:       
------------------------------------------------------------------------------*/
  DEFINE INPUT PARAMETER winhandle AS HANDLE NO-UNDO.
 
  IF LOOKUP(winhandle:TYPE , "window,dialox-box":U ) = 0  THEN RETURN.
 
  /* calculate coordinates and dimensions of working area */
  DEFINE VARIABLE workingleft   AS INTEGER NO-UNDO.
  DEFINE VARIABLE workingtop    AS INTEGER NO-UNDO.
  DEFINE VARIABLE workingwidth  AS INTEGER NO-UNDO.
  DEFINE VARIABLE workingheight AS INTEGER NO-UNDO.
  DEFINE VARIABLE lpWorkingRect AS MEMPTR. /* RECT structure */
  DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
  SET-SIZE(lpWorkingRect)=4 * {&INTSIZE}.
  RUN GetWorkingArea (winhandle:HWND, lpWorkingRect).
 
  /* RECT is filled with left,top,right,bottom */
  workingleft   = get-{&INT}(lpWorkingRect,1 + 0 * {&INTSIZE}).
  workingtop    = get-{&INT}(lpWorkingRect,1 + 1 * {&INTSIZE}).
  workingwidth  = get-{&INT}(lpWorkingRect,1 + 2 * {&INTSIZE}) - workingleft.
  workingheight = get-{&INT}(lpWorkingRect,1 + 3 * {&INTSIZE}) - workingtop.
 
 
  /* calculate current coordinates and dimensions of window */
  DEFINE VARIABLE windowleft   AS INTEGER NO-UNDO.
  DEFINE VARIABLE windowtop    AS INTEGER NO-UNDO.
  DEFINE VARIABLE windowwidth  AS INTEGER NO-UNDO.
  DEFINE VARIABLE windowheight AS INTEGER NO-UNDO.
  DEFINE VARIABLE hParent AS INTEGER NO-UNDO.
  DEFINE VARIABLE lpWinRect AS MEMPTR.
 
  SET-SIZE(lpWinRect)=4 * {&INTSIZE}.
  hParent = GetParent(winhandle:HWND).
  RUN GetWindowRect IN hpApi(hParent, 
                             GET-POINTER-VALUE(lpWinRect), 
                             OUTPUT ReturnValue).
 
  windowleft   = get-{&INT}(lpWinRect,1 + 0 * {&INTSIZE}).
  windowtop    = get-{&INT}(lpWinRect,1 + 1 * {&INTSIZE}).
  windowwidth  = get-{&INT}(lpWinRect,1 + 2 * {&INTSIZE}) - windowleft.
  windowheight = get-{&INT}(lpWinRect,1 + 3 * {&INTSIZE}) - windowtop.
 
  /* calculate new x and y for window */
  windowleft = workingleft + INTEGER((workingwidth  - windowwidth ) / 2 ).
  windowtop  = workingtop  + INTEGER((workingheight - windowheight ) / 2 ).
 
  /* perhaps you should ensure that the upper-left corner of the window
     stays visible, e.g. user can reach system-menu to close the window: */
  windowleft = MAXIMUM(workingleft, windowleft).
  windowtop  = MAXIMUM(workingtop,  windowtop).
 
  /* assign these values. No need to use API: */
  ASSIGN winhandle:X = windowleft
         winhandle:Y = windowtop.
 
  /* free memory */
  SET-SIZE(lpWorkingRect) = 0.
  SET-SIZE(lpWinRect)     = 0.
 
END PROCEDURE.
 
PROCEDURE GetWorkingArea :
  DEFINE INPUT PARAMETER HWND   AS INTEGER NO-UNDO.
  DEFINE INPUT PARAMETER lpRect AS MEMPTR  NO-UNDO.
 
  DEFINE VARIABLE hMonitor AS INTEGER NO-UNDO.
  DEFINE VARIABLE lpMonitorInfo AS MEMPTR.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
  DEFINE VARIABLE SimpleArea AS LOGICAL NO-UNDO INITIAL NO.
 
  IF NOT (RunningWindows98() OR RunningWindows2000()) THEN
     SimpleArea = YES.
  ELSE DO:
     RUN MonitorFromWindow(HWND, 2, OUTPUT hMonitor).
     IF hMonitor = 0 THEN
        SimpleArea = YES.
     ELSE DO:
        SET-SIZE(lpMonitorInfo)    = 4 + 16 + 16 + 4.
        PUT-LONG(lpMonitorInfo, 1) = GET-SIZE(lpMonitorInfo).
        RUN GetMonitorInfoA(hMonitor,
                            GET-POINTER-VALUE(lpMonitorInfo),
                            OUTPUT ReturnValue).
        IF ReturnValue = 0 THEN 
           SimpleArea = YES.
        ELSE DO:
           PUT-LONG(lpRect, 1) = GET-LONG(lpMonitorInfo, 21).
           PUT-LONG(lpRect, 5) = GET-LONG(lpMonitorInfo, 25).
           PUT-LONG(lpRect, 9) = GET-LONG(lpMonitorInfo, 29).
           PUT-LONG(lpRect,13) = GET-LONG(lpMonitorInfo, 33).
        END.
        SET-SIZE(lpMonitorInfo)    = 0.
     END.
  END.
 
  IF SimpleArea THEN 
    RUN SystemParametersInfo{&A} IN hpApi
         ( 48,  /* 48 = SPI_GETWORKAREA */
           0,
           GET-POINTER-VALUE(lpRect),
           0,
           OUTPUT ReturnValue).
 
END PROCEDURE.
 
PROCEDURE MonitorFromWindow EXTERNAL "user32" :
  DEFINE INPUT  PARAMETER HWND     AS LONG.
  DEFINE INPUT  PARAMETER dwFlags  AS LONG.
  DEFINE RETURN PARAMETER hMonitor AS LONG.
END PROCEDURE.
 
PROCEDURE GetMonitorInfoA EXTERNAL "user32" :
  DEFINE INPUT PARAMETER  hMonitor      AS LONG.
  DEFINE INPUT PARAMETER  lpMonitorInfo AS LONG.
  DEFINE RETURN PARAMETER ReturnValue   AS LONG.
END PROCEDURE.

Explanation

Can probably do with less variables but I wanted a certain degree of readability.
The procedure has to rely that the input parameter is indeed of type "window". In other procedures (in winstyle.p) I used to traverse up the GetParent chain until a window with a caption was found. That would not work for a Splash screen.
Can't use 4GL attributes to find the size of a window, because winhandle:width-pixels and winhandle:height-pixels return the dimensions of the Client area. It is convenient but confusing that winhandle:x and winhandle:y are the coordinates of the NonClient area.
procedure SystemParametersInfo is highly interesting: it can return or change many many configuration settings from the 'Control Panel'. However it only returns the working area for the primary display monitor.
Functions RunningWindows98() and RunningWindows2000() are listed on page which version of Windows is running

Creating a Palette or floating toolwindow

This example uses the source in procedure winstyle.p available in WinStyle.p.

A palette, or floating toolwindow should have these three features:
* a small title bar
* no associated button on the Taskbar because it is considered a popup-window of its 'client'
* stays on top, at least relative to the window it is 'serving'

The first two features are done automatically when pushing the WS_EX_PALETTEWINDOW style. Controlling the behavior of 'stay-on-top' requires some extra work in P4GL.

Controlling the Stay-on-top behavior

When a window has the Topmost style it will always be visible in front of all other windows that don't have the Topmost style. That is practically on top of all other windows. So when you create a palette in Progress with the Topmost style and switch to a different application (say, a web browser) you will still see the palette on top of the web browser. That is more than you bargained for and can not be tolerated.
What you really want is a window that is only Topmost relative to other windows in the same application (or in the same thread or in the same process, that's all pretty similar) and it is surprising that Windows does not support that requirement. So we will have to code it ourselves.
A floating toolbar is typically invoked by and working for one particular window. The same can be assumed for a palette window although the Progress UIB shows an exception to this 'rule'. For simplicity sake I will work with the assumption there are two windows involved: the Main window and its Palette window. The goal is: if win-Main is active we must assure that win-Palette has the Topmost style, if focus moves to a different window we must assure that the Topmost style gets removed from win-Palette.
So we will use the ON ENTRY and ON LEAVE triggers of win-Main.
This approach has one documented bug: if you leave win-Main to activate a different application you get no ON LEAVE event. Oh well, the user will click the win-Palette in an impulse and thus trigger the ON LEAVE of win-Main... it's not great but better than before.
To get a reliable ON LEAVE you should have to subclass the win-Main, but that's too far from 4GL for now. If required you might try the MsgBlaster control.

Examples

There are at least three procedure files involved: winmain.w implementing win-Main as mentioned above, palette.w implementing the palette window and winstyle.p being a library of procedures where the WS_EX_PALETTEWINDOW style is applied. Let's go:

/* some fragments from winmain.w */
DEFINE VARIABLE hPalette AS HANDLE un-undo.
 
ON ENTRY OF win-Main
DO:
   RUN SetTopMost IN hPalette(YES) NO-ERROR.
END.
 
ON LEAVE OF win-Main
DO:
   RUN SetTopMost IN hPalette(NO) NO-ERROR.
END.
 
ON CHOOSE OF BUTTON-palette IN FRAME DEFAULT-FRAME /* Show Palette */
DO:
  RUN SetTopMost IN hPalette(YES) NO-ERROR.
  IF ERROR-STATUS:ERROR THEN DO:
     RUN Palette.w PERSISTENT SET hPalette.
     RUN SetTopMost IN hPalette(YES) NO-ERROR.
  END.
END.

/* some fragments from palette.w */
{windows.i}
 
/* add to Mainblock: */
  DEFINE VARIABLE hStyle AS HANDLE NO-UNDO.
  RUN WinStyle.p PERSISTENT SET hStyle.
  RUN AddPaletteStyle IN hStyle ({&window-name}:HWND).
  DELETE PROCEDURE hStyle.
 
/* add internal procedure: */
PROCEDURE SetTopMost :
/*------------------------------------------------------------------------------
  Purpose:     prevents overlapping on other applications
  Parameters:  logical TopMost : yes = switch TopMost on
                                 no  = switch TopMost off
------------------------------------------------------------------------------*/
  DEFINE INPUT PARAMETER TopMost AS LOGICAL NO-UNDO.
 
  DEFINE VARIABLE hNonClient AS INTEGER NO-UNDO.
  DEFINE VARIABLE hwndInsertAfter AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  hNonClient = GetParent({&window-name}:HWND).
  IF TopMost THEN 
     hwndInsertAfter = {&HWND_TOPMOST}.
  ELSE
     hwndInsertAfter = {&HWND_NOTOPMOST}.
 
  RUN SetWindowPos IN hpApi
    ( hNonClient,
      hwndInsertAfter,
      0,0,0,0,    /* x,y,width,height : will be ignored */
      {&SWP_NOMOVE} + {&SWP_NOSIZE} + {&SWP_NOACTIVATE},
      OUTPUT ReturnValue
    ).
END PROCEDURE.
 

Explanation

The above source is pretty straightforward, I think. The contents of procedure AddPaletteStyle is another cup of tea, let's take a look:
First, the procedure needs to determine the hwnd of the NonClient-area because that's the window that owns the title bar (or 'Caption' in ms-talk). It finds it by repeatedly calling GetParent until it finds a window with a caption.
It is very weird to set the WS_EX_PALETTEWINDOW style when the window is already realized. To make it easier for Windows we first hide the window by calling ShowWindow(hwnd,0,output RetVal), this results also in the hiding of the Taskbar button. If you would not hide the window it would get the WS_EX_PALETTEWINDOW style alright but the Taskbar would become a mess, since Windows didn't really anticipate this.
Since we used ShowWindow to hide the window you might expect that we also use ShowWindow in the end to show it again. No need, because we already needed SetWindowPos we might as well give it the extra SWP_SHOWWINDOW option.
Because the caption shrinks, the entire window must shrink or else there will be a gap between the caption and the client-area. Procedure 'FitFrame' implements api-calls for calculating the required size for the NonClient-area.

Disabling the Close button

Introduction

Author: Todd G. Nist, Protech Systems Inc.

The source code for the window as shown in the picture is attached: w-disablex.w.
When you want to disable the [X]-button in the title bar and also want to remove the 'Close'-option from the system menu, you only have to call this function from within the main block of the window:

{windows.i}
 
FUNCTION DisableWindowClose RETURNS LOGICAL
  ( /* parameter-definitions */ ) :
/*---------------------------------------
  Purpose:  
    Notes:  
-----------------------------------------*/
  DEFINE VARIABLE hSysMenu   AS  INTEGER NO-UNDO.
  DEFINE VARIABLE hParent    AS  INTEGER NO-UNDO.
  DEFINE VARIABLE hInstance  AS  INTEGER NO-UNDO.
  DEFINE VARIABLE iRetCode   AS  INTEGER NO-UNDO.
  DEFINE VARIABLE iCnt       AS  INTEGER NO-UNDO.
 
  RUN GetParent IN hpApi(INPUT {&window-name}:HWND,
                         OUTPUT hParent).
 
  /* Get handle to the window's system menu
     (Restore, Maximize, Move, close etc.) */
  RUN GetSystemMenu IN hpApi(INPUT  hParent, 
                             INPUT  0,
                             OUTPUT hSysMenu).
 
  IF hSysMenu NE 0 THEN
  DO:
    /* Get System menu's menu count */
    RUN GetMenuItemCount IN hpApi(INPUT hSysMenu,
                                  OUTPUT iCnt).
 
    IF iCnt NE 0 THEN
    DO:
      /* Menu count is based on 0 (0, 1, 2, 3...) */
 
      /* remove the "close option" */
      RUN RemoveMenu IN hpApi(INPUT hSysMenu, 
                              INPUT iCnt - 1, 
                              INPUT {&MF_BYPOSITION} + {&MF_REMOVE},
                              OUTPUT iRetCode).
 
      /* remove the seperator */
      RUN RemoveMenu IN hpApi(INPUT hSysMenu, 
                              INPUT iCnt - 2, 
                              INPUT {&MF_BYPOSITION} + {&MF_REMOVE},
                              OUTPUT iRetCode).
 
      /* Force caption bar's refresh which 
         will disable the window close ("X") button */
      RUN DrawMenuBar IN hpApi(INPUT  hParent,
                               OUTPUT iRetCode).
      {&window-name}:TITLE = "Try to close me!".
    END. /* if iCnt NE 0... */
  END. /* if hSysMenu NE 0... */  
 
  RETURN FALSE.   /* Function return value. */
 
END FUNCTION.

Notes

Because you now have restricted the user from closing the window you will have to close it yourself from within 4GL. This statement will do it:

  apply "window-close" to {&window-name}. 

There are many ways for doing things. To refresh the title bar, instead of running DrawMenuBar, you could also

 run FlashWindow in hpApi(hParent,0, output iRetCode). 

FlashWindowEx

You can use this function when you want the taskbar button to flash.

run FlashTray.
PROCEDURE FlashTray :
  DEFINE VARIABLE pfwi AS MEMPTR NO-UNDO.
  DEFINE VARIABLE hwndParent AS INTEGER NO-UNDO.
  RUN GetParent (CURRENT-WINDOW:HWND, OUTPUT hwndParent).
  SET-SIZE (pfwi)    = 20.
  PUT-LONG (pfwi, 1) = GET-SIZE(pfwi).
  PUT-LONG (pfwi, 5) = hwndParent.
  PUT-LONG (pfwi, 9) = 2.  /* = FLASW_TRAY */
  PUT-LONG (pfwi,13) = 3.  /* number of times to blink */
  PUT-LONG (pfwi,17) = 0.  /* blink rate in msec, 0=use system default */
  RUN FlashWindowEx ( pfwi ).
  SET-SIZE(pfwi)     = 0.
END PROCEDURE.
PROCEDURE GetParent EXTERNAL "user32.dll" :
  DEFINE INPUT PARAMETER  ipWindow AS LONG.
  DEFINE RETURN PARAMETER ipParent AS LONG.
END PROCEDURE.
PROCEDURE FlashWindowEx EXTERNAL "user32.dll":
  DEFINE INPUT PARAMETER ipWindow AS MEMPTR.
END PROCEDURE.

GetDeviceCaps

Procedure GetDeviceCaps allows you to find many device capabilities, like: how many colors can be displayed, can a font be scaled or rotated, is the device capable of drawing lines or circles.
The "Device" can be the display but the procedure is also important for measuring the capabilities of a printer device, because your print routine may have to use different logic for penplotters or laserprinters or matrixprinters. Of course Windows can not actually measure the device but has to rely on the the device driver written by the manufacturer of the device.
You will use this procedure often together with GetSystemMetrics (to find out the dimensions of scrollbars or other objects) and with DeviceCapabilities (for printers only, to find info about paper sizes, orientation, number of bins and more)

How many colors can be displayed on screen?

A TrueColor picture can not be displayed when the display is configured for only 16 colors. At least not nicely. Suppose you have different sets of pictures for different display settings and now you want your program to decide which ones to use. You can do this by calling GetDeviceCaps, asking for the value on the BITSPIXEL index.

  {windows.i}
  &GLOBAL-DEFINE BITSPIXEL 12
 
  DEFINE VARIABLE ncolors AS INTEGER NO-UNDO.
  DEFINE VARIABLE txt AS CHARACTER NO-UNDO.
 
  RUN GetDisplayCaps( INPUT {&BITSPIXEL}, OUTPUT ncolors). 
 
  CASE ncolors :
     WHEN  1 THEN txt = "16 colors".
     WHEN  8 THEN txt = "256 colors".
     WHEN 16 THEN txt = "High Color (16 bits per pixel)".
     WHEN 24 THEN txt = "True Color (24 bits per pixel)".
     WHEN 32 THEN txt = "True Color (32 bits per pixel)".
     OTHERWISE    txt = "an unusual color depth!".
  END CASE.
 
  MESSAGE "your display is configured for " txt
          VIEW-AS ALERT-BOX.

Procedure GetDisplayCaps is a wrapper for the GetDeviceCaps and only works for the Display device. That's because the HDC (handle to device context) is used for a window. Any window will do, because all windows are on the same screen... This procedure uses the Progress DEFAULT-WINDOW because it always exists. If you want to find capabilities of a printer, you don't use GetDC but CreateDC.

PROCEDURE GetDisplayCaps :
  /* Wrapper for GetDeviceCaps when Device=display   */
  DEFINE INPUT PARAMETER  cap-index  AS INTEGER NO-UNDO.
  DEFINE OUTPUT PARAMETER capability AS INTEGER NO-UNDO.
 
  DEFINE VARIABLE hdc AS INTEGER NO-UNDO.
  DEFINE VARIABLE OK  AS INTEGER NO-UNDO.
  RUN GetDC IN hpApi(INPUT DEFAULT-WINDOW:HWND, OUTPUT hdc).
  RUN GetDeviceCaps IN hpApi(INPUT hdc,INPUT cap-index, OUTPUT capability). 
  RUN ReleaseDC IN hpApi(INPUT DEFAULT-WINDOW:HWND, INPUT hdc, OUTPUT OK).
END PROCEDURE.

Hiding the taskbar button

or actually: window parenting

Warning:

Reparenting windows affects messaging. There is no way of knowing if this confuses the internals of the Progress runtime module. I would personally not dare to use something like this in a production environment.

One of the most Frequently Asked Questions is: "Every window has a taskbar button, how can I make those buttons invisible?"
The answer is that every unowned window or every window that does not have a parent has a taskbar button, except windows that have the 'toolwindow' style. So all you have to do is give your window a parent... easier said than done, because a parented window is normally glued to its parents client area and can't be moved away from that parent...
The solution was found by accident, it is actually a bug but is seems to work without negative side effects, as far as I can see. In fact, I see some cool side effects...
If you want window A to be parent of window B, you should normally use SetParent(B,A) but I accidently used SetWindowLong(B, -8, A). This was a silly mistake, nothing seemed to happen except the taskbar button for window B was gone!
I wonder if this is a bug or a feature. If it is a bug, it might not work in future Windows versions (mine is 95 with Service Pack 1).
By the way: I love taskbar buttons. I hate windows without taskbar buttons... but since it is a FAQ:

Example source

Suppose the project has one main window (a typical UIB-like menu tool) and this mainwin launches a couple of other windows. You only accept one taskbar button.
The main window uses this procedure to start a window:

{windows.i}
{winfunc.i}
 
ON CHOOSE OF btnLaunch IN FRAME DEFAULT-FRAME /* Start window without Taskbar button */
DO:
  DEFINE VARIABLE hp         AS HANDLE NO-UNDO.
  DEFINE VARIABLE hWindow    AS HANDLE NO-UNDO.
  DEFINE VARIABLE hOldParent AS INTEGER NO-UNDO.
 
  RUN noTaskBar.w PERSISTENT SET hp.
  RUN GetWindowHandle IN hp (OUTPUT hWindow).
 
  RUN SetWindowLongA IN hpApi (GetParent(hWindow:HWND),
                               -8,
                               GetParent({&WINDOW-NAME}:HWND), /* or DEFAULT-WINDOW:HWND */
                               OUTPUT hOldParent).
 
END.

The launched window must have an internal procedure "GetWindowHandle" that returns the Progress widget handle for the newly created window:

PROCEDURE GetWindowHandle :
 
  DEFINE OUTPUT PARAMETER hWindow AS HANDLE NO-UNDO.
 
  hWindow = {&WINDOW-NAME}:HANDLE.
 
END PROCEDURE.

Cool side effects:

As shown in the above example, you can parent the new window to

  GetParent({&WINDOW-NAME}:HWND) 

or to

  DEFAULT-WINDOW:HWND  

or to any other window. There is a strange but great bonus in the first choice:
The main window can not overlap the child windows. In a normal UIB-like application you get to see a lot of pieces of desktop and other underlying programs between your Progress windows, with the risc of activating one of them when you click one by accident.
Now you can safely maximize your main window - it hides the background but will never hide any other project windows. It has like a 'stay-on-bottom' effect.
If you minimize the mainwin, all other windows will be minimized too. If you restore the minimized mainwin, all open child windows will appear again.
If you use DEFAULT-WINDOW:HWND you have the benefit of an always available handle but the mainwin will not control the others.

Problem ON CLOSE:

When you close the parent window, all child windows seem to be closed as well (which is fine). I am not sure if Progress knows about that: if the child window procedure has an 'ON WINDOW-CLOSE' event handler it will not be called. To play safe, you should catch the 'close' in the parent procedure and notify all children.

LockWindowUpdate

If you use dynamic widgets, or if you dynamically resize or reposition widgets, you simply have to use function LockWindowUpdate especially on NT Terminal Server.
This is probably the most widely used API function, covered in every presentation and every publication. Actually that's why I didn't bother to cover LockWindowsUpdate before, but here it is at last...

PROCEDURE LockWindowUpdate EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER hWndLock AS LONG.
  DEFINE RETURN PARAMETER IsLocked AS LONG.
END PROCEDURE.

• hWndLock specify a windows handle to request a lock for that window. Specify 0 to clear the lock.
• IsLocked returns 0 if the function fails, nonzero if the function succeeds.

LockWindowUpdate temporarily disables drawing in the specified window. While a window is locked you can change the appearance of the window or the appearance and/or positions of its child windows (widgets). These changes will not be drawn until the window is unlocked. When the window is unlocked its area will be invalidated and will eventually receive a WM_PAINT message. LockWindowUpdate will improve the overall performance of a drawing operation when you need to modify several widgets.
You should not move, resize, or hide/view the locked window while it has a lock. If you do you will see the desktop or other surrounding windows flash.
Only one window at a time can be locked.
If LockWindowUpdate failed (returned IsLocked=0) it may be because an other window owns the lock. This means you should not call LockWindowUpdate(0,..) if you didn't get the lock in the first place, because you may inadvertently unlock a different window.

a demo program

Procedure LockWindowUpdate.w, which is attached, shows a window with a whole lot of widgets in it. When you press button "Move Widgets" each widget will be moved and resized a random amount of pixels. This operation is very slow and flashy if "use LockWindowUpdate" is not toggled.
The demo also shows the effect of hiding the frame during LockWindowUpdate: the window itself will behave quite nicely but all other visible windows, including the desktop will accidently be redrawn.

Attachments

lockwindowupdate.w.zip : example source

Manipulating scrollbars

Progress frames and windows show both scrollbars or none.
It would be better if the scrollbars were shown independently.
The procedure ShowScrollbarsWhenNeeded is to be called 'on end-size' or during initialize.
The procedure HideScrollbars does simply that: hide both scrollbars whether or not the virtual size is larger than the actual size. The procedure is mainly a demonstration of the {&SB_BOTH} constant.

{windows.i}
 
PROCEDURE ShowScrollbarsWhenNeeded :
/* purpose : to be called from "on end-size" or whenever. */
   DEFINE INPUT PARAMETER hFrame AS HANDLE.
 
   DEFINE VARIABLE retval AS INTEGER NO-UNDO.
   IF hFrame:VIRTUAL-WIDTH-PIXELS > hFrame:WIDTH-PIXELS THEN
      RUN ShowScrollBar IN hpApi (hFrame:HWND, 
                                  {&SB_HORZ}, 
                                   -1,
                                  OUTPUT retval).
   ELSE
      RUN ShowScrollBar IN hpApi (hFrame:HWND, 
                                  {&SB_HORZ},  
                                  0,
                                  OUTPUT retval).
 
   IF hFrame:VIRTUAL-HEIGHT-PIXELS > hFrame:HEIGHT-PIXELS THEN
      RUN ShowScrollBar IN hpApi (hFrame:HWND, 
                                  {&SB_VERT}, 
                                  -1,
                                  OUTPUT retval).
   ELSE
      RUN ShowScrollBar IN hpApi (hFrame:HWND, 
                                  {&SB_VERT},  
                                  0,
                                  OUTPUT retval).
 
END PROCEDURE.
 
 
PROCEDURE HideScrollbars :
/* purpose : hide both scrollbars */
   DEFINE INPUT PARAMETER hFrame AS HANDLE.
 
   DEFINE VARIABLE retval AS INTEGER NO-UNDO.
   RUN ScrollUpperLeft(hFrame).
   RUN ShowScrollBar IN hpApi (hFrame:HWND, 
                               {&SB_BOTH},
                               0,
                               OUTPUT retval).
 
END PROCEDURE.
 
PROCEDURE ScrollUpperLeft :
/* purpose : move both scrollbars to their 0% position */
   DEFINE INPUT PARAMETER hFrame AS HANDLE.
 
   DEFINE VARIABLE wParam AS INTEGER NO-UNDO.
   DEFINE VARIABLE nPos AS INTEGER   NO-UNDO.
   DEFINE VARIABLE RetVal AS INTEGER NO-UNDO.
   nPos = 0.                       
   wParam = (nPos * 256) + {&SB_THUMBPOSITION}.
   RUN SendMessage{&A} IN hpApi (hFrame:HWND, {&WM_HSCROLL}, wParam, 0, OUTPUT RetVal).
   RUN SendMessage{&A} IN hpApi (hFrame:HWND, {&WM_VSCROLL}, wParam, 0, OUTPUT RetVal).
 
END PROCEDURE.

Explanation:

In procedure ScrollUpperleft, wParam has SB_THUMBPOSITION in its low byte to let windows know that you want to do something with the thumb position. The wanted position (nPos=0) is placed in the high byte by multiplying it by 256.
Frankly I only tried the value nPos=0 so I might as well have assigned
wParam = {&SB_THUMBPOSITION}.
For any other value for nPos you should test if the factor '256' is adequate for both 16-bits and 32-bits versions! (I guess not).

Easier ways to scroll

{windows.i}
DEFINE VARIABLE RetVal AS INTEGER NO-UNDO.
 
&GLOBAL-DEFINE SB_PAGEUP 2
&GLOBAL-DEFINE SB_PAGEDOWN 3
&GLOBAL-DEFINE SB_TOP 6
 
PROCEDURE ScrollUpperLeft :
/* purpose : move both scrollbars to their 0% position */
   DEFINE INPUT PARAMETER hFrame AS HANDLE.
 
   RUN SendMessage{&A} IN hpApi (hFrame:HWND, {&WM_HSCROLL}, {&SB_TOP}, 0, OUTPUT RetVal).
   RUN SendMessage{&A} IN hpApi (hFrame:HWND, {&WM_VSCROLL}, {&SB_TOP}, 0, OUTPUT RetVal).
 
END PROCEDURE.
 
PROCEDURE PageDown :
   DEFINE INPUT PARAMETER hFrame AS HANDLE.
 
   RUN SendMessage{&A} IN hpApi (hFrame:HWND, {&WM_VSCROLL}, {&SB_PAGEDOWN}, 0, OUTPUT RetVal).
 
END PROCEDURE.
 
PROCEDURE PageUp :
   DEFINE INPUT PARAMETER hFrame AS HANDLE.
 
   RUN SendMessage{&A} IN hpApi (hFrame:HWND, {&WM_VSCROLL}, {&SB_PAGEUP}, 0, OUTPUT RetVal).
 
END PROCEDURE.

Maximize, minimize a window

Ever tried to maximize a Progress window, with respect to the size and position of the Windows Taskbar? It is easy if you know about this not-well-documented feature (in 8.2A and up):

ASSIGN
   {&WINDOW-NAME}:MAX-HEIGHT   = ?
   {&WINDOW-NAME}:MAX-WIDTH    = ?
   {&WINDOW-NAME}:WINDOW-STATE = WINDOW-MAXIMIZED.

The fun part is assigning the unknown value to max-height/width. This results in dynamic resizing even when the user moves the Taskbar or changes the display resolution!

Minimize and Restore

To restore a Window to its original state, use the following code:

ASSIGN {&WINDOW-NAME}:WINDOW-STATE = WINDOW-NORMAL.

To minimize a Window, use the following code:

ASSIGN {&WINDOW-NAME}:WINDOW-STATE = WINDOW-MINIMIZED.

Minimizing a window to the System Tray

by Rob den Boer

The attached example procedure creates a Progress window. When the window is minimized, it shows an icon in the system tray (that's in the corner of the taskbar, next to the clock). Features of this tray icon are:
* on left mouse click, the window is restored
* on right mouse click a popup-menu appears (as shown on picture)
* the icon has a tooltip
* the icon can be animated

Installing the example

Download systray.zip (12 kilobyte) and unzip it to a directory in your PROPATH.
The example was created using the AppBuilder in Progress 9, it will have to be rewritten to run in Progress 8. The example uses the PSTimer ActiveX control and also the MsgBlaster control.

How it works

Run procedure ip-systray-init when the window gets initialized.

This procedure takes three input parameters: a unique ID for the icon, a comma-separated list of .ico filenames and a tooltip string.

Procedure ip-systray-init shows the icon and sets the MsgBlaster OCX to pass mouse-messages from the icon on to the Progress procedure. The event-handler for the MsgBlaster contains the code for showing the popup-menu (on mouse-menu-click) or for restoring the window (on mouse-select-click).
The icon can be animated only by using a PSTimer control: on pstimer.tick simply run ip-next-icon. This procedure fetches the next name from a comma-separated list of .ico filenames and updates the taskbar icon. You may refine this procedure by using an Imagelist control.
Don't forget to call procedure ip-systray-exit when the program ends.

API-procedures used in this example are listed here to be included in the search index: 
PROCEDURE SHGetFileInfoA    EXTERNAL "shell32"
PROCEDURE Shell_NotifyIconA EXTERNAL "shell32"
PROCEDURE SendMessageA      EXTERNAL "user32"

More Progress examples available on the homepage of Rob den Boer: http:home.hccnet.nl/rc.den.boer/progress/index.html

Attachments

systray.zip : (by Rob den Boer, improved by Peter Kiss)

Painting in Progress frames

Sometimes you may want to do some extra painting on a Progress frame or window, for example some circles, dotted lines, dashed area's or just lines that are not horizontal or vertical. Or how about right-aligned text?
The actual drawing can be done with GDI functions, but the result will be erased whenever Progress repaints the frame (or window). This topic is about preventing that.
Let's start with a simple example: drawing an ellipse on a Progress frame.
create a Progress window (doesn't have to be Smart) and place a button on it. On choose of this button: run Paint.

 
PROCEDURE PAINT :
/*----------------------------------------------------
  Purpose:     do some custom painting, in this case:
               draw a circle as large as the window
------------------------------------------------------ */
  DEFINE VARIABLE hdc AS INTEGER NO-UNDO.
  DEFINE VARIABLE Okay AS INTEGER NO-UNDO.
 
  RUN GetDC IN hpApi (INPUT FRAME {&frame-name}:HWND, 
                      OUTPUT hdc).
 
  RUN Ellipse IN hpApi (hdc, 
                        0,
                        0, 
                        FRAME {&frame-name}:WIDTH-PIXELS, 
                        FRAME {&frame-name}:HEIGHT-PIXELS,
                        OUTPUT Okay ).
 
  RUN ReleaseDC IN hpApi (INPUT FRAME {&frame-name}:HWND, 
                          INPUT hdc, 
                          OUTPUT Okay).
 
END PROCEDURE.

Now when you run the window and press the button you will see a large ellipse. When you drag any other window over the surface of your window, you will see that overlapped regions of the ellipse will be erased. To repaint the ellipse you can just press the button again, but you want a way to do this automatically.

When should you repaint your drawings?

A (region of a) window will be painted again when it has been overlapped by another window, or whenever the (region of the) window has become invalidated. MS-Windows sends a series of messages to the window when it is invalidated and Progress responds to it by painting the region again. Among those messages are WM_ERASEBKGND and WM_PAINT.
I have always believed that WM_PAINT was the proper message to wait for, but there are occasions when you see that progress repaints the window without ever having trapped a WM_PAINT message. Result: your custom drawing is erased.
Matt Gilarde at PSC Development explains what's going on:
Progress doesn't repaint a frame when it gets a WM_PAINT message; we do it when we get a WM_ERASEBKGND. Why? I believe the idea was to avoid flashing during repaints. Instead of wiping out the background in the WM_ERASEBKGND and then repainting widgets in the WM_PAINT, Progress does all the painting during WM_ERASEBKGND. Painting a frame consists of the following steps:
* Fill the frame with the background color
* Draw the grid if it is on
* Paint rectangles and images
* Paint all other widgets
* Highlight selected widgets
Since the painting is handled in WM_ERASEBKGND, the WM_PAINT message is not always generated (Windows removes the WM_PAINT from the message queue if there is no invalid region to be painted). So you may have better luck trapping WM_ERASEBKGND. Or you may run into other problems.
So you will have to set up your MessageBlaster to trap WM_ERASEBKGND instead WM_PAINT.

Let's do it:

Drop a MessageBlaster ActiveX control on your window and set it up as follows:

PROCEDURE CtrlFrame.Msgblst32.MESSAGE .
 
DEFINE INPUT        PARAMETER p-MsgVal    AS INTEGER NO-UNDO.
DEFINE INPUT        PARAMETER p-wParam    AS INTEGER NO-UNDO.
DEFINE INPUT        PARAMETER p-lParam    AS INTEGER NO-UNDO.
DEFINE INPUT-OUTPUT PARAMETER p-lplRetVal AS INTEGER NO-UNDO.
 
CASE p-MsgVal :
  WHEN 20 /* = WM_ERASEBKGND */ THEN RUN paint.
END CASE.
 
END PROCEDURE.
 
 
PROCEDURE initialize-controls :
/*------------------------------------------------------------------------------
  Purpose:     listen for WM_ERASEBKGND messages
------------------------------------------------------------------------------*/
  chCtrlFrame:Msgblst32:MsgList(0)    = 20.    /* = WM_ERASEBKGND */
  chCtrlFrame:Msgblst32:MsgPassage(0) = -1.    /* = let PSC handle the message first */
  chCtrlFrame:Msgblst32:hWndTarget    = FRAME {&frame-name}:HWND.
 
END PROCEDURE.

How to force a repaint?

If you want Progress to repaint the entire frame (or window), for example to erase your custom painting, you can not just send it a WM_ERASEBKGND message. Here's another excellent explanation from Matt Gilarde:
Sending WM_ERASEBKGND won't cause any repainting to be done since it requires the wParam to be the handle to a device context for the area which is to be repainted. To force a repaint, you need to invalidate all or part of the window or frame. Windows will then generate the proper WM_ERASEBKGND and WM_PAINT messages. You can use the InvalidateRect() API to invalidate a window.

BOOL InvalidateRect(HWND hWnd, RECT *lpRect, BOOL bErase); 

Calling InvalidateRect(hWnd, 0, 1) will force the entire window to repaint. You can call UpdateWindow(hWnd) to force the repaint to occur immediately (otherwise the paint messages will sit in the message queue until Progress gets around to looking for them). The result may not be what you want, however, since there may be lots of flashing when you force the repaint.

Removing min/max buttons from the title bar

This example uses the source in procedure winstyle.p, available on page WinStyle.
A normal window can be maximized to full-screen but a Progress window doesn't grow much unless you specifically set virtual sizes. Maximizing (or resizing at all) isn't very useful for a window that has a fixed amount of widgets, so you might prefer to hide the Maximize button. And while we are at it let's also hide the Minimize button.
Here's how you do it:
Create a Progress window and place this code fragment somewhere in the source:

  ASSIGN {&window-name} :MIN-BUTTON = NO
         {&window-name} :MAX-BUTTON = NO.

Explanation

Let's take a look at the source in winstyle.p.

The title bar is on the NonClient-area of the window, but the input parameter {&window-name}:hWnd is the Client-area. So the first task is to find the hWnd of the NonClient-area, this is simply done by repeatedly calling GetParent until a window is found that owns a caption. This method allows that the input parameter can be any widget:hWnd.

Now the style flags are fetched from the already existing NonClient-window, some style bits are set to zero and the new style is pushed back into the window. The min/max buttons are now invalid so I figured it's reasonable to make resizing of the window impossible.
The standard frame of type WS_THICKFRAME is sensitive for the mouse; users can drag the frame to resize it, so I also deleted the WS_THICKFRAME style. This means you now get a frame that is slightly less thick. Because of that you get to see a narrow transparent area between the new thin frame and the Client-area. This must be solved by shrinking the NonClient window until it tightly fits around the Client window.
The api function AdjustWindowRect is designed to calculate the required size of a window, given a certain size for the Client-area. So that's what we call. The size of the client-area is found by calling GetClientRect.

The new dimensions for the NonClient window are assigned by the SetWindowPos function.

We're done!

The menu-items in the system-menu for 'Size', 'Minimize' and 'Maximize' are automatically disabled as a result of the new window style. Disabled menu-items imply they may become enabled, so I decided to delete them.

Splash window

Splash is the name for a window that is shown during startup of an application. It masks a long loading time (for example during establishing connections to remote databases) and is often used to show the application title, 'licensed to'-info, author name and often a nice picture.

A Splash has no user interaction; a user must simply wait until the show begins. Therefore a Splash should not have a title bar and especially no 'close' button. It's common to display the Splash in the exact center of the screen and it also usually 'stays-on-top'.

Most people use third-party 3GL languages to create a Splash screen because it seems impossible to create one in Progress. The downside of using an external program is that it's hard to determine the proper time to close. This would be lots easier if the Splash was created in Progress and then it would also be possible to give status information (like "now connecting to system.db").

The next procedure accepts the hWnd of a Progress window (not a Frame or Dialog!) and makes it look like a Splash by removing the title bar and the thick frame, centering it to the screen and making it topmost.

/* ===================================================================
   file     : MkSplash.p
   by       : Jurjen Dijkstra, 1997
   language : Progress 8.2A on Windows 95
   purpose  : changes the appearance of a normal Progress window
              into a Splash window, e.g. no caption, no border, 
              centered to screen, stay-on-top.
   params   : hClient    = HWND of a client window
              ThinBorder = YES if a WS_BORDER style is wanted
                           NO creates no border at all
   usage    : during mainblock:
              run MkSplash.p ({&WINDOW-NAME}:HWND, YES).
   =================================================================== */
 
DEFINE INPUT PARAMETER hClient AS INTEGER.
DEFINE INPUT PARAMETER ThinBorder AS LOGICAL.
 
  {windows.i}
  {ProExtra.i}
 
  DEFINE VARIABLE hNonclient AS INTEGER NO-UNDO.
  DEFINE VARIABLE style AS INTEGER NO-UNDO.
  DEFINE VARIABLE oldstyle AS INTEGER NO-UNDO.
 
  hNonclient = GetParent(hClient).
 
  /* delete the caption and the thickframe */
  RUN GetWindowLong{&A} IN hpApi(hNonclient, {&GWL_STYLE}, OUTPUT style).
  RUN Bit_Remove IN hpExtra(INPUT-OUTPUT style, {&WS_CAPTION}).
  RUN Bit_Remove IN hpExtra(INPUT-OUTPUT style, {&WS_THICKFRAME}).
  RUN SetWindowLong{&A} IN hpApi(hNonclient, {&GWL_STYLE}, style, OUTPUT oldstyle).
 
  /* the next block creates a thin border around the window. 
     This has to be done in a second SetWindowLong */
  IF ThinBorder THEN DO:
    RUN GetWindowLong{&A} IN hpApi(hNonclient, {&GWL_STYLE}, OUTPUT style).
    RUN Bit_Or IN hpExtra(INPUT-OUTPUT style, {&WS_BORDER}).
    RUN SetWindowLong{&A} IN hpApi(hNonclient, {&GWL_STYLE}, style, OUTPUT oldstyle).
  END.
 
  /* The above changes in window styles are usually done before the window is
     created. Now we are actually too late, windows will not respond with an 
     automatic redraw of the window. We will have to force it. This is done by
     calling SetWindowPos with the SWP_FRAMECHANGED flag. 
     Since we are calling SetWindowPos we might as well ask it to perform 
     some other actions, like:
       make this a TOPMOST window,
       change the coordinates (centered to screen)
  */
 
  DEFINE VARIABLE lpRect AS MEMPTR NO-UNDO.
  DEFINE VARIABLE WIDTH AS INTEGER NO-UNDO.
  DEFINE VARIABLE HEIGHT AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  /* the lpRect structure is defined as LEFT,TOP,RIGHT,BOTTOM. */
  SET-SIZE(lpRect) = 4 * {&INTSIZE}.
 
  /* get the dimensions of the client area: */
  RUN GetWindowRect IN hpApi(hClient, 
                             GET-POINTER-VALUE(lpRect), 
                             OUTPUT ReturnValue).
 
  /* let Windows calculate how large the NonClient area must be
     to fit exactly around the Client area: */
  RUN AdjustWindowRect IN hpApi(GET-POINTER-VALUE(lpRect), style, 0, OUTPUT ReturnValue).
 
  /* so these will be the new dimensions of the Nonclient area: */
  WIDTH  =   get-{&INT}(lpRect, 1 + 2 * {&INTSIZE}) 
           - get-{&INT}(lpRect, 1 + 0 * {&INTSIZE}). 
  HEIGHT =   get-{&INT}(lpRect, 1 + 3 * {&INTSIZE}) 
           - get-{&INT}(lpRect, 1 + 1 * {&INTSIZE}). 
 
  SET-SIZE(lpRect) = 0.
 
  /* Do it. SWP_FRAMECHANGED is the most important flag here */
  RUN SetWindowPos IN hpApi
      (hNonclient, 
       -1, /* = HWND_TOPMOST */
       INTEGER((SESSION:WIDTH-PIXELS - WIDTH) / 2), 
       INTEGER((SESSION:HEIGHT-PIXELS - HEIGHT) / 2), 
       WIDTH, 
       HEIGHT, 
       {&SWP_NOACTIVATE} + {&SWP_FRAMECHANGED},
       OUTPUT ReturnValue
      ).
 
RETURN.
 

Notes:

The call to AdjustWindowRect assumes the window has no menu.
When centering the window I should have taken the visibility, position and size of Taskbar(s) into account. That would not have been too hard, see center a window to the working area

Parameter ThinBorder=NO causes the window to have no border at all. This looks nice if the Splash window is 100% covered with a picture that has its own edges.

Example

Zane Appel created an example Splash window, based on the mksplash.p procedure. This splash window will disappear after 5 seconds or when the user clicks anywhere on the splash window. The example is attached, see splashdm.zip

Attachments

splashdm.zip : demo by Zane Appel, based on mkspash.p

Tranparent window

In Windows 2000 you can make transparent windows, by using function SetLayeredWindowAttributes. The attached Progress procedure demonstrates this.

Attachments

transparent.w.zip : demo SetLayeredWindowAttributes

MsgBlaster

The MsgBlaster or MessageBlaster is a freeware ActiveX control that helps you catch every Windows message. This control is used in several examples in this Win32 zone, see topic context-help for a practical example.

You can download the MsgBlaster from: http:extra.newsguy.com/~bridge/mbocx32b.zip

ProExtra.dll

ProExtra.dll is a small Delphi utility I wrote to call some low-level stuff that would otherwise be hard to do from within 4GL.

proextra.dll and its Delphi source are included in "everything.zip" which is available for download on page windows.i and hpApi.

Winconst tool (search Windows Constants)

The Win32 API contains many constants.
winconst.zip contains a list of more than 14000 P4GL preprocessor definitions and a utility that helps to find dependencies.
For example, the constant WVR_REDRAW is defined as (WVR_HREDRAW | WVR_VREDRAW).

When you search for WVR_REDRAW in winconst.exe it will return

&GLOBAL-DEFINE WVR_VREDRAW 512
&GLOBAL-DEFINE WVR_HREDRAW 256
&GLOBAL-DEFINE WVR_REDRAW  ({&WVR_HREDRAW} + {&WVR_VREDRAW})

winconst.zip is freeware. So feel free to download it :-)
You have to be careful when you combine constants. In 3GL programming environments you would use the OR operator to combine constants, but in Progress we only have + to work with. This can make a difference. Also, we have no unsigned long integer. As a result, some values are converted to negative signed integers. Using these values together with the + operator instead of OR may give unexpected results.

----
Jeff Pilant writes on 11 Januari 2002:

I just saw a post on peg@peg.com about this site: http:www.other-coast.com/

It pointed out how to grab constants directly from the com object file.

The page http:home.attbi.com/~marc.lafleur/Articles/ExtractingNamedConstants.html talks about a microsoft provided program to do this.

http:www.microsoft.com/com/resources/OVI386.EXE and his own program to convert this to 4GL

http:home.attbi.com/~marc.lafleur/External/typedef.zip along with samples for a number of MS products in http:home.attbi.com/~marc.lafleur/Articles/OfficeIncludes.html

Changelog for winconst.i :

26 Nov 2002: many constants for MS-Access added by Jeff Pilant

Attachments

download winconst

windows.i and hpApi

Introduction

Throughout the site you will see references to windows.i and the handle hpApi.
hpApi is defined in windows.i and is a procedure-handle to windows.p.
windows.p contains a bunch of API procedures.

You can get a copy of windows.i and windows.p: they are in "everything.zip" which also contains some more API-related sources .

Attachments

everything.zip : contains windows.i and windows.p, and more :-)

WinStyle.p

You can find procedure winstyle.p in everything.zip, available on page windows.i and hpApi

a MAPI approach with one attachment

This solution is made by Johann van der Merwe.
It allows one attachment.

{windows.i}
 
RUN mapi ( "you@work.com",
           "yourwife@home.com",
           "late for dinner",
           "something came up..",
           "c:\images\flowers.bmp"
          ).
 
 
/* ========================================================================== */
 
PROCEDURE MAPI :
 
DEFINE INPUT PARAMETER OriginName   AS CHARACTER.
DEFINE INPUT PARAMETER RecipName    AS CHARACTER.
DEFINE INPUT PARAMETER Subject      AS CHARACTER.
DEFINE INPUT PARAMETER Bodytext     AS CHARACTER.
DEFINE INPUT PARAMETER FilePathName AS CHARACTER.
 
 
DEFINE VARIABLE SubjPtr AS MEMPTR.
SET-SIZE(SubjPtr) = LENGTH(Subject) + 1. /* maximum = 255 */ 
PUT-STRING(SubjPtr,1) = Subject.
DEFINE VARIABLE TextPtr AS MEMPTR.
SET-SIZE(TextPtr) = 16000. 
PUT-STRING(TextPtr,1) = Bodytext + (IF FilePathName = "":U 
                                    THEN "":U 
                                    ELSE CHR(10) + CHR(10) + " ":U).   
/* if file attached place at end of Bodytext with line skip */
 
/* ---------------- Build Originator details ------------------------ */
DEFINE VARIABLE OriginNamePtr AS MEMPTR.
SET-SIZE(OriginNamePtr) = LENGTH(OriginName) + 1.  /* maximum = 255 */
PUT-STRING(OriginNamePtr,1) = OriginName.  /* Originator name */
 
DEFINE VARIABLE OriginDescPtr AS MEMPTR.
SET-SIZE(OriginDescPtr) = 24.
PUT-LONG(OriginDescPtr,1) = 0. /* Reserved */ 
PUT-LONG(OriginDescPtr,5) = 0. /* RecipClass 0 = MAPI_ORIG */ 
PUT-LONG(OriginDescPtr,9) = GET-POINTER-VALUE(OriginNamePtr).  /* Name */
PUT-LONG(OriginDescPtr,13) = 0. /* Address */ 
PUT-LONG(OriginDescPtr,17) = 0. /* EID Size */ 
PUT-LONG(OriginDescPtr,21) = 0. /* Entry ID */
 
/* ----------------Build Recipient details -------------------------- */
DEFINE VARIABLE RecipNamePtr AS MEMPTR.
SET-SIZE(RecipNamePtr) = LENGTH(RecipName) + 1./* maximum = 255 */ 
PUT-STRING(RecipNamePtr,1) = RecipName. /* Recipient name */
DEFINE VARIABLE RecipDescPtr AS MEMPTR.
SET-SIZE(RecipDescPtr) = 24.
PUT-LONG(RecipDescPtr,1) = 0. /* Reserved */ 
PUT-LONG(RecipDescPtr,5) = 1. /* RecipClass 1 = MAPI_TO */ 
PUT-LONG(RecipDescPtr,9) = GET-POINTER-VALUE(RecipNamePtr).  /* Name */
PUT-LONG(RecipDescPtr,13) = 0. /* Address */ 
PUT-LONG(RecipDescPtr,17) = 0. /* EID Size */ 
PUT-LONG(RecipDescPtr,21) = 0. /* Entry ID */
 
/* --------------- Build File Details ------------------- */
IF FilePathName <> "":U THEN DO:
   DEFINE VARIABLE FilePathNamePtr AS MEMPTR.
   SET-SIZE(FilePathNamePtr) = LENGTH(FilePathName) + 1.  /* maximum = 255 */
   PUT-STRING(FilePathNamePtr,1) = FilePathName.  /* File pathname */
 
   DEFINE VARIABLE FILENAME AS CHARACTER NO-UNDO.
   FILENAME = SUBSTRING(FilePathName,R-INDEX(FilePathName,"\":U) + 1).
   /* extract filename (starting on last \) from filefullname */
   FILENAME = "     ":U + FILENAME.
   /* for some strange reason the first five chars disappear */
 
   DEFINE VARIABLE FileNamePtr AS MEMPTR.
   SET-SIZE(FileNamePtr) = LENGTH(FILENAME) + 1. /* maximum = 255 */ 
   PUT-STRING(FileNamePtr,1) = FILENAME. /* File name */
 
   DEFINE VARIABLE FileDescPtr AS MEMPTR.
   SET-SIZE(FileDescPtr) = 24.
   PUT-LONG(FileDescPtr,1) = 0. /* Reserved */ 
   PUT-LONG(FileDescPtr,5) = 0. /* Flags 0 = data file */
   PUT-LONG(FileDescPtr,9) = LENGTH(Bodytext) + 2.  /* Position */
   PUT-LONG(FileDescPtr,13) = GET-POINTER-VALUE(FilePathNamePtr).  /* PathName */
   PUT-LONG(FileDescPtr,17) = GET-POINTER-VALUE(FileNamePtr). /* FileName */ 
   PUT-LONG(FileDescPtr,21) = 0. /* FileType */
END.
 
 
 
/* ---------- Build Message Details ------------------- */
DEFINE VARIABLE MessageDescPtr AS MEMPTR.
SET-SIZE(MessageDescPtr) = 48.
PUT-LONG(MessageDescPtr,1) = 0.  /* Reserved */
PUT-LONG(MessageDescPtr,5) = GET-POINTER-VALUE(SubjPtr).  /* Subject */
PUT-LONG(MessageDescPtr,9) = GET-POINTER-VALUE(TextPtr).  /* Text */
PUT-LONG(MessageDescPtr,13) = 0. /* MessageType */ 
PUT-LONG(MessageDescPtr,17) = 0. /* DateReceived */ 
PUT-LONG(MessageDescPtr,21) = 0. /* ConversationID */ 
PUT-LONG(MessageDescPtr,25) = 1.  /* Flags */
PUT-LONG(MessageDescPtr,29) = GET-POINTER-VALUE(OriginDescPtr).  /* Originator */
PUT-LONG(MessageDescPtr,33) = 1.  /* RecipCount */
PUT-LONG(MessageDescPtr,37) = GET-POINTER-VALUE(RecipDescPtr).  /* Recips */
PUT-LONG(MessageDescPtr,41) = (IF FilePathName = "":U 
                                  THEN 0 
                                  ELSE 1).  /* FileCount */
PUT-LONG(MessageDescPtr,45) = (IF FilePathName = "":U 
                                  THEN 0 
                                  ELSE GET-POINTER-VALUE(FileDescPtr)).                             /* Files */
/* EO Build Message Details */
 
 
/* -------- Send Message ------------ */
DEFINE VARIABLE ResultInt AS INTEGER NO-UNDO.
RUN MAPISendMail IN hpApi
 (INPUT 0,
  INPUT 0,
  INPUT GET-POINTER-VALUE(MessageDescPtr),
  INPUT 11, /* 1 = MAPI_LOGON_UI + 2 = MAPI_NEW_SESSION + 8 = MAPI_DIALOG */
  INPUT 0,     
  OUTPUT ResultInt). 
 
RUN MapiReturnCode (ResultInt).
 
/* ------- Free memory ------------ */
SET-SIZE(SubjPtr)         = 0.
SET-SIZE(TextPtr)         = 0. 
SET-SIZE(OriginNamePtr)   = 0.
SET-SIZE(OriginDescPtr)   = 0.
SET-SIZE(RecipNamePtr)    = 0.
SET-SIZE(RecipDescPtr)    = 0.
SET-SIZE(FilePathNamePtr) = 0.
SET-SIZE(FileNamePtr)     = 0.
 
END PROCEDURE.

= A Simple MAPI Approach, Multiple Attachments and Recipients

=
This solution is by Ian Richards. A COM solution is easier, but this allows me to send automated e-mails from a server where Outlook is not installed. The recipients and attachments are presented as comma separated lists.

{windows.i}
 
RUN mapimulti( 
  INPUT "you@originator.com",
  INPUT "recipient1@address1.com,recipient2@address2.com",
  INPUT "Message Title",
  INPUT "Message Text",
  INPUT "C:\file1.txt,C:\file2.txt").
/* ========================================================================== */
PROCEDURE mapimulti:
{windows.i}
DEFINE INPUT PARAMETER ipOrigName     AS CHARACTER NO-UNDO.                 /* Originator Name */
DEFINE INPUT PARAMETER ipRecipName    AS CHARACTER NO-UNDO.                 /* Recipient(s) names, comma separated */
DEFINE INPUT PARAMETER ipSubject      AS CHARACTER NO-UNDO.
DEFINE INPUT PARAMETER ipBodytext     AS CHARACTER NO-UNDO.
DEFINE INPUT PARAMETER ipFilePathName AS CHARACTER NO-UNDO.                 /* Attachment(s) names, comma separated */ 
DEFINE VARIABLE intRecips AS INTEGER NO-UNDO.                               /* Count Recipients */
DEFINE VARIABLE intAttachs AS INTEGER NO-UNDO.                              /* Count Attachments */
DEFINE VARIABLE RecipName AS CHARACTER EXTENT 20 NO-UNDO.                   /* Recipient Array */
DEFINE VARIABLE FilePathName AS CHARACTER EXTENT 20 NO-UNDO.                /* Attachment Array */ 
/* Memptr Definitions */
DEFINE VARIABLE SubjPtr AS MEMPTR NO-UNDO.                                  /* Message Subject */
DEFINE VARIABLE TextPtr AS MEMPTR NO-UNDO.                                  /* Message Text */
DEFINE VARIABLE OriginNamePtr AS MEMPTR.                                    /* Originator Name */
DEFINE VARIABLE RecipNamePtr AS MEMPTR EXTENT 20 NO-UNDO.                   /* Array of pointers to Recipient Name */
DEFINE VARIABLE RecipDescPtr AS MEMPTR EXTENT 20 NO-UNDO.                   /* Array of pointers to Recipient Description */
DEFINE VARIABLE FilePathNamePtr AS MEMPTR EXTENT 20 NO-UNDO.                /* Array of pointers to Attachment Path */
DEFINE VARIABLE FileNam AS CHARACTER EXTENT 20 NO-UNDO.                     /* Array of Attachment Name */
DEFINE VARIABLE FileNamPtr AS MEMPTR EXTENT 20 NO-UNDO.                     /* Array of pointers to Attachment Name */
DEFINE VARIABLE FileDescPtr AS MEMPTR EXTENT 20 NO-UNDO.                    /* Array of pointers to Attachment Description */ 
DEFINE VARIABLE MessageDescPtr AS MEMPTR NO-UNDO.                           /* Pointer To Message Structure */
DEFINE VARIABLE FileArrayPtr AS MEMPTR NO-UNDO.                             /* Pointer to Array of File Decription */
DEFINE VARIABLE RecipArrayPtr AS MEMPTR NO-UNDO.                            /* Pointer to Array of Recipient */
DEFINE VARIABLE zz AS INTEGER NO-UNDO.                                      /* General Purpose Integer */
/* --- POPULATE RECIPIENT & ATTACHMENT ARRAYS -------*/
RUN recips.     /* Populate RecipName */
RUN attachs.    /* Populate FilePath Name */
                                                                                
/* --- SET MESSAGE TEXT AND SUBJECT -----------------*/
SET-SIZE(SubjPtr) = LENGTH(ipSubject) + 1.                                  /* maximum = 255 */ 
PUT-STRING(SubjPtr,1) = ipSubject.
SET-SIZE(TextPtr) = 16000. 
PUT-STRING(TextPtr,1) = ipBodytext. 
/* --- BUILD ORIGINATOR DETAILS ---------------------*/
SET-SIZE(OriginNamePtr) = LENGTH(ipOrigName) + 1.                           /* maximum = 255 */
PUT-STRING(OriginNamePtr,1) = ipOrigName.                                   /* Originator name */
 
DEFINE VARIABLE OriginDescPtr AS MEMPTR.
SET-SIZE(OriginDescPtr) = 24.
PUT-LONG(OriginDescPtr,1) = 0.                                              /* Reserved */ 
PUT-LONG(OriginDescPtr,5) = 0.                                              /* RecipClass 0 = MAPI_ORIG */ 
PUT-LONG(OriginDescPtr,9) = GET-POINTER-VALUE(OriginNamePtr).               /* Name */
PUT-LONG(OriginDescPtr,13) = 0.                                             /* Address */ 
PUT-LONG(OriginDescPtr,17) = 0.                                             /* EID Size */ 
PUT-LONG(OriginDescPtr,21) = 0.                                             /* Entry ID */
/* ---------- BUILD RECIPIENT DETAILS -------------- */
DO zz = 1 TO intRecips :
    SET-SIZE(RecipNamePtr[zz]) = LENGTH(RecipName[zz]) + 1.                 /* maximum = 255 */ 
    PUT-STRING(RecipNamePtr[zz],1) = RecipName[zz].                         /* Recipient name */
    SET-SIZE(RecipDescPtr[zz]) = 24.
    PUT-LONG(RecipDescPtr[zz],1) = 0.                                       /* Reserved */ 
    PUT-LONG(RecipDescPtr[zz],5) = 1.                                       /* RecipClass 1 = MAPI_TO */ 
    PUT-LONG(RecipDescPtr[zz],9) = GET-POINTER-VALUE(RecipNamePtr[zz]).     /* Name */
    PUT-LONG(RecipDescPtr[zz],13) = 0.                                      /* Address */ 
    PUT-LONG(RecipDescPtr[zz],17) = 0.                                      /* EID Size */ 
    PUT-LONG(RecipDescPtr[zz],21) = 0.                                      /* Entry ID */
END.
/* Populate Memory Indicated By RecipArrayPtr */
SET-SIZE(RecipArrayPtr) = 24 * intRecips.
DO zz = 1 TO intRecips :
    PUT-BYTES(RecipArrayPtr, (zz * 24) - 23)  = GET-BYTES(RecipDescPtr[zz],1,24).
END.
/* ---------- BUILD FILE DETAILS ------------------- */
/* Build File Description Array */
DO zz = 1 TO intAttachs:
    
    SET-SIZE(FilePathNamePtr[zz]) = LENGTH(FilePathName[zz]) + 1.           /* maximum = 255 */
    PUT-STRING(FilePathNamePtr[zz],1) = FilePathName[zz].                   /* File pathname */
 
    FileNam[zz] = SUBSTRING(FilePathName[zz],R-INDEX(FilePathName[zz],"\":U) + 1).
 
    SET-SIZE(FileNamPtr[zz]) = LENGTH(FileNam[zz]) + 1.                     /* maximum = 255 */ 
    PUT-STRING(FileNamPtr[zz],1) = FileNam[zz].                             /* File name */
 
    SET-SIZE(FileDescPtr[zz]) = 24.
    PUT-LONG(FileDescPtr[zz],1) = 0.                                        /* Reserved */ 
    PUT-LONG(FileDescPtr[zz],5) = 0.                                        /* Flags 0 = data file */
    PUT-LONG(FileDescPtr[zz],9) = -1.                                       /* Position */
    PUT-LONG(FileDescPtr[zz],13) = GET-POINTER-VALUE(FilePathNamePtr[zz]).  /* PathName */
    PUT-LONG(FileDescPtr[zz],17) = GET-POINTER-VALUE(FileNamPtr[zz]).       /* File Name */ 
    PUT-LONG(FileDescPtr[zz],21) = 0.                                       /* FileType */
END.
/* Populate Memory Indicated By FileArrayPtr */
SET-SIZE(FileArrayPtr) = 24 * intAttachs.
DO zz = 1 TO intAttachs:
    
    PUT-BYTES(FileArrayPtr, (zz * 24) - 23)  = GET-BYTES(FileDescPtr[zz],1,24).
    
END.
/* ---------- BUILD MESSAGE DETAILS ---------------- */
SET-SIZE(MessageDescPtr) = 48.
PUT-LONG(MessageDescPtr,1) = 0.                                             /* Reserved */
PUT-LONG(MessageDescPtr,5) = GET-POINTER-VALUE(SubjPtr).                    /* Subject */
PUT-LONG(MessageDescPtr,9) = GET-POINTER-VALUE(TextPtr).                    /* Text */
PUT-LONG(MessageDescPtr,13) = 0.                                            /* MessageType */ 
PUT-LONG(MessageDescPtr,17) = 0.                                            /* DateReceived */ 
PUT-LONG(MessageDescPtr,21) = 0.                                            /* ConversationID */ 
PUT-LONG(MessageDescPtr,25) = 1.                                            /* Flags */
PUT-LONG(MessageDescPtr,29) = GET-POINTER-VALUE(OriginDescPtr).             /* Originator */
PUT-LONG(MessageDescPtr,33) = intRecips.                                    /* RecipCount */
PUT-LONG(MessageDescPtr,37) = GET-POINTER-VALUE(RecipArrayPtr).             /* Recips */
PUT-LONG(MessageDescPtr,41) = intAttachs.                                   /* FileCount */
PUT-LONG(MessageDescPtr,45) = GET-POINTER-VALUE(FileArrayPtr).              /* Files */
/* ---------- SEND MESSAGE ------------------------- */
DEFINE VARIABLE ResultInt AS INTEGER NO-UNDO.
RUN MAPISendMail IN hpApi
 (INPUT 0,
  INPUT 0,
  INPUT GET-POINTER-VALUE(MessageDescPtr),
  INPUT 0,                                                                  /* 1 = MAPI_LOGON_UI + 2 = MAPI_NEW_SESSION + 8 = MAPI_DIALOG */
  INPUT 0,     
  OUTPUT ResultInt). 
 
IF ResultInt <> 0 THEN RUN MapiReturnCode.p (INPUT ResultInt).
 
/* ---------- RELEASE RESOURCES -------------------- */
SET-SIZE(SubjPtr) = 0.
SET-SIZE(TextPtr) = 0. 
DO zz = 1 TO intAttachs :
    SET-SIZE(FilePathNamePtr[zz]) = 0.
    SET-SIZE(FileNamPtr[zz])     = 0.
    SET-SIZE(FilePathNamePtr[zz]) = 0.
    SET-SIZE(FileDescPtr[zz])     = 0.
END.
DO zz = 1 TO intRecips :
    SET-SIZE(RecipNamePtr[zz])    = 0.
    SET-SIZE(RecipDescPtr[zz])    = 0.
END.
SET-SIZE(MessageDescPtr) = 0.
SET-SIZE(FileArrayPtr) = 0.
SET-SIZE(RecipArrayPtr) = 0.
SET-SIZE(OriginNamePtr) = 0.
IF VALID-HANDLE(hpAPI) THEN DELETE OBJECT hpAPI.
/* ---------- INTERNAL PROCEDURES ------------------ */
PROCEDURE recips:
/* --------------------------------------------*/
/*    Populate Reciptient Array, RecipName,    */
/*    from comma separated list.               */         
/*---------------------------------------------*/    
    DEFINE VARIABLE xx AS INTEGER NO-UNDO.
    IntRecips = 0.
    DO WHILE ipRecipName <> "":
        xx = INDEX(ipRecipName, ",").
        IF xx > 0 THEN DO:
            intRecips = intRecips + 1.
            RecipName[intRecips] = SUBSTRING(ipRecipName, 1, xx - 1).
            ipRecipName = SUBSTRING(ipRecipName, xx + 1).
        END.
        ELSE DO:
            IF ipRecipName <> "" THEN DO:
                intRecips = intRecips + 1.
                RecipName[intRecips] = ipRecipName.
                ipRecipName = "".
            END.
        END.
    END.
END PROCEDURE.
PROCEDURE attachs:
/* --------------------------------------------*/
/*    Populate Attachment Array, FilePathName  */
/*    from comma separated list.               */         
/*---------------------------------------------*/ 
    DEFINE VARIABLE yy AS INTEGER NO-UNDO.
    IntAttachs = 0.
    DO WHILE ipFilePathName <> "":
        yy = INDEX(ipFilePathName, ",").
        IF yy > 0 THEN DO:
            intAttachs = intAttachs + 1.
            FilePathName[intAttachs] = TRIM(SUBSTRING(ipFilePathName, 1, yy - 1)).
            ipFilePathName = TRIM(SUBSTRING(ipFilePathName, yy + 1)).
        END.
        ELSE DO:
            IF ipFilePathName <> "" THEN DO:
                intAttachs = intAttachs + 1.
                FilePathName[intAttachs] = TRIM(ipFilePathName).
                ipFilePathName = "".
            END.
        END.
    END.
END PROCEDURE.
END PROCEDURE.

Dial a telephone number

The Tapi (Telephony API) can be used to dial a telephone number or pager.
This source is from Johann van der Merwe.
His introduction says:
This is an example of what we use. The code is not cleaned up. We also
use our own dialing properties (for instance a outside line). Hope this
helps. Use MSDN to look up tapiRequestMakeCall for parameter info.

DEFI: DO ON ERROR UNDO, RETURN "ERROR-DEFI":U:
 
  DEFINE INPUT PARAMETER TelNoStr AS CHARACTER NO-UNDO. 
 
  DEFINE VARIABLE GetLine     AS CHARACTER NO-UNDO.
  DEFINE VARIABLE TelNo       AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE i           AS INTEGER   NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER   NO-UNDO.
END.
 
Main: DO ON ERROR UNDO, RETURN "ERROR-MAIN":U:
 
  GET-KEY-VALUE SECTION "Modem":U KEY "GetLine":U VALUE GetLine.
  IF GetLine = "?":U OR GetLine = ? THEN 
     GetLine = "":U.
 
  SET-SIZE(TelNo) = LENGTH(GetLine + TelNoStr) + 1.
  DO i = 1 TO LENGTH(TelNoStr + GetLine): 
     PUT-BYTE(TelNo,i) = ASC(SUBSTRING(GetLine + TelNoStr,i,1)).
  END.
  PUT-BYTE(TelNo,i) = 0.
  RUN tapiRequestMakeCall (INPUT GET-POINTER-VALUE(TelNo), 
                           INPUT "0":U, 
                           INPUT "0":U, 
                           INPUT "0":U,
                           OUTPUT ReturnValue).
END. 
 
PROCEDURE tapiRequestMakeCall EXTERNAL "tapi32.dll":U:
  DEFINE INPUT  PARAMETER lpszDestAddress AS LONG.
  DEFINE INPUT  PARAMETER lpszAppName     AS CHARACTER.
  DEFINE INPUT  PARAMETER lpszCalledParty AS CHARACTER.
  DEFINE INPUT  PARAMETER lpszComment     AS CHARACTER.
  DEFINE RETURN PARAMETER ReturnValue     AS LONG.
END PROCEDURE.

Interfacing with MAPI (email)

There are different kinds of solutions for using Email from Progress. For example, there are several ActiveX components, there is a Progress 7+8 product with source made by Ketil Parow (you can download a trial version at http:www.sn.no/~ketilp/misc/mapi.zip), you can use the MAPI OLE automation server (there is a document about that on the ActiveX pages on www.dotr.com) or you can use the MAPI through its native API. On this site we'll only discuss the API kind of solutions.
The next sourcecode example was posted by Jeff Ledbetter and was earlier found in Profiles. I ported it to 32-bit.
The example uses the 'Simple MAPI' interface. This interface is not by default available on any machine. The easiest way to ensure if Simple MAPI is available is to check the registry: the "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows Messaging Subsystem" variable "MAPI" should have value "1".

 
RUN SendMail ( INPUT "yourself@home.com",
              INPUT "this is the subject line",
              INPUT "This is the body text",
              OUTPUT Okay).
 
 
PROCEDURE SendMail :
DEFINE INPUT PARAMETER send-to-name AS CHARACTER NO-UNDO.
DEFINE INPUT PARAMETER send-subject AS CHARACTER NO-UNDO.
DEFINE INPUT PARAMETER send-text    AS CHARACTER NO-UNDO.
DEFINE OUTPUT PARAMETER Okay        AS LOGICAL NO-UNDO INITIAL NO.
 
DEFINE VARIABLE pnames   AS MEMPTR.
DEFINE VARIABLE psendto  AS MEMPTR.
DEFINE VARIABLE psubj    AS MEMPTR.
DEFINE VARIABLE ptext    AS MEMPTR.
DEFINE VARIABLE pmessage AS MEMPTR.
 
DEFINE VARIABLE wans AS INTEGER .
 
SET-SIZE(pnames)  = 24.
SET-SIZE(psendto) = 16.
 
 
PUT-LONG(pnames,1)  = 0. /* Reserved */
PUT-LONG(pnames,5)  = 1. /* Recip Class MAPI_TO */
PUT-LONG(pnames,9)  = GET-POINTER-VALUE(psendto). /* Names */
PUT-LONG(pnames,17) = 0. /* EID Size */
 
SET-SIZE(psubj)    = 100.
SET-SIZE(ptext)    = 8000.
SET-SIZE(pmessage) = 48.
 
PUT-STRING(psubj,1)   = send-subject.
PUT-STRING(ptext,1)   = send-text.
PUT-STRING(psendto,1) = send-to-name.
 
PUT-LONG(pmessage,1)  = 0. /* Reserved */
PUT-LONG(pmessage,5)  = GET-POINTER-VALUE(psubj). /* Subject */
PUT-LONG(pmessage,9)  = GET-POINTER-VALUE(ptext). /* Text */
PUT-LONG(pmessage,25) = 0. /* Flags */
PUT-LONG(pmessage,33) = 1. /* RecipCount */
PUT-LONG(pmessage,37) = GET-POINTER-VALUE(pnames).
PUT-LONG(pmessage,41) = 0.
 
RUN MAPISendMail IN hpApi(INPUT 0,      /* mapi session handle */
                          INPUT 0,      /* parent window handle */
                          INPUT GET-POINTER-VALUE(pmessage),
                          INPUT 0,      /* flags */
                          INPUT 0,      /* reserved, must be 0 */
                          OUTPUT Wans). /* error status */
IF Wans<>0 THEN
   MESSAGE "Mail not sent, error code=" Wans
           VIEW-AS ALERT-BOX.
ELSE
   Okay = YES.
 
/* dealloc memory */
SET-SIZE(pnames)   = 0.
SET-SIZE(psendto)  = 0.
SET-SIZE(psubj)    = 0.
SET-SIZE(ptext)    = 0.
SET-SIZE(pmessage) = 0.
 
END PROCEDURE.

Comments on MAPISendMail

The first parameter is a Mapi-session handle. If 0, MAPI will try to find a shared session or create a temporary session for the duration of the call and it might have to show a login dialog. So if you need to send several mails it might be better to create a session up front and reuse its handle.
The second parameter is a parent window handle. If MapiSendMail has to show a dialog (for example a login dialog), it will be an application-modal dialog parented to this window handle.The value 0 is valid but will not block input in your Progress application.
The third parameter is a fairly complicated message structure. This example only creates a simple mail but MAPI also allows to add one or more attachements as shown in the source on the next page ([[mapiattachment]] wikilink).
If you do not specify a recipient (send-to-name) you must allow MAPI to ask for one. That is, you must use the MAPI_DIALOG (=8) flag in the 4th parameter of MapiSendMail.

MAPI return codes

By Johann van der Merwe.

 
PROCEDURE MapiReturnCode  :
 
INPUT PARAMETER ResultInt AS INTEGER. /* result from MAPISendMail */
DEFINE VARIABLE RESULT AS CHARACTER NO-UNDO.
 
IF ResultInt <> 0 THEN DO:  /* 0 = Success */ 
   CASE ResultInt:
     WHEN  1 THEN RESULT = "User Abort".
     WHEN  2 THEN RESULT = "Failure".
     WHEN  3 THEN RESULT = "Login Failure".
     WHEN  4 THEN RESULT = "Disk Full".
     WHEN  5 THEN RESULT = "Insufficient Memory".
     WHEN  6 THEN RESULT = "Blk Too Small".
     WHEN  8 THEN RESULT = "Too Many Sessions".
     WHEN  9 THEN RESULT = "Too Many Files".
     WHEN 10 THEN RESULT = "Too Many Recipients".
     WHEN 11 THEN RESULT = "Attachment Not Found".
     WHEN 12 THEN RESULT = "Attachment Open Failure".
     WHEN 13 THEN RESULT = "Attachment Write Failure".
     WHEN 14 THEN RESULT = "Unknown Recipient".
     WHEN 15 THEN RESULT = "Bad Recipient type".
     WHEN 16 THEN RESULT = "No Messages".
     WHEN 17 THEN RESULT = "Invalid Message".
     WHEN 18 THEN RESULT = "Bodytext Too Large".
     WHEN 19 THEN RESULT = "Invalid Session".
     WHEN 20 THEN RESULT = "Type Not Supported".
     WHEN 21 THEN RESULT = "Ambiguous Recipient".
     WHEN 22 THEN RESULT = "Message in use".
     WHEN 23 THEN RESULT = "Network failure".
     WHEN 24 THEN RESULT = "Invalid edit fields".
     WHEN 25 THEN RESULT = "Invalid recipients".
     WHEN 26 THEN RESULT = "Feature not supported"
     OTHERWISE RESULT    = "Unknown error".
   END CASE.
 
   DO ON ENDKEY UNDO, LEAVE:
      MESSAGE ResultInt RESULT
              VIEW-AS ALERT-BOX.
   END.
END.

smtpmail.p

Since this is a chapter about email, it should be noted there is an excellent program named smtpmail.p available for free at [broken link removed]

This program is entirely written in regular Progress ABL without any WIN32 API call.

Using Microsoft CDO to send e-mail

You can use Microsoft's CDO object library to easily send emails from Progress using ActiveX.
It seems to use the local SMTP server installed with IIS, so you can get started with very little code.

def var objMessage as com-handle.

create "CDO.Message" objMessage.

objMessage:Subject = "Example CDO Message from Progress".
objMessage:From = "example@example.com".
objMessage:To = "example@example.com".
objMessage:TextBody = "This is some sample message text.".
objMessage:Send().

More extensive examples of using CDO (with VBScript) can be found here:
http://www.paulsadowski.com/WSH/cdo.htm
http://www.lewisroberts.com/2006/06/09/sending-cdomessage-with-importanc...

Using Outlook to send e-mail

There are many ways to send email, smtpmail.p from freeframework.org is known to be very good.
In the past there have been many quesions about Outlook. Here is one code snippet, seen on Peg in an email from John Lubenow (I hope we have permission to use this, if not just delete this topic and let me know please)

/** Send Outlook Mail **/
DEFINE INPUT PARAMETER mailto AS CHARACTER FORMAT "x(30)".
DEFINE INPUT PARAMETER mailcc AS CHARACTER FORMAT "x(30)".
DEFINE INPUT PARAMETER subject AS CHARACTER FORMAT "x(50)".
DEFINE INPUT PARAMETER body AS CHARACTER FORMAT "x(255)".

    DEFINE VARIABLE chOutlook AS COM-HANDLE NO-UNDO.
    DEFINE VARIABLE chmail AS COM-HANDLE NO-UNDO.

    CREATE "outlook.application.9" choutlook NO-ERROR.
    ASSIGN chmail = chOutlook:createItem(0).

    /** Assign data **/
    ASSIGN chmail:Subject  = subject.
    ASSIGN chMail:Body = body.
    ASSIGN chMail:TO = mailto.
    ASSIGN chMail:CC = mailcc.

    /** example for one attachment: **/
    chMail:Attachments:Add( [insert-file-name-here] ) NO-ERROR.
    chMail:Attachments(1):DisplayName =  [insert-file-display-name-here].

    /** view mail **/
    chMail:Display(1).
    chMail:SEND().
   
    RELEASE OBJECT chmail.
    RELEASE OBJECT choutlook.

CreateProcess

It is recommended to use the CreateProcess procedure instead WinExec. This is a very low-level procedure, it gives complete control over processes, threads and more.
CreateProcess takes 10 parameters, two of which are pointers to structures containing further parameters. Most parameters are not very interesting for our needs, so I have made a function CreateProcess that only takes the three most important params. The function is described in winfunc.p and can be called like in this example:

  {windows.i}
  DEFINE VARIABLE hProcess AS INTEGER NO-UNDO. 
  hProcess = CreateProcess("notepad.exe c:\config.sys",
                           "",
                           1). 
  IF hProcess=0 THEN
     ShowLastError().
  RUN CloseHandle IN hpApi (hProcess, OUTPUT ReturnValue).

The first parameter is the command line with optional parameters. The second parameter is the working directory for the new process, where "" will result in the current working directory of the Progress application. The third parameter is cmdShow with the same meaning as in WinExec.
The return value is a handle to the new process or 0 if the call failed.

notes

The GetLastError procedure did not work well in Progress 8, but it is fine now.

Do not forget to call CloseHandle. MS-Windows keeps a reference count to each kernel object, a process is a kernel object. A kernel object can not be destroyed when its reference count is larger than zero. Run CloseHandle decrements the reference count by one which only tells the kernel that you are not interested in keeping the new process alive. The process itself also has at least one reference to itself, so this CloseHandle call will not actually terminate the process. Forgetting to call CloseHandle will result in resource loss.

returning a PID

The following procedure also uses CreateProcess, but this time it returns a PID (process identifier) instead of a process handle.
This can be useful because procedure KillProcess expects a PID as input parameter, see terminate a process gently.

{windows.i}
 
PROCEDURE MakeProcess :
  DEFINE INPUT  PARAMETER CommandLine AS CHARACTER    NO-UNDO.
  DEFINE INPUT  PARAMETER WorkingDir  AS CHARACTER    NO-UNDO.
  DEFINE OUTPUT PARAMETER PID         AS INTEGER NO-UNDO.
 
  DEFINE VARIABLE wShowWindow AS INTEGER NO-UNDO INITIAL 0.
  DEFINE VARIABLE bResult     AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
   DEFINE VARIABLE lpStartupInfo AS MEMPTR.
   SET-SIZE(lpStartupInfo)     = 68.
   PUT-LONG(lpStartupInfo,1)   = 68.
   PUT-LONG (lpStartupInfo,45) = 1. /* = STARTF_USESHOWWINDOW */
   PUT-SHORT(lpStartupInfo,49) = wShowWindow.
 
   DEFINE VARIABLE lpProcessInformation AS MEMPTR.
   SET-SIZE(lpProcessInformation)   = 16.
 
   DEFINE VARIABLE lpWorkingDirectory AS MEMPTR.
   IF WorkingDir NE "" THEN DO:
      SET-SIZE(lpWorkingDirectory)     = 256.
      PUT-STRING(lpWorkingDirectory,1) = WorkingDir.
   END.   
 
   RUN CreateProcessA IN hpApi
     ( 0,
       CommandLine,
       0,
       0,
       0,
       0,
       0,
       IF WorkingDir=""
          THEN 0 
          ELSE GET-POINTER-VALUE(lpWorkingDirectory),
       GET-POINTER-VALUE(lpStartupInfo),
       GET-POINTER-VALUE(lpProcessInformation),
       OUTPUT bResult
     ).
 
  IF bResult=0 THEN 
     PID = 0.
  ELSE DO:
     PID      = GET-LONG(lpProcessInformation,9).
     /* release kernel-objects hProcess and hThread: */
     RUN CloseHandle IN hpApi(GET-LONG(lpProcessInformation,1), OUTPUT ReturnValue).
     RUN CloseHandle IN hpApi(GET-LONG(lpProcessInformation,5), OUTPUT ReturnValue).
  END.
 
  SET-SIZE(lpStartupInfo)        = 0.
  SET-SIZE(lpProcessInformation) = 0.
  SET-SIZE(lpWorkingDirectory)   = 0.
 
END PROCEDURE.

execute a program and wait until it becomes visible

Suppose your window has a button that is designed to launch an application, using ShellExecute or CreateProcess, but this application takes a few seconds to launch. Since ShellExecute(Ex) and CreateProcess return immediately after the process is created, an impatient user will have time to press the button several times. To work around this problem you may want to disable the button until the application really becomes visible. WaitForInputIdle does the trick. Well, in reality it waits until the application has its input queue (for mouse and keyboard) empty and waiting, but that's at about the same time anyway.

  
  {windows.i}
  DEFINE VARIABLE hProcess AS INTEGER NO-UNDO. 
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
  hProcess = CreateProcess("notepad.exe",
                           "",
                           3). 

  IF hProcess = 0 THEN DO:
      getlasterror().
      ShowLastError().
  END.
  ELSE DO:
     RUN WaitForInputIdle IN hpApi (hProcess, 
                                    -1,   /* -1=INFINITE */
                                    OUTPUT ReturnValue).
     RUN CloseHandle IN hpApi (hProcess, OUTPUT ReturnValue).
  END.

Note

CreateProcess does not search for applications as good as ShellExecute does. When CreateProcess does not find an application you may have more luck with ShellExecuteEx (not ShellExecute itself, because that does not return a hProcess).
ShellExecuteEx will return a hProcess when SEE_MASK_NOCLOSEPROCESS is specified in its fMask field.

execute a program and wait until it has finished

16-bit (there is a 32-bit solution near end of page)

This code was found on PEG, posted by Stuart Butler a while ago. It is 16 bit code and needs to be reworked for 32-bit. It compiles in version 8.2 but does not wait as expected.
The example program runs notepad, waits until the user has closed notepad and then displays the results of the user's work with notepad.

 /* If we were being run persistent we would want to 
  *** be interrupted when waiting for notepad to finish
  *** if we are closed so include an on close event trigger */
 DEFINE VARIABLE lgClosing AS LOGICAL INITIAL FALSE.
 ON CLOSE OF THIS-PROCEDURE
 DO:
    lgClosing = TRUE.
 END.
 
/* Run Notepad and keep a record of its task number */
 DEFINE VARIABLE nTask AS INT.
 RUN WinExec IN hpApi( "Notepad c:\temp\trash.txt", 1, OUTPUT nTask ).
 IF nTask GT 0 AND nTask LT 32 
 THEN DO: 
    MESSAGE "WinExec failed" VIEW-AS ALERT-BOX.
    RETURN.
 END.
 
/* Now wait for notepad to finish - when notepad is closed
 *** the task number will become invalid and Module
 *** API functions will fail - we are using GetModuleFileName. 
 *** The WAIT-FOR will process events and not hog all the CPU
 *** - pity the PAUSE could not be in milliseconds but will have to do
 *** with what's available.  If you use PROCESS EVENTS in some 
 *** other loop construction (with say a timer VBX) it is a good idea to 
 *** preceed it with a call to the WaitMessage() API call as 
 *** looping with PROCESS EVENTS tends to hog the CPU.
 *** You might want to disable your user interface at this point 
 *** though that may not be necessary if you have run this .p
 *** persistently to deal with the windows app "in the background".
 */
 DEFINE VARIABLE szName AS CHARACTER.
 DEFINE VARIABLE szNameLength AS INTEGER.
 REPEAT:
    WAIT-FOR CLOSE OF THIS-PROCEDURE PAUSE 1.
    szName = FILL(" ",256).
    RUN GetModuleFileName{&A} IN hpApi( nTask, 
                                        OUTPUT szName,
                                        LENGTH(szName),
                                        OUTPUT szNameLength).
    /* We don't want to know the ModuleFileName, we only want
     *** to know if the function fails. Fails if result=0.
     *** A failure indicates that the task has ended. */
    IF (szNameLength=0) OR lgClosing THEN
        LEAVE.
 END.
 
/* Notepad should have finished at this point - let's 
 *** see what the user input */
 MESSAGE "Notepad finished" VIEW-AS ALERT-BOX.
 INPUT FROM c:\temp\trash.txt.
 DEFINE VARIABLE szLine AS CHARACTER.
 REPEAT:
     IMPORT UNFORMATTED szLine.
     MESSAGE szLine VIEW-AS ALERT-BOX.
 END. 
 INPUT CLOSE.

Unfortunately, the repeat loop that checks for the existence of the executing task may slow down the computer.

32-bit

In a 32-bit environment you can use the procedure WaitForSingleObject. This is a very efficient procedure. The input parameter for WaitForSingleObject is a handle to an object, in this case a kernel process object. This is not the same as the hInstance as returned by ShellExecute.

To obtain a process handle you seem to have to start the process using either CreateProcess or ShellExecuteEx.
Here is a (simplified) example for CreateProcess. The next page, titled "wait until MS-Word finished printing" uses ShellExecuteEx but not specifically for its process handle...

  {windows.i}
  DEFINE VARIABLE hProcess AS INTEGER NO-UNDO. 
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
  hProcess = CreateProcess("notepad.exe c:\config.sys",
                           "",
                           1). 
  IF hProcess=0 THEN
     ShowLastError().
  ELSE DO:
     RUN WaitForSingleObject IN hpApi (hProcess, 
                                       -1,   /* -1=INFINITE */
                                       OUTPUT ReturnValue).
     RUN CloseHandle IN hpApi (hProcess, OUTPUT ReturnValue).
  END

CreateProcess and ShowLastError are declared in windows.i.

Don't forget CloseHandle!

The process object has an internal reference counter. There are/were at least two references: one from within notepad.exe itself, the other one from your program (obtained by CreateProcess). When notepad.exe terminates, it will decrease the object's reference counter but your program still holds one. The object can not be destroyed until the reference counter decreases to zero, so you must use CloseHandle (which decrements the counter by one and invalidates the handle).

In other words: there is a memory leak if you don't call CloseHandle (although the kernel calls it when the Progress session terminates).
CloseHandle does not destroy the object (yet), it just tells the Kernel that it can destroy the object whenever it wants to (as far as you are concerned). CloseHandle is important for every Kernel object: CreateProcess returns a process object and also a thread object. The thread object is already closed inside the P4GL implementation of function CreateProcess in winfunc.p (version May 9, 1998).

ShellExecute

ShellExecute is the procedure that is called by the Desktop or Windows Explorer when you double-click an item: if the item is an executable it will run it, if the item is a Word-document it will open it in MS-Word, etc.
There is a lot you can do with this easy-to-use procedure. Let's have a look at the parameters:

PROCEDURE ShellExecute{&A} EXTERNAL "shell32" :
     DEFINE INPUT PARAMETER HWND AS LONG.
     DEFINE INPUT PARAMETER lpOperation AS CHARACTER.
     DEFINE INPUT PARAMETER lpFile AS CHARACTER.
     DEFINE INPUT PARAMETER lpParameters AS CHARACTER.
     DEFINE INPUT PARAMETER lpDirectory AS CHARACTER.
     DEFINE INPUT PARAMETER nShowCmd AS LONG.
     DEFINE RETURN PARAMETER hInstance AS LONG.
  END.

The parameters are:
* hwnd : parent window that will receive a possible messagebox. This parameter is usually 0
* lpOperation : "open" or "print"
"print" is only valid if lpFile is a document
* lpFile : name of an executable or name of a document
* lpParameters : command-line parameters for the executable in lpFile
* lpDirectory : default directory to execute lpFile in
* nShowCmd : Same as in winexec: hidden=0 normal=1 minimized=2 maximized=3
* hInstance : If function succeeds hInstance will be the instance handle of the executed program. If the value is >=0 and <=32 the function failed.

As you can see there are different ways to perform "notepad.exe c:\readme.txt" :

RUN ShellExecute{&A} IN hpApi(0,
                              "open",
                              "notepad.exe",
                              "c:\readme.txt",
                              "",
                              1,
                              OUTPUT hInstance).

RUN ShellExecute{&A} IN hpApi(0,
                              "open",
                              "c:\readme.txt",
                              "",
                              "",
                              1,
                              OUTPUT hInstance).

The second example shows an important feature of ShellExecute: opening a document. It uses associations to find the matching executable. Both examples will have the exact same result if the extention ".txt" is associated with "notepad.exe".

Examples

The following examples, submitted by Rob den Boer, show how ShellExecute can be used to send email, or to open the default browser for a particular website:

Sending email

  DEFINE VARIABLE email AS CHARACTER NO-UNDO.
  email =   "mailto:rc.den.boer@hccnet.nl"
          + "?cc=piet@nowhere.nl"
          + "?Subject=Test%20by%20Rob"  /* notice %20 instead of space */
          + "?Body=How are you doing".
 
  RUN ShellExecute{&A} IN hpApi 
                   (0,
                    "open",
                    email,
                    "",
                    "",
                    1,
                    OUTPUT hInstance).

open a website in your default browser

  RUN ShellExecute{&A} IN hpApi 
                   (0,
                    "open",
                    "ftp://zdftp.zdnet.com",
                    "",
                    "",
                    1,
                    OUTPUT hInstance).
/* or: */ 
  RUN ShellExecute{&A} IN hpApi 
                   (0,
                    "open",
                    "http://home.hccnet.nl/rc.den.boer/progress/index.html",
                    "",
                    "",
                    1,
                    OUTPUT hInstance).
 

ShellExecute and OpenAs

improved by Tim Townsend

Documents can be associated with executables, Windows recognizes a document by its file extention.
Thanks to associations, the ShellExecute procedure knows how to "open" a document and the Explorer knows which icon to draw next to a document.
If a document does not have an association yet and you choose "open" in the Explorer, you will be presented a "Open As" dialog where you can choose an application. The following example shows how to do this in Progress.
The procedure first tries to open (or print) the document. If this fails the first time, it will try a second time using the OpenAs dialog.

/*--------------------------------------------------------------------------
       File        : open-doc.p
       Purpose     : Open a windows document using the associated application.
                     If no assocoated application, run the OpenAs dialog to
                     allow the user to pick an application.
 
       Syntax      :
 
       Description :
 
       Author(s)   : TWT
       Created     : 22 Dec 1999
       Notes       :
--------------------------------------------------------------------------*/
 
DEFINE INPUT        PARAM cFileName            AS CHARACTER        NO-UNDO.
DEFINE INPUT        PARAM cParams              AS CHARACTER        NO-UNDO.
DEFINE INPUT        PARAM cDirectory           AS CHARACTER        NO-UNDO.
DEFINE INPUT        PARAM lPrint               AS LOG         NO-UNDO.
 
&SCOPED-DEFINE SE_ERR_NOASSOC 31
&SCOPED-DEFINE SE_ERR_ASSOCINCOMPLETE 27
 
DEFINE VARIABLE iInstance            AS INTEGER                        NO-UNDO.
DEFINE VARIABLE cWorkDirectory       AS CHARACTER                       NO-UNDO.
 
/* in case parameter cDirectory contains a relative path 
   it has to be replaced by a fully-qualified path: */
 
ASSIGN FILE-INFO:FILE-NAME = cDirectory.
IF FILE-INFO:FULL-PATHNAME > "" THEN
  cWorkDirectory = FILE-INFO:FULL-PATHNAME.
 
/* try to execute the document: */
 
RUN ShellExecuteA(INPUT 0,
                  INPUT (IF lPrint THEN "print":u ELSE "open":u),
                  INPUT cFileName,
                  INPUT cParams,
                  INPUT cWorkDirectory,
                  INPUT 1,  /* normal mode */
                  OUTPUT iInstance).
 
/* if no associated application, run OpenAs dialog: */
 
IF (iInstance = {&SE_ERR_NOASSOC} OR 
    iInstance = {&SE_ERR_ASSOCINCOMPLETE}) 
   AND NOT lPrint THEN DO:
 
   /* Ignore cParams because cFileName is a document.
      cParams is only valid with executables */
   RUN ShellExecuteA (INPUT 0,
                      INPUT "open":u,
                      INPUT "rundll32.exe":u,
                      INPUT "shell32.dll,OpenAs_RunDLL ":u + cFileName,
                      INPUT cWorkDirectory,
                      INPUT 1,
                      OUTPUT iInstance).
END.  /* if */
 
/* test for error: */
 
RUN TestErrorCode(iInstance).
IF RETURN-VALUE > "" THEN
  MESSAGE RETURN-VALUE
    VIEW-AS ALERT-BOX ERROR BUTTON OK.
 
/****************************************************************************/
 
PROCEDURE ShellExecuteA EXTERNAL "shell32":U :
  DEFINE INPUT PARAMETER HWND         AS LONG.
  DEFINE INPUT PARAMETER lpOperation  AS CHARACTER.
  DEFINE INPUT PARAMETER lpFile       AS CHARACTER.
  DEFINE INPUT PARAMETER lpParameters AS CHARACTER.
  DEFINE INPUT PARAMETER lpDirectory  AS CHARACTER.
  DEFINE INPUT PARAMETER nShowCmd     AS LONG.
  DEFINE RETURN PARAMETER hInstance   AS LONG.
END PROCEDURE.
 
 
PROCEDURE TestErrorCode :
DEFINE INPUT PARAMETER iCode AS INTEGER.
DEFINE VARIABLE cTxt AS CHARACTER NO-UNDO.
 
IF iCode < 0 OR iCode > 32 THEN RETURN "". /* no error */
 
CASE iCode :
  WHEN  0 THEN cTxt = "The operating system is out of memory or resources.":T132.
  WHEN  2 THEN cTxt = "The specified file was not found":T132.
  WHEN  3 THEN cTxt = "The specified path was not found.":T132.
  WHEN  5 THEN cTxt = "The operating system denied access to the specified file.":T132.
  WHEN  8 THEN cTxt = "There was not enough memory to complete the operation.":T132.
  WHEN 10 THEN cTxt = "Wrong Windows version":T132.
  WHEN 11 THEN cTxt = "The .EXE file is invalid (non-Win32 .EXE or error in .EXE image).":T132.
  WHEN 12 THEN cTxt = "Application was designed for a different operating system.":T132.
  WHEN 13 THEN cTxt = "Application was designed for MS-DOS 4.0.":T132.
  WHEN 15 THEN cTxt = "Attempt to load a real-mode program.":T132.
  WHEN 16 THEN cTxt = "Attempt to load a second instance of an application with non-readonly data segments.":T132.
  WHEN 19 THEN cTxt = "Attempt to load a compressed application file.":T132.
  WHEN 20 THEN cTxt = "Dynamic-link library (DLL) file failure.":T132.
  WHEN 26 THEN cTxt = "A sharing violation occurred.":T132.
  WHEN 27 THEN cTxt = "The filename association is incomplete or invalid.":T132.
  WHEN 28 THEN cTxt = "The DDE transaction could not be completed because the request timed out.":T132.
  WHEN 29 THEN cTxt = "The DDE transaction failed.":T132.
  WHEN 30 THEN cTxt = "The DDE transaction could not be completed because other DDE transactions were being processed.":T132.
  WHEN 31 THEN cTxt = "There is no application associated with the given filename extension.":T132.
  WHEN 32 THEN cTxt = "The specified dynamic-link library was not found.":T132.
  OTHERWISE    cTxt = "Undocumented error code returned":T132.
END.
 
RETURN cTxt.
 
END PROCEDURE.

notes

This example by Tim Townsend replaces the old example, which was published here until 5 januari 2000. For those who still use a copy of the old source: this new one is better because you can now pass a URL, like "www.progress.com", to the cFilename parameter.

ShellExecute return codes

If a call to ShellExecute succeeds, the returned hInstance parameter will be the instance handle of the executed program. But if the hInstance is less then 33, it indicates a failure.
Actually if the hInstance>=0 and hInstance<33 because a very large hInstance will be casted into a signed integer variable and may appear to be negative from Progress' perspective.
This page lists the descriptions for some of the possible failures.

It's actually a combination from different resources, both from WinExec and other procedures so some of the result may never occur when using ShellExecute. There are also some gaps in the list, and moreover: some results should have a different description in 16-bit mode. Where descriptions in 16-bit are different then 32-bit I've picked the 32-bit description

{windows.i}
 
DEFINE VARIABLE hInstance AS INTEGER.
 
RUN ShellExecute{&A} IN hpApi(0,
                              "open",
                              "xyz.doc",
                              "",
                              "",
                              1,
                              OUTPUT hInstance).
 
RUN TestInstance (hInstance).
IF RETURN-VALUE > "" THEN
   MESSAGE "ShellExecute failed, reason: " SKIP
           RETURN-VALUE
           VIEW-AS ALERT-BOX ERROR.
 
 
 
PROCEDURE TestInstance :
 
DEFINE INPUT PARAMETER hInstance AS INTEGER. /* =return value from ShellExecute */
DEFINE VARIABLE txt AS CHARACTER NO-UNDO.
 
IF hInstance<0 OR hInstance>32 THEN RETURN "". /* not failed */
 
CASE hInstance :
  WHEN  0 THEN txt = "The operating system is out of memory or resources.".
  WHEN  2 THEN txt = "The specified file was not found".
  WHEN  3 THEN txt = "The specified path was not found.".
  WHEN  5 THEN txt = "Windows 95 only: The operating system denied " 
                      + "access to the specified file".
  WHEN  8 THEN txt = "Windows 95 only: There was not enough memory to "
                      + "complete the operation.".
  WHEN 10 THEN txt = "Wrong Windows version".
  WHEN 11 THEN txt = "The .EXE file is invalid (non-Win32 .EXE or "
                      + "error in .EXE image).".
  WHEN 12 THEN txt = "Application was designed for a different operating system".
  WHEN 13 THEN txt = "Application was designed for MS-DOS 4.0".
  WHEN 15 THEN txt = "Attempt to load a real-mode program".
  WHEN 16 THEN txt = "Attempt to load a second instance of "
                      + "an application with non-readonly data segments".
  WHEN 19 THEN txt = "Attempt to load a compressed application file".
  WHEN 20 THEN txt = "Dynamic-link library (DLL) file failure".
  WHEN 26 THEN txt = "A sharing violation occurred.".
  WHEN 27 THEN txt = "The filename association is incomplete or invalid.".
  WHEN 28 THEN txt = "The DDE transaction could not be completed " 
                      + "because the request timed out.".
  WHEN 29 THEN txt = "The DDE transaction failed.".
  WHEN 30 THEN txt = "The DDE transaction could not be completed because "
                      + "other DDE transactions were being processed.".
  WHEN 31 THEN txt = "There is no application associated with "
                     + "the given filename extension.".
  WHEN 32 THEN txt = "Windows 95 only: The specified dynamic-link " 
                     + "library was not found.".
  OTHERWISE    txt = "undocumented".
END.
 
RETURN txt.
 
END PROCEDURE.
 

ShellExecuteEx

ShellExecuteEx combines features of ShellExecute and CreateProcess, the most noticable feature is that it returns a PID.

PROCEDURE ShellExecuteExA EXTERNAL "shell32.dll" :
  DEFINE INPUT  PARAMETER lpExecInfo  AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.

lpExecInfo is a memory-pointer to a structure of type SHELLEXECUTEINFO, which is a bit complicated to describe. Perhaps it's best to point at an example: See wait until MS-Word finished printing.

the obsolete WinExec procedure

WinExec is often found in old examples for Visual Basic. It's old... don't use it!
In Windows 3.x you would have used the WinExec procedure to run a program. The procedure is still around in Windows but it is obsolete, you should use CreateProcess or ShellExecute instead. In fact, WinExec itself is nothing but a wrapper to CreateProcess.
Note that WinExec from "krnl386.exe" (the 16 bit version) can not execute a 32-bit program, while WinExec from "kernel32.dll" (the 32 bit version) can't execute a 16-bit program.
So if you are running a Progress version less than 8.2 on Windows 95+, you may end up using two different versions of WinExec (the regular 16-bits version and a thunked 32-bits version).
(Also if you want to call a 16-bit program in Progress 8.2, but that is something you should not want to do!)
The WinExec procedure does not let you control the default directory.
If all these problems don't apply to you, you will find WinExec easy to use. Here is how you call it:

  {windows.i}
  DEFINE VARIABLE hTask AS INTEGER NO-UNDO.
  RUN WinExec IN hpApi( "notepad.exe c:\readme.txt", 1, OUTPUT hTask).
  IF hTask>=0 AND hTask<32 THEN
     MESSAGE "failed" VIEW-AS ALERT-BOX.

Explanation

The second parameter is the CmdShow parameter, the most commonly used values are:
* hidden = 0
* normal = 1
* minimized = 2
* maximized = 3

The output parameter is a handle to the task that WinExec created. According to API documentation this value should be greater than 31. But since it is an unsigned integer and gets casted into a signed Progress integer, it may occur that a valid very large value will seem to be less than 0. Values 0 to 31 represent a documented error status.

wait until MS-Word finished printing

Scenario:

* You have created an RTF file, c:\temp\test.rtf
* You want MS-Word to print this RTF file, but you don't want to use OLE Automation. In other words: you want to call ShellExecute(..., "print", "c:\temp\test.rtf", .....).
* You want to wait until MS-Word has finished printing.

Why:

OLE Automation would be fine but the OLE commands are application specific (and perhaps even version/translation specific) so you rather rely on the Shell "print"-verb.
You can not easily use CreateProcess and WaitForSingleObject, because MS-Word (and many other word-processors) has an MDI-interface. This means MS-Word (the process) will not terminate if it was already opened before you issued the "print"-request.

Solution:

Knowing that the Shell's "print"-verb executes a DDE-conversation with MS-Word, you can use ShellExecuteEx with the option to wait until the DDE conversation terminates.
Procedure PrintAndWait in this example uses the ShellExecuteEx function. I did not include any error-handling.

RUN PrintAndWait ("c:\temp\test.rtf").
 
{windows.i}
 
PROCEDURE PrintAndWait :
  define INPUT PARAMETER FILENAME AS CHARACTER NO-UNDO.
 
  DEFINE VARIABLE lpVerb AS MEMPTR.
  DEFINE VARIABLE lpFile AS MEMPTR.
  DEFINE VARIABLE lpExecInfo AS MEMPTR.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  SET-SIZE(lpVerb)         = LENGTH("print") + 1.
  PUT-STRING(lpVerb,1)     = "print".
 
  SET-SIZE(lpFile)         = LENGTH (FILENAME) + 1.
  PUT-STRING(lpFile,1)     = FILENAME.
 
  SET-SIZE (lpExecInfo)    = 60.
  PUT-LONG (lpExecInfo, 1) = GET-SIZE(lpExecInfo).
  PUT-LONG (lpExecInfo, 5) = 256. /* = SEE_MASK_FLAG_DDEWAIT */
  PUT-LONG (lpExecInfo, 9) = 0.   /* hwnd                    */
  PUT-LONG (lpExecInfo,13) = GET-POINTER-VALUE(lpVerb).
  PUT-LONG (lpExecInfo,17) = GET-POINTER-VALUE(lpFile).
  PUT-LONG (lpExecInfo,21) = 0.   /* commandline             */
  PUT-LONG (lpExecInfo,25) = 0.   /* current directory       */
  PUT-LONG (lpExecInfo,29) = 2.   /* wCmdShow                */
 
  RUN ShellExecuteExA IN hpApi(GET-POINTER-VALUE(lpExecInfo),
                               OUTPUT ReturnValue).
 
  SET-SIZE (lpExecInfo)    = 0.
  SET-SIZE (lpFile)        = 0.
  SET-SIZE (lpverb)        = 0.
 
END PROCEDURE.
 

Available disk space (not win95)

by Michael Rüsweg-Gilbert

To get the amount of available disk space you can call GetDiskFreeSpace or GetDiskFreeSpaceEx.
GetDiskFreeSpaceEx is best because it supports disks larger than 2 gigabyte. Unfortunately this function may not be available on every Windows version (Windows 95 before OSR2 only supports GetDiskFreeSpace).

The following program shows how to call GetDiskFreeSpaceEx. Note how the 64-bit parameters are cast in MEMPTR variables and converted to decimal values.

/* ===============================================================================
    Program:  VolSpace.p
    Created:  Michael R?Gilbert    Feb 2001
              mailto:rg@rgilbert.de
Description:  returns the capacity and free space of a volume (even if Vol > 2 GB)
      Usage:  for ex. run VolSpace.p ("C:",
                                      "KB",
                                      output freeSpace,
                                      output totalSpace).
 Parameters: - Volume to check or Blank
                 (Blank returns informations abaout the working drirector drive)
               It does not have to be the root, accepts any directory.   
             - Unit to format the result; legal entries are 
                   "KB", "MB" or "GB".
               If the unit is not recognized or empty, VolSpace will return 
               Number of Bytes.
             - OUTPUT available free space in given unit
             - OUTPUT total space in given unit
 
             When VolSpace is not successful, both output parameters will return ?.
 
modifications:
   March 14, 2001: Jurjen - added function IsAPIFunctionSupported()             
===================================================================================== */
 
DEFINE INPUT  PARAMETER ip_drive   AS CHARACTER NO-UNDO.
DEFINE INPUT  PARAMETER ip_unit    AS CHARACTER NO-UNDO.
DEFINE OUTPUT PARAMETER op_free    AS DECIMAL   NO-UNDO.
DEFINE OUTPUT PARAMETER op_total   AS DECIMAL   NO-UNDO.
 
&SCOPED-DEFINE WTRUE 1
&SCOPED-DEFINE WFALSE 0
 
FUNCTION get64BitValue RETURNS DECIMAL
    (INPUT m64 AS MEMPTR) FORWARD.
 
FUNCTION IsAPIFunctionSupported RETURNS LOGICAL 
    (FunctionName AS CHAR, ModuleName AS CHARACTER) FORWARD.
 
DEFINE VARIABLE retval     AS INTEGER    NO-UNDO.
DEFINE VARIABLE divident   AS INTEGER    NO-UNDO INIT 1.
DEFINE VARIABLE i          AS INTEGER    NO-UNDO.
 
DEFINE VARIABLE mem1 AS MEMPTR     NO-UNDO.
DEFINE VARIABLE mem2 AS MEMPTR     NO-UNDO.
DEFINE VARIABLE mem3 AS MEMPTR     NO-UNDO.
 
/* See if GetDiskFreeSpaceEx is available in this Windows version.
   (it is available in NT4, Windows 95 OSR2, Windows 98, Windows 2000)  */
IF NOT IsAPIFunctionSupported("GetDiskFreeSpaceExA":U, "kernel32.dll":U) THEN DO:
    MESSAGE "Sorry, your version of Windows does not support GetDiskFreeSpaceEx"
            VIEW-AS ALERT-BOX.
    ASSIGN op_free  = ?
           op_total = ?.
    RETURN.
END.
 
IF CAN-DO("KB,Kilo,Kilobyte,Kilobytes", ip_unit)
THEN divident = 1024.
ELSE
IF CAN-DO("MB,Mega,Megabyte,Megabytes", ip_unit)
THEN divident = 1024 * 1024.
ELSE
IF CAN-DO("GB,Giga,Gigabyte,Gigabytes", ip_unit)
THEN divident = 1024 * 1024 * 1024.
ELSE divident = 1.
 
/* No directory specified? Then use the current directory */
IF (ip_drive = "") OR (ip_drive=?) THEN DO:
    FILE-INFO:FILE-NAME = ".".
    ip_drive = FILE-INFO:FULL-PATHNAME.
END.
 
/* If a UNC name was specified, make sure it ends with a backslash ( \\drive\share\dir\ )
   This won't hurt for a mapped drive too */
IF SUBSTR(ip_drive, LENGTH(ip_drive), 1) NE "\"
   THEN ip_drive = ip_drive + "\".
 
SET-SIZE(mem1) = 8.  /* 64 bit integer! */
SET-SIZE(mem2) = 8.
SET-SIZE(mem3) = 8.
 
RUN GetDiskFreeSpaceExA ( ip_drive + CHR(0),
                         OUTPUT mem1,
                         OUTPUT mem2,
                         OUTPUT mem3,
                         OUTPUT retVal  ).
IF retVal NE {&WTRUE} THEN DO:
        op_free = ?.
        op_total = ?.
END.
ELSE DO:
     ASSIGN
        op_free  = TRUNC( get64BitValue(mem3) / divident, 3)
        op_total = TRUNC( get64BitValue(mem2) / divident, 3).
END.
 
SET-SIZE(mem1) = 0.
SET-SIZE(mem2) = 0.
SET-SIZE(mem3) = 0.
 
RETURN.
 
PROCEDURE GetModuleHandleA EXTERNAL "kernel32.dll" :
    DEFINE  INPUT PARAMETER lpModuleName       AS CHARACTER NO-UNDO.
    DEFINE RETURN PARAMETER hModule            AS LONG      NO-UNDO.
END PROCEDURE.
 
PROCEDURE GetProcAddress EXTERNAL "kernel32.dll" :
    DEFINE  INPUT PARAMETER hModule            AS LONG NO-UNDO.
    DEFINE  INPUT PARAMETER lpProcName         AS CHARACTER NO-UNDO.
    DEFINE RETURN PARAMETER lpFarproc          AS LONG NO-UNDO.
END PROCEDURE.
 
PROCEDURE GetDiskFreeSpaceExA EXTERNAL "kernel32.dll" :
    DEFINE  INPUT  PARAMETER  lpDirectoryName        AS CHARACTER NO-UNDO.
    DEFINE OUTPUT  PARAMETER  FreeBytesAvailable     AS MEMPTR    NO-UNDO.
    DEFINE OUTPUT  PARAMETER  TotalNumberOfBytes     AS MEMPTR    NO-UNDO.
    DEFINE OUTPUT  PARAMETER  TotalNumberOfFreeBytes AS MEMPTR    NO-UNDO.
    DEFINE RETURN  PARAMETER  retval                 AS LONG      NO-UNDO.
END PROCEDURE.
 
 
/* See if GetDiskFreeSpaceEx is available in this Windows version */
FUNCTION IsAPIFunctionSupported RETURNS LOGICAL
    (FunctionName AS CHAR, ModuleName AS CHARACTER):
 
    DEFINE VARIABLE hModule AS INTEGER NO-UNDO.
    DEFINE VARIABLE lpFarProc AS INTEGER NO-UNDO.
 
    /* you should run LoadLibraryA to load the module into memory, 
       but this is not necessary for ModuleName="kernel32.dll": the kernel is 
       always available. */
    RUN GetModuleHandleA (ModuleName, OUTPUT hModule).
    RUN GetProcAddress   (hModule, FunctionName, OUTPUT lpFarProc).
    RETURN lpFarProc NE 0.
END FUNCTION.
 
 
/* Converts a 64-bit integer given in a 8 byte mempointer into a decimal */
FUNCTION get64BitValue RETURNS DECIMAL
( INPUT m64 AS MEMPTR ):
 
    /* constant 2^32 */
    &SCOPED-DEFINE BigInt 4294967296
 
    DEFINE VARIABLE d1 AS DECIMAL    NO-UNDO.
    DEFINE VARIABLE d2 AS DECIMAL    NO-UNDO.
 
    d1 = GET-LONG(m64, 1).
    IF d1 < 0 
    THEN d1 = d1 + {&BigInt}.
 
    d2 = GET-LONG(m64, 5).
    IF d2 < 0 
    THEN d2 = d2 + {&BigInt}.
 
    IF d2 GT 0
    THEN d1 = d1 + (d2 * {&BigInt}).
 
    RETURN d1.
 
END FUNCTION.

Available disk space (win95)

To get the amount of available disk space you can call GetDiskFreeSpace or GetDiskFreeSpaceEx.
There are differences between Windows 95, Windows 95 OSR/2 and Windows NT 4.0.

This text is quoted from MSDN Library:

In Windows 95, the existing Win32 function GetDiskFreeSpace may obtain
incorrect values for volumes that are larger than 2 gigabytes (GB). 
In OSR 2, the function GetDiskFreeSpace has been modified to cap the 
value returned and never reports volume sizes greater than 2 GB. 
On very large empty volumes, existing applications will see only 2 GB free. 
If less than 2 GB are free, the correct amount will be returned. 
Windows 95 OSR 2 and Windows NT 4.0 support the GetDiskFreeSpaceEx function. 
GetDiskFreeSpaceEx obtains correct values on all platforms for all volumes, 
including those that are larger than 2 GB. 
New applications should use the GetDiskFreeSpaceEx function instead of 
the GetDiskFreeSpace function. 

The following code shows how to call GetDiskFreeSpace. This example was submitted by Stuart Morris [stuart@IBS-PUBLIC-SERVICES.CO.UK]

  DEFINE VARIABLE iSectorsPerCluster AS INTEGER  NO-UNDO.
  DEFINE VARIABLE iBytesPerSector    AS INTEGER  NO-UNDO.
  DEFINE VARIABLE iFreeClusters      AS INTEGER  NO-UNDO.
  DEFINE VARIABLE iClusters          AS INTEGER  NO-UNDO.
  DEFINE VARIABLE iResult            AS INTEGER  NO-UNDO.
  DEFINE VARIABLE iVolName           AS CHARACTER NO-UNDO INIT "c:\".
 
  PROCEDURE GetDiskFreeSpaceA EXTERNAL "kernel32.dll":
      DEFINE INPUT   PARAM lpRootPathName      AS CHARACTER.
      DEFINE OUTPUT  PARAM opSectorsPerCluster AS LONG.
      DEFINE OUTPUT  PARAM opBytesPerSector    AS LONG.
      DEFINE OUTPUT  PARAM opFreeClusters      AS LONG.
      DEFINE OUTPUT  PARAM opClusters          AS LONG.
      DEFINE RETURN PARAM bResult              AS LONG.
  END PROCEDURE.
 
  RUN GetDiskFreeSpaceA(INPUT  iVolName,
                        OUTPUT iSectorsPerCluster,
                        OUTPUT iBytesPerSector,
                        OUTPUT iFreeClusters,
                        OUTPUT iClusters,
                        OUTPUT iResult
                       ).
 
 
  MESSAGE "SectorsPerCluster = " iSectorsPerCluster SKIP
          "BytesPerSector = "    iBytesPerSector    SKIP
          "FreeClusters = "      iFreeClusters      SKIP
          "Clusters = "          iClusters          SKIP(1)
 
          "BytesPerCluster = "   (iSectorsPerCluster * iBytesPerSector) SKIP
          "DiskSpaceFree = "     ((iFreeClusters * iSectorsPerCluster) * iBytesPerSector)
 
          VIEW-AS ALERT-BOX INFO TITLE "disk " + iVolname.

BrowseForFolder

Sometimes you want to choose a folder but the usual system dialogs require you to choose a file as well. The API function SHBrowseForFolder does not show any files: it does exactly what the name implies.

/* a test/demo program */
DEFINE VARIABLE folder AS CHARACTER NO-UNDO.
DEFINE VARIABLE canceled AS LOGICAL NO-UNDO.
 
RUN BrowseForFolder.p ("choose the directory where you want to dump your data",
                       OUTPUT folder, 
                       OUTPUT canceled).
 
MESSAGE "folder=" folder SKIP
        "canceled=" canceled
        VIEW-AS ALERT-BOX.
 
/* ==========================================================
   file:  BrowseForFolder.p
   ========================================================== */
{windows.i}
 
DEFINE INPUT  PARAMETER DialogTitle AS CHARACTER NO-UNDO.
DEFINE OUTPUT PARAMETER FolderName  AS CHARACTER NO-UNDO.
DEFINE OUTPUT PARAMETER Canceled    AS LOGICAL NO-UNDO.
 
DEFINE VARIABLE MAX_PATH       AS INTEGER INITIAL 260.
DEFINE VARIABLE lpbi           AS MEMPTR.  /* pointer to BROWSEINFO structure */
DEFINE VARIABLE pszDisplayName AS MEMPTR.
DEFINE VARIABLE lpszTitle      AS MEMPTR.
DEFINE VARIABLE lpItemIDList   AS INTEGER NO-UNDO.
DEFINE VARIABLE ReturnValue    AS INTEGER NO-UNDO.
 
SET-SIZE(lpbi)           = 32.
SET-SIZE(pszDisplayName) = MAX_PATH.
SET-SIZE(lpszTitle)      = LENGTH(DialogTitle) + 1.
 
PUT-STRING(lpszTitle,1)  = DialogTitle.
 
PUT-LONG(lpbi, 1) = 0.  /* hwnd for parent */
PUT-LONG(lpbi, 5) = 0.
PUT-LONG(lpbi, 9) = GET-POINTER-VALUE(pszDisplayName).
PUT-LONG(lpbi,13) = GET-POINTER-VALUE(lpszTitle).
PUT-LONG(lpbi,17) = 1. /* BIF_RETURNONLYFSDIRS = only accept a file system directory */
PUT-LONG(lpbi,21) = 0. /* lpfn, callback function */
PUT-LONG(lpbi,25) = 0. /* lParam for lpfn */
PUT-LONG(lpbi,29) = 0.
 
RUN SHBrowseForFolder IN hpApi ( INPUT  GET-POINTER-VALUE(lpbi), 
                                 OUTPUT lpItemIDList ).
 
/* parse the result: */
IF lpItemIDList=0 THEN DO:
   Canceled   = YES.
   FolderName = "".
END.
ELSE DO:
   Canceled = NO.
   FolderName = FILL(" ", MAX_PATH).
   RUN SHGetPathFromIDList IN hpApi(lpItemIDList, 
                                    OUTPUT FolderName,
                                    OUTPUT ReturnValue).
   FolderName = TRIM(FolderName).
END.   
 
/* free memory: */
SET-SIZE(lpbi)=0.
SET-SIZE(pszDisplayName)=0.
SET-SIZE(lpszTitle)=0.
RUN CoTaskMemFree (lpItemIDList).
 
PROCEDURE CoTaskMemFree EXTERNAL "ole32.dll" :
  DEFINE INPUT PARAMETER lpVoid AS LONG.
END PROCEDURE.

Notes

Documentation says that SHBrowseForFolder is not supported on Windows NT. However the above procedure was tested on Windows NT and seemed to work fine.

More Notes

The memory occupied by lpItemIDList can be freed by CoTaskMemFree. This was discovered by Todd G. Nist who explains "This will free the memory the shell allocated for the ITEMIDLIST structure which consists of one or more consecutive ITEMIDLIST structures packed on byte boundaries, followed by a 16-bit zero value. An application can walk a list of item identifiers by examining the size specified in each SHITEMID structure and stopping when it finds a size of zero. A pointer to an item identifier list, is called a PIDL (pronounced piddle.) "

Even More Notes

An different but very interesting approach is to use COM Automation: the "shell.application" interface contains a BrowseForFolder function. There is an example in article 18823 of the Progress Knowledgebase.
There is a different example by Julian Lyndon-Smith on page BrowseForFolder using COM

Initial folder

SHBrowseForFolder supports the use of a callback function from where you can specify an initial folder or perform some validations. Unfortunately, callback functions can not be written in Progress 4GL so you will have to wrap it in a DLL. This has been done by Cyril O'Floinn, see BrowseForFolder with an initial folder

BrowseForFolder using COM Automation

Instead of using API-function SHBrowseForFolder to select a directory, you can also use the COM-interface of the "Shell".
There is an example in article 18823 of the Progress Knowledgebase.
Julian Lyndon-Smith wrote the following example, different from the one in the Knowledge Base.

 
FUNCTION DotRGetFolder RETURNS CHARACTER
  ( INPUT ip_cTitle AS CHARACTER /* title for browse dialog */ ) :
 
   /* constants for BrowseForFolder options */
   &SCOPED BIF_RETURNONLYFSDIRS  1
   &SCOPED BIF_DONTGOBELOWDOMAIN 2
 
   DEFINE VARIABLE lv_chShell  AS COM-HANDLE NO-UNDO. /* shell application */
   DEFINE VARIABLE lv_chFolder AS COM-HANDLE NO-UNDO. /* holder for selected folder object */
 
   DEFINE VARIABLE lv_cPathName AS CHARACTER NO-UNDO. /* folder pathame */
 
   IF ip_cTitle EQ "":U OR ip_cTitle EQ ? THEN 
      ASSIGN ip_cTitle = "Select Folder".
 
   /* create Shell Automation object */
   CREATE "Shell.Application":U lv_chShell NO-ERROR.
 
   IF NOT VALID-HANDLE(lv_chShell) THEN 
      RETURN "":u. /* automation object not present on system */
 
   /* execute the browseForFolderMethod */
   lv_chFolder = lv_chShell:BrowseForFolder(CURRENT-WINDOW:HWND,
                                            ip_cTitle,
                                            {&BIF_DONTGOBELOWDOMAIN}
                                            + {&BIF_RETURNONLYFSDIRS}).
 
   /* see if user has selected a valid folder */
   IF VALID-HANDLE(lv_chFolder) AND lv_chFolder:SELF:IsFolder THEN 
      ASSIGN lv_cPathName   = lv_chFolder:SELF:Path.
   ELSE
      ASSIGN lv_cPathName   = "":U.
 
   /* always release com objects when done */
   RELEASE OBJECT lv_chFolder NO-ERROR.
   RELEASE OBJECT lv_chShell  NO-ERROR.
 
   RETURN lv_cPathName.
 
END FUNCTION.

BrowseForFolder with an initial folder

Cyril O'Floinn has wrapped function SHBrowseForFolder into a higher-level DLL function, named BrowseForFolder. This has the advantage of being able to specify an initial directory.
The source for this new function is written in Delphi and is added to PROEXTRA.DLL.

The declaration is added to PROEXTRA.P and looks like this:

PROCEDURE BrowseForFolder EXTERNAL {&ProExtra} :
  DEFINE INPUT  PARAMETER hWndOwner       AS LONG.
  DEFINE INPUT  PARAMETER lpTitle         AS CHARACTER.
  DEFINE INPUT  PARAMETER uiFlags         AS LONG.
  DEFINE INPUT  PARAMETER lpInitialFolder AS CHARACTER.
  DEFINE OUTPUT PARAMETER lpFolder        AS CHARACTER.
  DEFINE RETURN PARAMETER BoolRetVal      AS LONG.
END PROCEDURE.

PROEXTRA.DLL and PROEXTRA.P are part of 'everything.zip' November 29, 1998 and can be downloaded from page windows.i and hpApi.
Cyril also made an example procedure, demonstrating the options of this function. This example is attached.

Attachments

folder.w.zip : example

Create Shortcuts

by Todd G. Nist

Program source is available for download: w-createshortcut.p
This program demonstrates how to create a shortcut in Windows and how to modify it. More specifically, the demo will create a folder called "SomeApplication", place a link to a "Readme.txt" file into the folder created, add it to the end users desktop, and create a link to this website under "Favorites".

By using the SHAddToRecentDocs() call, a shortcut can be created on the fly and added to the user's Documents item on the Start menu. Then by using the SHFileOperation function, one can move and rename files or folders across drives. By applying the SHGetSpecialFolderLocation API, we can get the current user's "Special" systems paths - their Start Menu, their Recent Files path, and others.

The code uses SHAddToRecentDocs to create shortcuts, SHGetSpecialFolderLocation to find the appropriate folders for the system, and SHFileOperation to create a folder, move and then rename the shortcuts. The end result is the ability to create any shortcut you want, to any file you want, and place it anywhere on the user's system. The example code does not do all the necessary error checking so if run more then once, you may encounter errors.

API-procedures used in this example are listed here to be included in the search index:
PROCEDURE SHAddToRecentDocs          EXTERNAL "shell32.dll" :
PROCEDURE SHFileOperationA           EXTERNAL "shell32.dll" :
PROCEDURE SHGetPathFromIDListA       EXTERNAL "shell32.dll" :
PROCEDURE SHGetSpecialFolderLocation EXTERNAL "shell32.dll" :
PROCEDURE SHChangeNotify             EXTERNAL "shell32.dll" :
PROCEDURE CoTaskMemFree              EXTERNAL "ole32.dll" :
PROCEDURE GetTempPathA               EXTERNAL "kernel32.dll" :
PROCEDURE Sleep                      EXTERNAL "kernel32.dll" :
PROCEDURE FindClose                  EXTERNAL "kernel32.dll" :
PROCEDURE FindFirstFileA             EXTERNAL "kernel32.dll" :

Attachments

w-createshortcut.p.zip : example

File Summary Info

Hi there,

Working with an NTFS based operating system, I'd like to link so-called "File Summary Information" with our R-Codes (and get the "Summary" tab when accessing the "properties" of a R-Code in the Windows Explorer... just like .DOC, .XLS,... files).

I've seen that we have to use these functions to achieve this:
stgCreateStorageEx (to create a "File Summary Information" structure);
stgOpenStorageEx (to access the structure);
SetFileSummaryInfo (to fill the structure with info).

Does anyone have yet "played" with these functions, or have any advice or sample I can use to set this up?

Thanks in advance,

File Summary Properties

This code was posted to PEG by Jared Middleton.

/*******************************************************************
   Procedure:   shellfile.p
   Description: Demo program to access File Summary Properties
                using Shell FolderItems object GetDetailsOf method.
   Written by:  Jared Middleton  (January 17, 2007)
*******************************************************************/

DEFINE VAR chApp            AS COM-HANDLE NO-UNDO.
DEFINE VAR chFolder         AS COM-HANDLE NO-UNDO.
DEFINE VAR chFolderItem     AS COM-HANDLE NO-UNDO.
DEFINE VAR cFile            AS CHARACTER  NO-UNDO.
DEFINE VAR cDir             AS CHARACTER  NO-UNDO.
DEFINE VAR cBase            AS CHARACTER  NO-UNDO.
DEFINE VAR lOpen            AS LOGICAL    NO-UNDO.
DEFINE VAR cLabel           AS CHARACTER  NO-UNDO FORMAT "x(24)".
DEFINE VAR cValue           AS CHARACTER  NO-UNDO FORMAT "x(50)".

DEFINE FRAME frmDisp
  cLabel
  cValue
  WITH NO-LABELS DOWN.

SYSTEM-DIALOG GET-FILE cFile
   FILTERS
     'All Files (*.*)'          '*.*',
     'MP3 Files (*.mp3)'        '*.mp3',        /* optional */
     'JPG Files (*.jpg,*.jpeg)' '*.jpg,*.jpeg'  /* optional */
   UPDATE lOpen.
IF NOT lOpen THEN RETURN.

CREATE "Shell.Application" chApp NO-ERROR.
IF VALID-HANDLE(chApp) THEN DO:
  ASSIGN cDir  = SUBSTRING(cFile,1,R-INDEX(cFile,"\") - 1)
         cBase = SUBSTRING(cFile,LENGTH(cDir) + 2).
  ASSIGN chFolder = chApp:Namespace(cDir).
  IF VALID-HANDLE(chFolder) THEN DO:
    ASSIGN chFolderItem = chFolder:ParseName(cBase).

    /* Extended File Properties are OS version specific.
       The following are valid for Windows XP/2003 */
    IF VALID-HANDLE(chFolderItem) THEN DO:
      RUN get-item ("File:",0).
      RUN get-item ("Size:",1).
      RUN get-item ("Type:",2).
      RUN get-item ("Title:",10).
      RUN get-item ("Subject:",11).
      RUN get-item ("Category:",12).
      RUN get-item ("Artist:",16).
      RUN get-item ("Album:",17).
      RUN get-item ("Year:",18).
      RUN get-item ("Track:",19).
      RUN get-item ("Genre:",20).
      RUN get-item ("Duration:",21).
      RUN get-item ("Bit Rate:",22).
    /*RUN get-item ("Protected:",23).*/
    /*RUN get-item ("Episode Name:",29).*/
    /*RUN get-item ("Audio Sample Size:",32).*/
      RUN get-item ("Audio Sample Rate:",33).
      RUN get-item ("Channels:",34).
      RUN get-item ("Camera Model:",24).
      RUN get-item ("Date Taken:",25).
    /*RUN get-item ("Dimensions:",26).*/
      RUN get-item ("Width:",27).
      RUN get-item ("Height:",28).
    END.
  END.
END.

RELEASE OBJECT chFolderItem NO-ERROR.
RELEASE OBJECT chFolder     NO-ERROR.
RELEASE OBJECT chApp        NO-ERROR.

PROCEDURE get-item:
  DEFINE INPUT PARAMETER l-cLabel AS CHARACTER NO-UNDO.
  DEFINE INPUT PARAMETER l-cItem  AS INTEGER   NO-UNDO.

  DEFINE VAR l-cValue AS CHARACTER NO-UNDO.

  DO WITH FRAME frmDisp:
    ASSIGN l-cValue = chFolder:GetDetailsOf(chFolderItem,l-cItem).
    IF l-cValue > "" THEN DO:
      DISPLAY l-cLabel @ cLabel
              l-cValue @ cValue.
      DOWN.
    END.
  END.
END PROCEDURE.

/* End of program */

File version information

Most win32 binaries, like executables (exe), dynamic link libraries (dll) and automation controls (ocx) contain a version information structure. The data in this version information structure is used by setup programs to decide if it's ok to overwrite the file.
The version information can also be useful for support engineers for determining why a feature doesn't work as expected. Especially when used in a list of all modules loaded by the current Progress process, see ListModules.
Typically a file contains both a productversion and fileversion. The version info structure may also contain strings describing the file or its publisher, but this textual information is kind of difficult to read because they are grouped together in codepage blocks. Productversion and fileversion are not language specific so these are easier to read.

DEFINE VARIABLE vProductVersion AS CHARACTER NO-UNDO.
DEFINE VARIABLE vFileVersion    AS CHARACTER NO-UNDO.
RUN GetProductVersion ( 'c:\windows\system\mfc42.dll', 
                        OUTPUT vProductVersion,
                        OUTPUT vFileVersion).
MESSAGE vProductVersion SKIP 
        vFileVersion
        VIEW-AS ALERT-BOX.
 
/* shows 6.0.1.0 
         6.0.8267.0 
   on my system. This indicates someone or something installed the 
   runtime modules for MS Visual Studio 6 */

PROCEDURE GetProductVersion :
 
    DEFINE INPUT  PARAMETER pFilename       AS CHARACTER NO-UNDO.
    DEFINE OUTPUT PARAMETER pProductVersion AS CHARACTER NO-UNDO.
    DEFINE OUTPUT PARAMETER pFileVersion    AS CHARACTER NO-UNDO.
 
    DEFINE VARIABLE dummy           AS INTEGER NO-UNDO.
    DEFINE VARIABLE ReturnValue     AS INTEGER NO-UNDO.
    DEFINE VARIABLE lpVersionInfo   AS MEMPTR  NO-UNDO.  /* VS_VERSION_INFO structure  */
    DEFINE VARIABLE lpFixedFileInfo AS MEMPTR  NO-UNDO.  /* VS_FIXEDFILEINFO structure */
    DEFINE VARIABLE versize         AS INTEGER NO-UNDO.  /* size of lpVersionInfo      */
    DEFINE VARIABLE ptrInfo         AS INTEGER NO-UNDO.  /* address of lpFixedFileInfo */
    DEFINE VARIABLE cInfo           AS INTEGER NO-UNDO.  /* size of lpFixedFileInfo    */
 
    RUN GetFileVersionInfoSizeA (pFileName,
                                 OUTPUT dummy,
                                 OUTPUT versize).
 
    IF versize = 0 THEN RETURN.
 
    SET-SIZE(lpVersionInfo) = 0.
    SET-SIZE(lpVersionInfo) = versize.
 
    RUN GetFileVersionInfoA ( pFileName,
                              0,
                              INPUT versize,
                              INPUT GET-POINTER-VALUE(lpVersionInfo),
                              OUTPUT returnvalue).
 
    IF returnvalue = 0 THEN DO:
      SET-SIZE(lpVersionInfo) = 0.
      RETURN.
    END.
 
    RUN VerQueryValueA (GET-POINTER-VALUE(lpVersionInfo),
                        "\":U,
                        OUTPUT ptrInfo,
                        OUTPUT cInfo,
                        OUTPUT returnvalue).
 
    IF NOT (returnvalue=0 OR cInfo=0) THEN DO:
       SET-SIZE(lpFixedFileInfo)          = cInfo.
       SET-POINTER-VALUE(lpFixedFileInfo) = ptrInfo.
 
       pProductVersion =  STRING(GET-SHORT (lpFixedFileInfo,19)) + '.' +
                          STRING(GET-SHORT (lpFixedFileInfo,17)) + '.' +
                          STRING(GET-SHORT (lpFixedFileInfo,23)) + '.' +
                          STRING(GET-SHORT (lpFixedFileInfo,21)).
 
       pFileVersion    =  STRING(GET-SHORT (lpFixedFileInfo,11)) + '.' +
                          STRING(GET-SHORT (lpFixedFileInfo, 9)) + '.' +
                          STRING(GET-SHORT (lpFixedFileInfo,15)) + '.' +
                          STRING(GET-SHORT (lpFixedFileInfo,13)).
 
    END.
 
    SET-SIZE (lpVersionInfo)   = 0.
 
/*  ------ DON'T DO THIS: --------
    SET-SIZE (lpFixedFileInfo) = 0. */
 
END PROCEDURE.

Definitions used in this procedure:

PROCEDURE GetFileVersionInfoSizeA EXTERNAL "version.dll" :
  DEFINE INPUT  PARAMETER lptstrFilename  AS CHARACTER.
  DEFINE OUTPUT PARAMETER lpdwHandle      AS LONG.
  DEFINE RETURN PARAMETER VersionInfoSize AS LONG.
END PROCEDURE.
 
 
PROCEDURE GetFileVersionInfoA EXTERNAL "version.dll" :
  DEFINE INPUT  PARAMETER lptstrFilename  AS CHARACTER.
  DEFINE INPUT  PARAMETER dwHandle        AS LONG.
  DEFINE INPUT  PARAMETER dwLen           AS LONG.
  DEFINE INPUT  PARAMETER lpData          AS LONG.
  DEFINE RETURN PARAMETER ReturnValue     AS LONG.
END PROCEDURE.
 
 
PROCEDURE VerQueryValueA EXTERNAL "version.dll" :
  DEFINE INPUT  PARAMETER lpBlock     AS LONG.
  DEFINE INPUT  PARAMETER lpSubBlock  AS CHARACTER.
  DEFINE OUTPUT PARAMETER lplpBuffer  AS LONG.
  DEFINE OUTPUT PARAMETER puLen       AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.

Format a floppy disk (or hard drive)

by Stuart Morris

This allows you to call a standard system dialog for formatting Floppy disks and Hard drives etc.

/* S.A.Morris - 01/02/2000 */
 
&GLOB SHFD_CAPACITY_DEFAULT 0 /* default drive capacity                 */
&GLOB SHFD_CAPACITY_360     3 /* 360KB, applies to 5.25" drives only    */
&GLOB SHFD_CAPACITY_720     5 /* 720KB, applies to 3.5" drives only     */
&GLOB SHFD_FORMAT_QUICK     0 /* quick format                           */
&GLOB SHFD_FORMAT_FULL      1 /* full format                            */
&GLOB SHFD_FORMAT_SYSONLY   2 /* copies system files only (Win95 Only!) */
 
DEFINE VARIABLE RESULT AS INTEGER NO-UNDO.
 
PROCEDURE SHFormatDrive EXTERNAL "shell32.dll" :
   DEFINE INPUT  PARAM hwndOwner   AS LONG.
   DEFINE INPUT  PARAM iDrive      AS LONG.
   DEFINE INPUT  PARAM iCapacity   AS LONG.
   DEFINE INPUT  PARAM iFormatType AS LONG.
   DEFINE OUTPUT PARAM lpResult    AS LONG.
END PROCEDURE.
 
 
RUN SHFormatDrive (INPUT  CURRENT-WINDOW:HWND,
                          0,  /* Drive A=0, B=1 (if present, otherwise C=1 etc) */
                          {&SHFD_CAPACITY_DEFAULT},
                          {&SHFD_FORMAT_QUICK},
                   OUTPUT RESULT
                  )
                  NO-ERROR. /* Needs this to stop Stack Errors */

GetShortPathName

function GetShortPathName retrieves the 8.3 pathname for an existing long pathname.

 
PROCEDURE GetShortPathNameA EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER  lpszLongPath  AS CHARACTER.
  DEFINE OUTPUT PARAMETER  lpszShortPath AS CHARACTER.
  DEFINE INPUT  PARAMETER  cchBuffer     AS LONG.
  DEFINE RETURN PARAMETER  ReturnValue   AS LONG.
END PROCEDURE.
 
DEFINE VARIABLE longname AS CHARACTER NO-UNDO.
DEFINE VARIABLE shortname AS CHARACTER NO-UNDO.
DEFINE VARIABLE returnvalue AS INTEGER NO-UNDO.
 
&GLOB shortsize 68
 
longname = "C:\Program Files\VendorName\Some Application\Data\Monthly Revenue.txt".
shortname = FILL("-", {&shortsize}).
 
RUN GetShortPathNameA (longname,
                       OUTPUT shortname,
                       LENGTH(shortname),
                       OUTPUT ReturnValue).
 
IF ReturnValue > {&shortsize} THEN 
   MESSAGE "buffer too short, specify at least " ReturnValue.
ELSE 
IF ReturnValue = 0 THEN 
   MESSAGE "file does not exist".
ELSE 
   shortname = ENTRY(1, shortname, CHR(0)).

GetSpecialFolder

  MESSAGE GetSpecialFolder({&CSIDL_SYSTEM}) VIEW-AS ALERT-BOX.

will return "c:\windows\system" or "c:\winnt\system32" or whatever is valid on your PC.
There are different implementations of this function. This page shows one by Stuart Morris and one by Jan Verley.

Using SHGetSpecialFolderLocation

by Stuart Morris, stuart@IBS-PUBLIC-SERVICES.co.uk

PROCEDURE SHGetPathFromIDListA EXTERNAL "shell32.dll":U :
  DEFINE INPUT  PARAMETER pidl    AS  LONG.
  DEFINE OUTPUT PARAMETER pszPath AS  CHARACTER.
  DEFINE RETURN PARAMETER iResult AS  LONG.
END PROCEDURE.       
 
PROCEDURE SHGetSpecialFolderLocation EXTERNAL "shell32.dll":U :
  DEFINE INPUT  PARAMETER hwndOwner AS  LONG.
  DEFINE INPUT  PARAMETER nFolder   AS  LONG.
  DEFINE OUTPUT PARAMETER pidl      AS  LONG.
  DEFINE RETURN PARAMETER iResult   AS  LONG.
END PROCEDURE.
 
PROCEDURE CoTaskMemFree EXTERNAL "ole32.dll":U :
  DEFINE INPUT PARAMETER lpPidl AS LONG.
END PROCEDURE.
 
FUNCTION GetSpecialFolder RETURNS CHARACTER (INPUT iCSIDL AS INT):
/*-----------------------------------------------------------
  Purpose:      
  Notes:  
-------------------------------------------------------------*/
  DEFINE VARIABLE iResult AS INTEGER  NO-UNDO.
  DEFINE VARIABLE cPath   AS CHARACTER NO-UNDO.
  DEFINE VARIABLE pidl    AS INTEGER  NO-UNDO.
 
  RUN SHGetSpecialFolderLocation (INPUT  0,
                                  INPUT  iCSIDL,
                                  OUTPUT pidl,
                                  OUTPUT iResult
                                 ).
 
  IF iResult = 0 THEN DO:    
     cPath = FILL(' ', {&MAX_PATH}).
     RUN SHGetPathFromIDListA(INPUT  pidl,
                              OUTPUT cPath,
                              OUTPUT iResult
                             ).
 
     RUN CoTaskMemFree(INPUT pidl).
 
     IF iResult GT 0 THEN
        RETURN TRIM(cPath) + '\':U.
  END.
 
  RETURN "".   /* Function return value. */
 
END FUNCTION.

Using SHGetFolderPathA

by Jan Verley, jverle@softcell.be

Jan made a similar function, using SHGetFolderPathA in shfolder.dll. SHGetFolderPathA is more programmer-friendly because it simply returns the path as a string, not as as pidl. SHGetFolderPathA is a wrapper to lower-level procedures, it selects the appropriate procedures matching the current Windows version. Another interesting aspect is that this procedure lets you impersonate any user to get his/her personal folders. The downside is that SHGetFolderPathA doesn't support every defined CSIDL.
Info (for Visual Basic programmers) about this on: http:www.mvps.org/vbnet/code/shell/csidl.htm and on http:developer.earthweb.com/journal/techworkshop/020400_vbwin2k.html
Be careful: shfolder.dll may not be available on your target machine. It is a freely redistributable dll and ships with Win2000 and NT4 service pack 4 and later, IE5, Win98 Second Edition and probably ships with other MS products as well.

PROCEDURE SHGetFolderPathA EXTERNAL "shfolder.dll":U :
   DEFINE INPUT  PARAMETER hwndOwner   AS LONG.
   DEFINE INPUT  PARAMETER nFolder     AS LONG.
   DEFINE INPUT  PARAMETER hToken      AS LONG.
   DEFINE INPUT  PARAMETER dwFlags     AS LONG.
   DEFINE OUTPUT PARAMETER pszPath     AS CHARACTER.
   DEFINE RETURN PARAMETER hResult     AS LONG.
END PROCEDURE.
 
FUNCTION GetSpecialFolder RETURNS CHARACTER (INPUT iCSIDL AS INT):
/*-----------------------------------------------------------
  Purpose:      
  Notes:  
-------------------------------------------------------------*/
  DEFINE VARIABLE op_dir      AS CHARACTER NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER   NO-UNDO.
 
  ASSIGN op_dir = FILL (" " ,{&MAX_PATH}).
  RUN SHGetFolderPathA (INPUT  0, 
                        INPUT  iCSIDL, 
                        INPUT  0, 
                        INPUT  0, 
                        OUTPUT op_dir,
                        OUTPUT ReturnValue).
  RETURN TRIM(op_dir).
 
END FUNCTION.

Definitions

Constants used in this example, and a few more. This is a subset from te list in [[winconst]] wikilink.zip.

&GLOBAL-DEFINE CSIDL_ADMINTOOLS 48
&GLOBAL-DEFINE CSIDL_ALTSTARTUP 29
&GLOBAL-DEFINE CSIDL_APPDATA 26
&GLOBAL-DEFINE CSIDL_BITBUCKET 10
&GLOBAL-DEFINE CSIDL_COMMON_ADMINTOOLS 47
&GLOBAL-DEFINE CSIDL_COMMON_ALTSTARTUP 30
&GLOBAL-DEFINE CSIDL_COMMON_DESKTOPDIRECTORY 25
&GLOBAL-DEFINE CSIDL_COMMON_DOCUMENTS 46
&GLOBAL-DEFINE CSIDL_COMMON_FAVORITES 31
&GLOBAL-DEFINE CSIDL_COMMON_PROGRAMS 23
&GLOBAL-DEFINE CSIDL_COMMON_STARTMENU 22
&GLOBAL-DEFINE CSIDL_COMMON_STARTUP 24
&GLOBAL-DEFINE CSIDL_COMMON_TEMPLATES 45
&GLOBAL-DEFINE CSIDL_CONTROLS 3
&GLOBAL-DEFINE CSIDL_COOKIES 33
&GLOBAL-DEFINE CSIDL_DESKTOP 0
&GLOBAL-DEFINE CSIDL_DESKTOPDIRECTORY 16
&GLOBAL-DEFINE CSIDL_DRIVES 17
&GLOBAL-DEFINE CSIDL_FAVORITES 6
&GLOBAL-DEFINE CSIDL_FONTS 20
&GLOBAL-DEFINE CSIDL_HISTORY 34
&GLOBAL-DEFINE CSIDL_INTERNET 1
&GLOBAL-DEFINE CSIDL_INTERNET_CACHE 32
&GLOBAL-DEFINE CSIDL_LOCAL_APPDATA 28
&GLOBAL-DEFINE CSIDL_MYPICTURES 39
&GLOBAL-DEFINE CSIDL_NETHOOD 19
&GLOBAL-DEFINE CSIDL_NETWORK 18
&GLOBAL-DEFINE CSIDL_PERSONAL 5
&GLOBAL-DEFINE CSIDL_PRINTERS 4
&GLOBAL-DEFINE CSIDL_PRINTHOOD 27
&GLOBAL-DEFINE CSIDL_PROFILE 40
&GLOBAL-DEFINE CSIDL_PROGRAMS 2
&GLOBAL-DEFINE CSIDL_PROGRAM_FILES 38
&GLOBAL-DEFINE CSIDL_PROGRAM_FILESX86 42
&GLOBAL-DEFINE CSIDL_PROGRAM_FILES_COMMON 43
&GLOBAL-DEFINE CSIDL_PROGRAM_FILES_COMMONX86 44
&GLOBAL-DEFINE CSIDL_RECENT 8
&GLOBAL-DEFINE CSIDL_SENDTO 9
&GLOBAL-DEFINE CSIDL_STARTMENU 11
&GLOBAL-DEFINE CSIDL_STARTUP 7
&GLOBAL-DEFINE CSIDL_SYSTEM 37
&GLOBAL-DEFINE CSIDL_SYSTEMX86 41
&GLOBAL-DEFINE CSIDL_TEMPLATES 21
&GLOBAL-DEFINE CSIDL_WINDOWS 36
 
&GLOBAL-DEFINE CSIDL_FLAG_CREATE 32768
&GLOBAL-DEFINE CSIDL_FLAG_DONT_VERIFY 16384
&GLOBAL-DEFINE CSIDL_FLAG_MASK 65280
 
&GLOBAL-DEFINE MAX_PATH 260

Getting file and directory information

This page explains how to find the size (in bytes) of a certain file, the long and short filenames, the date and time a file was last modified. It also shows a way to get a directory listing.
This is based on a rather large procedure library, file-api.p and file-api.i, which are available in everything.zip in page windows.i and hpApi

Using the library

To use any of the functions in library file-api.p simply include {file-api.i} in the definitions section of your program. This will define some constants you might want to use and it runs file-api.p persistent in handle hpFileApi.

Organisation of the library

The library file-api.p defines a couple of API functions but you will probably not run these directly. Instead, you will probably run one of the 4GL internal procedures in there.
The procedures work with a memptr to a WIN32_FIND_DATA structure. So the procedures will either have an output parameter or an input parameter of this type. You don't have to allocate or fill this structure or fetch information from it; this is all done by the procedures themselves.

File Information

Here's an example of getting information about file "c:\autoexec.bat" :

{file-api.i}
 
DEFINE VARIABLE lpFindData AS MEMPTR.
 
DEFINE VARIABLE longname AS CHARACTER.
DEFINE VARIABLE shortname AS CHARACTER.
DEFINE VARIABLE SIZE AS INTEGER.
DEFINE VARIABLE chDate AS DATE.
DEFINE VARIABLE chTime AS INTEGER.
 
/* get a lpFindData structure */
RUN FileFind IN hpFileApi ("c:\autoexec.bat", OUTPUT lpFindData).
 
/* read information from the lpFileInfo structure */
RUN FileInfo_LongName  IN hpFileApi(lpFindData, OUTPUT longname).
RUN FileInfo_ShortName IN hpFileApi(lpFindData, OUTPUT shortname).
RUN FileInfo_Size      IN hpFileApi(lpFindData, OUTPUT SIZE).
RUN FileInfo_LastWrite IN hpFileApi(lpFindData, OUTPUT chDate, OUTPUT chTime).
 
MESSAGE 
 "name="       longname SKIP
 "short name=" shortname SKIP
 "modified="   chDate STRING(chTime,"hh:mm:ss") SKIP
 "size="       SIZE " bytes"
 VIEW-AS ALERT-BOX.

Directory listing

The general idea is: find the first file in the directory and repeat to find the next file until no more files are found. This loop is performed by the procedure FileFindLoop in file-api.p. Whenever it finds a file, it runs an internal procedure you specified with an lpFindData pointer as input parameter. Example:

{file-api.i}
 
RUN FileFindLoop IN hpFileApi ("d:\progress\*.p",      /* mask, must contain wildcards */
                               "ProcessOneFile",       /* name of callback procedure   */
                               THIS-PROCEDURE:HANDLE). /* location of callback proc    */
 
PROCEDURE ProcessOneFile :
  DEFINE INPUT PARAMETER lpFindData AS MEMPTR.
 
  /* do whatever you like here, for example show the file name
     if modified within last 3 days */
  DEFINE VARIABLE longname AS CHARACTER NO-UNDO.
  DEFINE VARIABLE chDate AS DATE NO-UNDO.
  DEFINE VARIABLE chTime AS INTEGER NO-UNDO.
  RUN FileInfo_LongName  IN hpFileApi(lpFindData, OUTPUT longname).
  RUN FileInfo_LastWrite IN hpFileApi(lpFindData, OUTPUT chDate, OUTPUT chTime).
  IF chDate> TODAY - 3 THEN 
     MESSAGE longname VIEW-AS ALERT-BOX.
 
END PROCEDURE.

Testing file attributes

The callback procedure in the above example will be called for every file that meets the mask, these can include files or (sub)directories. Often you will want to show only directories, or only files, or only files that have the Archive-bit set, or skip all hidden and system files. Whatever. In those cases you will need to test the file attributes during the callback function.
File attributes are one DWORD where each bit represents one certain attribute. The attributes are stored in the first element of the lpFindData structure, the meaning of the different bits is listed in file-api.i for your convenience. To test for the presence of a certain bit you must use binary logic (the AND), covered on page "Bitwise operators using ProExtra.DLL".
So if you want to make sure if a file is actually a directory, you would include a test like this:

{file-api.i}
 
PROCEDURE ProcessOneFile :
  DEFINE INPUT PARAMETER lpFindData AS MEMPTR.
 
  DEFINE VARIABLE attribs AS INTEGER NO-UNDO.
  DEFINE VARIABLE RESULT  AS INTEGER NO-UNDO.
  attribs = GET-LONG(lpFindData,1).
  RUN Bit_And IN hpExtra(attribs, {&DDL_DIRECTORY}, OUTPUT RESULT).
  IF result NE 0 THEN DO:
     /* whatever you want to do with a directory */
  END.
  ELSE DO:
     /* whatever you want to do with a file */
  END.
 
END PROCEDURE.

Note that flag DDL_READWRITE has value 0. This is a brain teaser: it can't be set, so you can't test for its presence! The definition says: a file is READWRITE unless any other bit is set. In other words: you don't use Bit_And() to test if attribs contains DDL_READWRITE, but you simply test if attribs=DDL_READWRITE.

Local name to UNC name

by Michael Rüsweg-Gilbert

Procedure WNetGetConnection retrieves the name of the network resource associated with a local device. In other words, it can be used to get the UNC name for a mapped network drive or printer. If K: is the drive letter of a mapped network drive, the following example finds the UNC name for this network drive.

DEFINE VARIABLE Drive_Name AS CHARACTER NO-UNDO INIT "K:".
DEFINE VARIABLE UNC_Name AS CHARACTER NO-UNDO.
 
DEFINE VARIABLE namelen AS INTEGER NO-UNDO INITIAL 100.
DEFINE VARIABLE retBool AS INTEGER NO-UNDO.
 
UNC_Name = FILL("x",namelen).
RUN WNetGetConnectionA ( Drive_Name,
                   OUTPUT UNC_Name,
                   INPUT-OUTPUT namelen,
                   OUTPUT retBool).
 
IF retBool = 0 THEN
   UNC_Name = SUBSTRING(UNC_Name, 1, namelen).
ELSE
   UNC_Name = "".
 
MESSAGE
    UNC_Name
    VIEW-AS ALERT-BOX.

API definitions used in this exampe, not listed in windows.p :

PROCEDURE WNetGetConnectionA EXTERNAL "mpr.dll" :
  DEFINE INPUT        PARAMETER lpDrive    AS CHARACTER.
  DEFINE OUTPUT       PARAMETER lpUNCName  AS CHARACTER.
  DEFINE INPUT-OUTPUT PARAMETER lpnLength  AS LONG.
  DEFINE RETURN       PARAMETER RetBool    AS LONG.
END PROCEDURE.

Locking a file

Code found in an e-mail to Peg, send by by Jeffrey L. Boyer

Sometimes you want to read a file and be sure that nobody else is writing to the file in the meantime. So you want to lock it for writing.

&GLOBAL-DEFINE GENERIC_WRITE 1073741824   /* &H40000000 */
&GLOBAL-DEFINE OPEN_EXISTING 3
&GLOBAL-DEFINE FILE_SHARE_READ 1                  /* = &H1 */
&GLOBAL-DEFINE FILE_ATTRIBUTE_NORMAL 128       /* = &H80 */

PROCEDURE CreateFileA EXTERNAL "kernel32":
    DEFINE INPUT PARAMETER lpFileName AS CHARACTER.
    DEFINE INPUT PARAMETER dwDesiredAccess AS LONG.
    DEFINE INPUT PARAMETER dwShareMode AS LONG.
    DEFINE INPUT PARAMETER lpSecurityAttributes AS LONG.
    DEFINE INPUT PARAMETER dwCreationDisposition AS LONG.
    DEFINE INPUT PARAMETER dwFlagsAndAttributes AS LONG.
    DEFINE INPUT PARAMETER hTemplateFile AS LONG.
    DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.

PROCEDURE CloseHandle EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER hObject     AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.

DEFINE VARIABLE lpSecurityAtt AS INTEGER NO-UNDO.
DEFINE VARIABLE hObject AS INTEGER NO-UNDO.
DEFINE VARIABLE nReturn AS INTEGER NO-UNDO.

/* Lock file agains writing */
RUN CreateFileA (INPUT source.txt, 
                 INPUT {&GENERIC_WRITE}, 
                 {&FILE_SHARE_READ},
                 lpSecurityAtt, 
                 {&OPEN_EXISTING},
                 {&FILE_ATTRIBUTE_NORMAL},
                 0,
                 OUTPUT hObject).

input from source.txt.
repeat:
  import aline.
  /* do stuff */
end.
input close.

/* Release file handle */
RUN CloseHandle (INPUT hObject, 
                 OUTPUT nReturn).

Reading and setting file attributes

Let's start with a couple of definitions:

&GLOBAL-DEFINE FILE_ATTRIBUTE_READONLY 1
&GLOBAL-DEFINE FILE_ATTRIBUTE_HIDDEN 2
&GLOBAL-DEFINE FILE_ATTRIBUTE_SYSTEM 4
&GLOBAL-DEFINE FILE_ATTRIBUTE_DIRECTORY 16
&GLOBAL-DEFINE FILE_ATTRIBUTE_ARCHIVE 32
&GLOBAL-DEFINE FILE_ATTRIBUTE_NORMAL 128
&GLOBAL-DEFINE FILE_ATTRIBUTE_COMPRESSED 2048
 
PROCEDURE SetFileAttributesA EXTERNAL "kernel32" :
   DEFINE INPUT PARAMETER lpFilename AS CHARACTER.
   DEFINE INPUT PARAMETER dwFileAttributes AS LONG.
END.
 
PROCEDURE GetFileAttributesA EXTERNAL "kernel32" :
   DEFINE INPUT PARAMETER lpFilename AS CHARACTER.
   DEFINE RETURN PARAMETER dwFileAttributes AS LONG.
END.

The first example shows how to make a file read-only. It also clears most of the existing attributes because only one attribute is specified.

RUN SetFileAttributesA ( "c:\autoexec.bat", {&FILE_ATTRIBUTE_READONLY} ).

(Specify FILE_ATTRIBUTE_NORMAL to clear all attributes.)
The next example makes the file read-only and leaves the existing attributes intact.

DEFINE VARIABLE lv_attribs AS INTEGER NO-UNDO.
 
RUN GetFileAttributesA ( "c:\autoexec.bat", OUTPUT lv-attribs ).
/* if lv-attribs does not include {&FILE_ATTRIBUTE_READONLY} then */
RUN SetFileAttributesA ( "c:\autoexec.bat", lv-attribs + {&FILE_ATTRIBUTE_READONLY}).

The commented line should be replaced by an actual IF-statement. You can use procedure CheckOneAttribute by Dmitri, or a variant of his procedure, to test if the file already has the attribute set.

/* by Dmitri Levin, dlevin@ryland.com */
DEFINE VARIABLE lv-filename     AS CHARACTER INIT "c:\autoexec.bat" NO-UNDO.
DEFINE VARIABLE lv-attribs      AS INTEGER NO-UNDO.
DEFINE VARIABLE lv-attribs-list AS CHARACTER NO-UNDO.
 
RUN GetFileAttributesA ( lv-filename, OUTPUT lv-attribs ).
 
RUN CheckOneAttribute( lv-attribs, 
                       {&FILE_ATTRIBUTE_READONLY},  
                       "READONLY",
                       INPUT-OUTPUT lv-attribs-list).
RUN CheckOneAttribute( lv-attribs, 
                       {&FILE_ATTRIBUTE_HIDDEN},    
                       "HIDDEN",
                       INPUT-OUTPUT lv-attribs-list).
RUN CheckOneAttribute( lv-attribs, 
                       {&FILE_ATTRIBUTE_SYSTEM},    
                       "SYSTEM",
                       INPUT-OUTPUT lv-attribs-list).
RUN CheckOneAttribute( lv-attribs, 
                       {&FILE_ATTRIBUTE_DIRECTORY}, 
                       "DIRECTORY",
                       INPUT-OUTPUT lv-attribs-list).
RUN CheckOneAttribute( lv-attribs, 
                       {&FILE_ATTRIBUTE_ARCHIVE},   
                       "ARCHIVE",
                       INPUT-OUTPUT lv-attribs-list).
 
MESSAGE "File Attributes:" lv-attribs-list VIEW-AS ALERT-BOX.
 
PROCEDURE CheckOneAttribute :
  DEFINE INPUT PARAMETER lp-attribs  AS INTEGER NO-UNDO.
  DEFINE INPUT PARAMETER lp-attrib-num  AS INTEGER NO-UNDO.
  DEFINE INPUT PARAMETER lp-attrib-name  AS CHARACTER NO-UNDO.
  DEFINE INPUT-OUTPUT PARAMETER lp-attrib-list  AS CHARACTER NO-UNDO.
 
  IF lp-attribs MOD ( lp-attrib-num * 2 ) GE lp-attrib-num THEN
     lp-attrib-list = lp-attrib-list + MIN(lp-attrib-list,", ") + lp-attrib-name.
END.

Select a filename using the SHAutoComplete feature

by Simon Sweetman

This is a demo program that uses SHAutoComplete from shlwapi.dll to enable the Windows filename auto complete (like the Win2K file-open dialog) on an editor field, the same call can be used on a fill-in but it doesn?t work real well with progress. The editor version works fine except for TAB and BACK-TAB which seem to be trapped by SHAutoComplete before they get to progress.

Attachments

autocomp.w.zip

Select multiple files

by Scott Anderson, Stuart Morris and Jurjen
"SYSTEM-DIALOG GET-FILE" allows to select only one filename. When you want to select multiple filenames you can call API function GetOpenFileNameA, specifying the OFN_ALLOWMULTISELECT flag.
Procedure SelectMultipleFileNames uses GetOpenFileNameA for the purpose of selecting multiple filenames. The first listing shows how to call the procedure, the second listing shows the implementation of the procedure.
The parameters are:
* FilterList
a list of filters separated by 'pipe'-symbols ( "|" ). Each individual filter is a description, followed by a pipe-symbol, followed by a semicolon-separated list of wildcards. The format of the description is not important but by convention it should be a text followed by the list of wildcards between brackets. The first filter is the default.
* InitialDirectory
Name of the directory where you want to the dialog to start. Specify the unknown value (?) to start in the current directory.
* DialogTitle
Specifies the title for the dialog.
* FileNames
returns a comma-separated list of selected filenames unless OK=FALSE.
* OK
returns FALSE if the user selected the Cancel button.

DEFINE VARIABLE lv-Files AS CHARACTER NO-UNDO.
DEFINE VARIABLE OK       AS LOGICAL   NO-UNDO.
 
RUN SelectMultipleFileNames (INPUT "Word Documents (*.doc,*.rtf)|*.doc;*.rtf" + "|" +
                                   "Excel Worksheets (*.xls)|*.xls"           + "|" +
                                   "Access Databases (*.mdb)|*.mdb"           + "|" +
                                   "All (doc,rtf,xls,mdb,ppt)|*.doc;*.rtf;*.xls;*.mdb;*.ppt",
                             INPUT "C:\My Documents",
                             INPUT "Select one or more Office documents",
                             OUTPUT lv-Files,
                             OUTPUT OK
                            ).
 
IF OK THEN 
   MESSAGE "you selected these files:" SKIP
           lv-Files 
           VIEW-AS ALERT-BOX.
ELSE
   MESSAGE "you pressed Cancel" VIEW-AS ALERT-BOX.

&GLOBAL-DEFINE OFN_OVERWRITEPROMPT  2
&GLOBAL-DEFINE OFN_HIDEREADONLY     4
&GLOBAL-DEFINE OFN_NOCHANGEDIR      8
&GLOBAL-DEFINE OFN_ALLOWMULTISELECT 512
&GLOBAL-DEFINE OFN_PATHMUSTEXIST    2048
&GLOBAL-DEFINE OFN_FILEMUSTEXIST    4096
&GLOBAL-DEFINE OFN_NOREADONLYRETURN 32768
&GLOBAL-DEFINE OFN_EXPLORER         524288
 
PROCEDURE GetOpenFileNameA EXTERNAL "comdlg32.dll" :
  DEFINE INPUT  PARAMETER lpOfn   AS LONG.
  DEFINE RETURN PARAMETER pReturn AS LONG.
END PROCEDURE.
 
 
PROCEDURE SelectMultipleFileNames :
/*------------------------------------------------------------------------------
  Purpose:     Replaces the SYSTEM-DIALOG-GET-FILE common dialog,
               supports multiselect.
  Parameters:
------------------------------------------------------------------------------*/
  DEFINE INPUT  PARAMETER FilterList       AS CHARACTER NO-UNDO.
  DEFINE INPUT  PARAMETER InitialDirectory AS CHARACTER NO-UNDO.
  DEFINE INPUT  PARAMETER DialogTitle      AS CHARACTER NO-UNDO.
  DEFINE OUTPUT PARAMETER FileNames        AS CHARACTER NO-UNDO.
  DEFINE OUTPUT PARAMETER OK               AS INTEGER   NO-UNDO.
 
  DEFINE VARIABLE Flags           AS INTEGER NO-UNDO.
  DEFINE VARIABLE lpOfn           AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE lpstrFilter     AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE lpstrTitle      AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE lpstrInitialDir AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE lpstrFile       AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE offset          AS INTEGER NO-UNDO.
 
  /* Flags controls the behaviour and appearance of the dialog-box. 
           There is much room for experiments. This combination works nice: */
  Flags = {&OFN_ALLOWMULTISELECT} + 
          {&OFN_EXPLORER} + 
          {&OFN_NOCHANGEDIR}.
 
  /* convert the "|"-separated list of filters to a CHR(0)-separated 
     list and make sure it's terminated with a double CHR(0): */
  FilterList = TRIM(FilterList,"|") + "|". /* this will cause the double CHR(0) */
  SET-SIZE(lpstrFilter)      = LENGTH(FilterList) + 1.
  PUT-STRING(lpstrFilter, 1) = FilterList.
  DO offset=1 TO GET-SIZE(lpstrFilter) :
     IF GET-BYTE(lpstrFilter,offset)=124 /* =ASC("|") */ THEN 
        PUT-BYTE(lpstrFilter,offset)=0.
  END.
 
  /* get memory-pointers to the string parameters: */
  SET-SIZE(lpstrFile)   = 1024. /* room for a couple of files...     */
  PUT-BYTE(lpstrFile,1) = 0.    /* don't initialize dialog to a file */
 
  SET-SIZE(lpstrTitle) = LENGTH(DialogTitle) + 1.
  PUT-STRING(lpstrTitle,1) = DialogTitle.
 
  IF InitialDirectory NE ? THEN DO:
     SET-SIZE(lpstrInitialDir) = LENGTH(InitialDirectory) + 1.
     PUT-STRING(lpstrInitialDir,1) = InitialDirectory.
  END.
 
  /* create and initialize an OPENFILENAME structure: */
  SET-SIZE(lpOfn) = 76. /* = {&OPENFILENAME_SIZE_VERSION_400} 
                             to be used in NT4 and Windows 95/98. 
                             Windows 2000 supports a couple more fields. */
 
/* size */              PUT-LONG (lpOfn, 1) = GET-SIZE(lpOfn).
/* hwndOwner */         PUT-LONG (lpOfn, 5) = CURRENT-WINDOW:HWND.
/* hInstance */         PUT-LONG (lpOfn, 9) = 0.
/* lpstrFilter */       PUT-LONG (lpOfn,13) = GET-POINTER-VALUE(lpstrFilter).
/* lpstrCustomFilter */ PUT-LONG (lpOfn,17) = 0.
/* nMaxCustFilter */    PUT-LONG (lpOfn,21) = 0.
/* nFilterIndex */      PUT-LONG (lpOfn,25) = 0.
/* lpstrFile */         PUT-LONG (lpOfn,29) = GET-POINTER-VALUE(lpstrFile).
/* nMaxFile */          PUT-LONG (lpOfn,33) = GET-SIZE(lpstrFile).
/* lpstrFileTitle */    PUT-LONG (lpOfn,37) = 0.
/* nMaxFileTitle */     PUT-LONG (lpOfn,41) = 0.
/* lpstrInitialDir */   PUT-LONG (lpOfn,45) = GET-POINTER-VALUE(lpstrInitialDir).
/* lpstrTitle */        PUT-LONG (lpOfn,49) = GET-POINTER-VALUE(lpstrTitle).
/* flags */             PUT-LONG (lpOfn,53) = Flags.
 
/* nFileOffset */       PUT-SHORT(lpOfn,57) = 0.
/* nFileExtension */    PUT-SHORT(lpOfn,59) = 0.
/* lpstrDefExt */       PUT-LONG (lpOfn,61) = 0.
/* lCustData */         PUT-LONG (lpOfn,65) = 0.
/* lpfnHook */          PUT-LONG (lpOfn,69) = 0.
/* lpTemplateName */    PUT-LONG (lpOfn,73) = 0.
 
  /* run the dialog: */
  RUN GetOpenFileNameA (GET-POINTER-VALUE(lpOfn), OUTPUT OK).
 
  /* release memory: */
  SET-SIZE(lpstrFilter)     = 0.
  SET-SIZE(lpOfn)           = 0.
  SET-SIZE(lpstrTitle)      = 0.
  SET-SIZE(lpstrInitialDir) = 0.
 
  /* lpstrFilter now contains a path, followed by CHR(0), followed 
     by a CHR(0)-separated list of filenames, terminated by a double CHR(0). 
     Unless the user selected only one file: then lpstrFilter will simply
     contain the fully-qualified filename.
     Either way, let's convert the result to a comma-separated list of 
     fully-qualified filenames: */
 
  IF OK NE 0 THEN DO:
    DEFINE VARIABLE cPath AS CHARACTER NO-UNDO.
    DEFINE VARIABLE cList AS CHARACTER NO-UNDO.
    DEFINE VARIABLE cFile AS CHARACTER NO-UNDO.
 
    ASSIGN cPath  = GET-STRING(lpstrFile,1)
           offset = LENGTH(cPath) + 2.
 
    REPEAT:
      cFile = GET-STRING(lpstrFile, offset).
      IF cFile = "" THEN LEAVE.
      ASSIGN cList  = cList + ',' + cPath +  '\' + cFile
             offset = offset + LENGTH(cFile) + 1.
    END.
    ASSIGN cList     = TRIM(cList, ",")
           FileNames = IF cList = "" THEN cPath ELSE cList.
  END.
 
  SET-SIZE(lpstrFile) = 0.
 
END PROCEDURE. /* SelectMultipleFileNames */

SHFileOperation

by Todd G. Nist

Program source is available for download: w-SHFileOp.p
By calling SHFileOperation, one can leverage the existing dialogs for moving files and providing user feed back as to the status of the process all with just one call. It is a fairly simple demo, where it will ask for a directory to be copied, accepting wild cards, a destination directory, a delete directory file specification and a title for the dialog box. Then by invoking the call to SHFileOperation the standard windows dialog box showing the folders and the flying documents will be displayed, this is making the assumption that the information being copied is large enough to allow the dialog to be created. Also, if the files already exist, it will bring up the standard dialog asking if you wish to over write, the size of the file and the date of the files in question. Finally, if delete files is chosen, it will remove the files from the "delete file spec" and bring up the same general dialogs.
To test just make sure you are coping a large file or directory structure. Once it has completed, choose "copy files" again and you should see all the standard dialogs. Finally, specify a delete file spec and choose "delete files".

API-procedures used in this example are listed here to be included in the search index: 
PROCEDURE SHFileOperationA EXTERNAL "Shell32.dll":
PROCEDURE FormatMessageA   EXTERNAL "kernel32.dll":

Attachments

w-shfileop.p.zip : example

Watched folder

by Gordon Campbell

I created a test program that illustrates how to 'watch a folder' in MS
Windows.  The code can be downloaded at:
http://www.epro-sys.com/samples/watchfolder.w
The sample watches a directory called c:\watch\in and via an IP
(ProcessFile) moves the contents to c:\watch\out.
The ProcessFile IP can be modified to process a file in the 'in' directory.
You could use this to automate conversion of text files to PDF via
PDFinclude or automate the sending of documents to e-mail addresses .... or
whatever automated process you would consider when dealing with a file.
Later,
Gordon Campbell
WIKA Instruments Ltd.

Functions

This source code example uses the following Win32 API functions:
* FindFirstChangeNotificationA
* FindCloseChangeNotification
* FindNextChangeNotification
* WaitForSingleObject

notes

Just to be on the safe side, I have also attached a copy of his source code:

Attachments

watchfolder.w.zip : original from Gordon Campbell

Calling HTML-Help

WinHelp is history... HTML Help is the future. The API for HTML Help is implemented in hhctrl.ocx (don't let the filename fool you; the ocx contains both an ActiveX control and API functions). First let's take a look at the definition:

&GLOBAL-DEFINE HH_DISPLAY_TOPIC 0
&GLOBAL-DEFINE HH_KEYWORD_LOOKUP 13
&GLOBAL-DEFINE HH_DISPLAY_TEXT_POPUP 14
 
PROCEDURE HtmlHelpA EXTERNAL "hhctrl.ocx" PERSISTENT :
   DEFINE INPUT PARAMETER  hwndCaller AS LONG.
   DEFINE INPUT PARAMETER  pszFile    AS CHARACTER.
   DEFINE INPUT PARAMETER  uCommand   AS LONG.
   DEFINE INPUT PARAMETER  dwData     AS LONG.
   DEFINE RETURN PARAMETER hwndHelp   AS LONG.
END PROCEDURE.

Notice the **PERSISTENT** keyword: it is required for this function!
hwndCaller is the HWND of the calling window. The help-window stays on top of this calling window. You can specify hwndCaller=0 if you don't like that stay-on-top behaviour.
pszFile is (depending on uCommand) the name of the helpfile, combined with the name of the topic file, combined with the name of the window class in which you want to show the topic. For example "apisite.chm::/playsounda.html>mainwin".
pszFile can also be used to specify the text to show in a popup-window (if uCommand is HH_DISPLAY_TEXT_POPUP) as demonstrated on the next page, Popup windows from HTML Help

pszFile can also be NULL for some values of uCommand. That is going to be a problem in the way I defined the function using a CHAR parameter.
uCommand specifies what the function is supposed to do; examples follow.
dwData depends on uCommand, it is most often a pointer to some structure or simply NULL.
hwndHelp (the return parameter) is the HWND of the created help window. It can be used for manipulating the help window from within your application.
The following example opens helpfile apisite.chm and navigates to a specific topic file (playsounda.html).

RUN ShowHelpTopic ( FRAME {&FRAME-NAME}:HANDLE,
                    "PlaySoundA").
 
PROCEDURE ShowHelpTopic :
  DEFINE INPUT PARAMETER hParent  AS HANDLE  NO-UNDO.
  DEFINE INPUT PARAMETER cTopic   AS CHARACTER    NO-UNDO.
 
  DEFINE VARIABLE        hWndHelp AS INTEGER NO-UNDO.
 
  IF NOT VALID-HANDLE(hParent) THEN 
     hParent = CURRENT-WINDOW:HANDLE.
 
  IF cTopic NE '' THEN 
     cTopic = "::/" + cTopic + ".html".
 
  RUN HtmlHelpA( hParent:HWND , 
                 "apisite.chm" + cTopic, 
                 {&HH_DISPLAY_TOPIC},
                 0, 
                 OUTPUT hWndHelp).
END PROCEDURE.

The next example uses keyword lookup. The input parameter is a ";" separated list of keywords. Keyword lookup is case sensitive!! If exactly one matching topic is found it will immediately be shown. If more than one match is found you will get to see a menu.
What happens if no matches are found? Well, that depends on the members in the lpHH_AKLINK structure. This example is set to open the helpfile and show the "Index" tab. It could also have been set to go to a specific topic (using the pszUrl field) or to show a messagebox (using pszMsgText and pszMsgTitle)

 
RUN ShowHelpKeyword ( FRAME {&FRAME-NAME}:HANDLE,
                      "BrowseForFolder;SHBrowseForFolder").
 
PROCEDURE ShowHelpKeyword :
  DEFINE INPUT PARAMETER hParent   AS HANDLE  NO-UNDO.
  DEFINE INPUT PARAMETER cKeywords AS CHARACTER    NO-UNDO.
 
  DEFINE VARIABLE        hWndHelp    AS INTEGER NO-UNDO.
  DEFINE VARIABLE        lpKeywords  AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE        lpHH_AKLINK AS MEMPTR  NO-UNDO.
 
  IF cKeywords="" THEN RETURN.
 
  IF NOT VALID-HANDLE(hParent) THEN 
     hParent = CURRENT-WINDOW:HANDLE.
 
  /* first use HH_DISPLAY_TOPIC to initialize the help window */
  RUN ShowHelpTopic (hParent, "").
  /* should really check if this succeeded.... */
 
  /* if succeeded then use HH_KEYWORD_LOOKUP */
  SET-SIZE (lpKeywords)     = LENGTH(cKeywords) + 2.
  PUT-STRING(lpKeywords, 1) = cKeywords.
 
  SET-SIZE (lpHH_AKLINK)    = 32.
  PUT-LONG (lpHH_AKLINK, 1) = GET-SIZE(lpHH_AKLINK).
  PUT-LONG (lpHH_AKLINK, 5) = INT(FALSE). /* reserved, always FALSE */
  PUT-LONG (lpHH_AKLINK, 9) = GET-POINTER-VALUE(lpKeywords).
  PUT-LONG (lpHH_AKLINK,13) = 0.          /* pszUrl      */
  PUT-LONG (lpHH_AKLINK,17) = 0.          /* pszMsgText  */
  PUT-LONG (lpHH_AKLINK,21) = 0.          /* pszMsgTitle */
  PUT-LONG (lpHH_AKLINK,25) = 0.          /* pszWindow   */
  PUT-LONG (lpHH_AKLINK,29) = INT(TRUE).  /* fIndexOnFail */
 
  RUN HtmlHelpA( hParent:HWND , 
                 "apisite.chm", 
                 {&HH_KEYWORD_LOOKUP},
                 GET-POINTER-VALUE(lpHH_AKLINK), 
                 OUTPUT hWndHelp).
 
  SET-SIZE (lpHH_AKLINK) = 0.
  SET-SIZE (lpKeywords) = 0.
 
END PROCEDURE.

Popup windows from HTML Help

The previous topic calling HTML Help described how to call HtmlHelp to show a normal HTML topic. Here is how to use HtmlHelp to show a popup or contexthelp-window.

The declaration for the HtmlHelp function is now slightly different: pszFile is now declared as a LONG parameter because we will have to pass it the NULL value. This is the new declaration:

&GLOBAL-DEFINE HH_DISPLAY_TEXT_POPUP 14
 
PROCEDURE HtmlHelpA EXTERNAL "hhctrl.ocx" PERSISTENT :
   DEFINE INPUT PARAMETER  hwndCaller AS LONG.
   DEFINE INPUT PARAMETER  pszFile    AS LONG.
   DEFINE INPUT PARAMETER  uCommand   AS LONG.
   DEFINE INPUT PARAMETER  dwData     AS LONG.
   DEFINE RETURN PARAMETER hwndHelp   AS LONG.
END PROCEDURE.

There are at least two different ways to create a popup. The first way does not need a CHM file: you can simply pass the string you want to show. The second way uses a CHM file which contains a list of strings.
Procedure HHPopupString in the following example creates a popup containing a specified string, positioned near a specified Progress widget.

{windows.i}
 
RUN HHPopupString (FILL-IN-1:HANDLE,
                   "This is the text that will be shown in the popup window").
 
PROCEDURE HHPopupString :
 
  DEFINE INPUT PARAMETER phWidget AS WIDGET-HANDLE NO-UNDO.
  DEFINE INPUT PARAMETER pText    AS CHARACTER          NO-UNDO.
 
  DEFINE VARIABLE FontSpec AS CHARACTER.
  DEFINE VARIABLE HH_POPUP AS MEMPTR.
  DEFINE VARIABLE lpText   AS MEMPTR.
  DEFINE VARIABLE lpFont   AS MEMPTR.
  DEFINE VARIABLE lpPoint  AS MEMPTR.
  DEFINE VARIABLE retval   AS INTEGER NO-UNDO.
 
  SET-SIZE (lpText)    = LENGTH(pText) + 1.
  PUT-STRING(lpText,1) = pText.
 
  /* specify a font, format "facename[, point size[, charset[ BOLD ITALIC UNDERLINE]]]" */
  FontSpec = 'MS Sans Serif,10,,BOLD'.
  FontSpec = 'MS Sans Serif,10,,'.
  SET-SIZE (lpFont) = LENGTH(FontSpec) + 1.
  PUT-STRING(lpFont,1) = FontSpec.
 
  /* screen coordinates. There is something weird about this */
  /* I currently have only one disply monitor... should test 
     this calculation with a secondary monitor using negative coords */
  SET-SIZE (lpPoint) = 8.
  PUT-LONG (lpPoint,1) = INTEGER(phWidget:WIDTH-PIXELS / 2).
  PUT-LONG (lpPoint,5) = INTEGER(phWidget:HEIGHT-PIXELS / 2).
  RUN ClientToScreen IN hpApi(phWidget:HWND,
                              GET-POINTER-VALUE(lpPoint),
                              OUTPUT retval).
 
  /* fill the HH_POPUP structure */  
  SET-SIZE (HH_POPUP)     = 52.
  PUT-LONG (HH_POPUP, 1)  = GET-SIZE(HH_POPUP).
  PUT-LONG (HH_POPUP, 5)  = 0.  /* or hInstance for a DLL that contains string resource */
  PUT-LONG (HH_POPUP, 9)  = 0.  /* or number of string resource in the DLL              */
  PUT-LONG (HH_POPUP,13)  = GET-POINTER-VALUE(lpText).
  PUT-LONG (HH_POPUP,17)  = GET-LONG(lpPoint,1). /* X-coordinate of center */
  PUT-LONG (HH_POPUP,21)  = GET-LONG(lpPoint,5). /* Y-coordinate of top    */
  PUT-LONG (HH_POPUP,25)  =  1. /* default textcolor or RGB-VALUE(Red,Green,Blue) */
  PUT-LONG (HH_POPUP,29)  = -1. /* default bgcolor   or RGB-VALUE(Red,Green,Blue) */
  PUT-LONG (HH_POPUP,33)  = -1. /* default left margin */
  PUT-LONG (HH_POPUP,37)  = -1. /* default top margin */
  PUT-LONG (HH_POPUP,41)  = -1. /* default right margin */
  PUT-LONG (HH_POPUP,45)  = -1. /* default bottom margin */
  PUT-LONG (HH_POPUP,49)  = 0.  /* or get-pointer-value(lpFont). */
 
  RUN HtmlHelpA ( phWidget:HWND, 
                  0, 
                  {&HH_DISPLAY_TEXT_POPUP}, 
                  GET-POINTER-VALUE(HH_POPUP),
                  OUTPUT RetVal).
 
  /* free memory */
  SET-SIZE (lpText)   = 0.
  SET-SIZE (lpFont)   = 0.
  SET-SIZE (lpPoint)  = 0.
  SET-SIZE (HH_POPUP) = 0.
 
END PROCEDURE.

As you can see in you can manipulate colors, fonts, margins and coordinates but I only used values that represent the system defaults.
The next example uses a CHM file to retrieve the string. A single CHM file can contain many strings, each string has a ContextId number.

{windows.i}
 
RUN HHPopupContext (FILL-IN-1:HANDLE,
                    "apisite.chm",
                    2).
 
/* or:
   RUN HHPopupContext (FILL-IN-1:HANDLE,
                       "apisite.chm::/cshelp.txt",
                       2).
*/
 
PROCEDURE HHPopupContext :
 
  DEFINE INPUT PARAMETER phWidget   AS WIDGET-HANDLE NO-UNDO.
  DEFINE INPUT PARAMETER pFilename  AS CHARACTER          NO-UNDO.
  DEFINE INPUT PARAMETER pContextId AS INTEGER       NO-UNDO.
 
  DEFINE VARIABLE FontSpec   AS CHARACTER.
  DEFINE VARIABLE HH_POPUP   AS MEMPTR.
  DEFINE VARIABLE lpFileName AS MEMPTR.
  DEFINE VARIABLE lpFont     AS MEMPTR.
  DEFINE VARIABLE lpPoint    AS MEMPTR.
  DEFINE VARIABLE retval     AS INTEGER NO-UNDO.
 
  SET-SIZE (lpFileName)    = LENGTH(pFileName) + 1.
  PUT-STRING(lpFileName,1) = pFileName.
 
  /* specify a font, format "facename[, point size[, charset[ BOLD ITALIC UNDERLINE]]]" */
  FontSpec = 'MS Sans Serif,10,,BOLD'.
  FontSpec = 'MS Sans Serif,10,,'.
  SET-SIZE (lpFont) = LENGTH(FontSpec) + 1.
  PUT-STRING(lpFont,1) = FontSpec.
 
  /* screen coordinates. There is something weird about this. */
  /* I really wish I had two video adaptors to test negative screen coordinates */
  SET-SIZE (lpPoint) = 8.
  PUT-LONG (lpPoint,1) = INTEGER(phWidget:WIDTH-PIXELS / 2).
  PUT-LONG (lpPoint,5) = INTEGER(phWidget:HEIGHT-PIXELS / 2).
  RUN ClientToScreen IN hpApi(phWidget:HWND,
                              GET-POINTER-VALUE(lpPoint),
                              OUTPUT retval).
 
  /* fill the HH_POPUP structure */  
  SET-SIZE (HH_POPUP)     = 52.
  PUT-LONG (HH_POPUP, 1)  = GET-SIZE(HH_POPUP).
  PUT-LONG (HH_POPUP, 5)  = 0.
  PUT-LONG (HH_POPUP, 9)  = pContextId.
  PUT-LONG (HH_POPUP,13)  = 0.
  PUT-LONG (HH_POPUP,17)  = GET-LONG(lpPoint,1). /* X-coordinate of center */
  PUT-LONG (HH_POPUP,21)  = GET-LONG(lpPoint,5). /* Y-coordinate of top    */
  PUT-LONG (HH_POPUP,25)  =  1. /* default textcolor or RGB-VALUE(Red,Green,Blue) */
  PUT-LONG (HH_POPUP,29)  = -1. /* default bgcolor   or RGB-VALUE(Red,Green,Blue) */
  PUT-LONG (HH_POPUP,33)  = -1. /* default left margin */
  PUT-LONG (HH_POPUP,37)  = -1. /* default top margin */
  PUT-LONG (HH_POPUP,41)  = -1. /* default right margin */
  PUT-LONG (HH_POPUP,45)  = -1. /* default bottom margin */
  PUT-LONG (HH_POPUP,49)  = 0.  /* or get-pointer-value(lpFont). */
 
  RUN HtmlHelpA ( phWidget:HWND, 
                  GET-POINTER-VALUE(lpFileName), 
                  {&HH_DISPLAY_TEXT_POPUP}, 
                  GET-POINTER-VALUE(HH_POPUP),
                  OUTPUT RetVal).
 
  /* free memory */
  SET-SIZE (lpFileName) = 0.
  SET-SIZE (lpFont)   = 0.
  SET-SIZE (lpPoint)  = 0.
  SET-SIZE (HH_POPUP) = 0.
 
END PROCEDURE.

To build a CHM that contains popup strings you have to write a TXT file. The default name for this TXT file is "cshelp.txt" and it should by default be located in the CHM root. If it has a different name or a different location you have to specify it along with the name of the CHM file, as shown in the commented RUN statement above. You can also create several text files in the same CHM project in order to organize a large amount of strings. Finally the text file has to be added to the [TEXT POPUPS] section in the project file.
This file (cshelp.txt) can contain many strings and is formatted like this little example :

.topic 1
This is the first example of a popup topic. It can be called
using HTMLHelp with the HH_DISPLAY_TEXT_POPUP option. see page 
hhpopup.html
 
.topic 2
well this is just another example. Great isn't it?

Using context help from any button

Topic using the contexthelp-button from the title-bar explained how to create the standard windows contexthelp-button on the title bar, and how to respond to its events. This standard button is commonly used with dialog boxes but is not really suitable for (top-level) windows, especially because the contexthelp-button can only be realised when the Minimize/Maximize buttons aren't visible.
On a (top-level) window, it's probably more appropriate to create a toolbar where one of the right-most buttons invokes context-help. To implement this in Progress you can simply create a button-widget and add the following ON CHOOSE-handler to it:

{windows.i}
DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
ON CHOOSE OF Btn_CTHELP IN FRAME DEFAULT-FRAME
DO:
  RUN SendMessageA IN hpApi(c-win:HWND, 
                            274,   /* = WM_SYSCOMMAND  */
                            61824, /* = SC_CONTEXTHELP */
                            0,
                            OUTPUT ReturnValue).
END.

This message will result in the mouse-pointer changing to the ?-symbol and will also make the MW_HELP message to be sent when the user clicks on a widget.
To catch the WM_HELP message and supply appropriate help, you will have to use the MsgBlaster control and follow the instructions on page Using the contecthelp-button from the title-bar

In Progress 9 you don't need to use a MsgBlaster anymore, you can just set c-win:context-help=true. However this is a little bit tedious, but Tom Bergman found the solution:

There's a trick you must do to make it work in
AppBuilder code. Progress will only respond to the click on a widget if the
context-help attribute of the window is set to true. Since the AppBuilder won't
let you set this attribute along with min and max buttons this presents a minor
problem.
Trying to set the attribute in the main block fails because the window has
already been realized.
The "trick" is to create an include file with the following content:

  {&WINDOW-NAME}:CONTEXT-HELP = TRUE.

Add this include file as a method-library and it gets included before the window
is realized.
One of the nice features of the Progress implementation of this feature is that
you don't actually need a help file to use it. If you don't reference a help
file or context-id, progress will show you the help attribute of the widget when
you click on it using what's this help.

Using the contexthelp-button from the title-bar

This topic is 32-bit only and was made in cooperation with Paul Koufalis.

This example uses the source in procedure winstyle.p, available on page WinStyle.p.
It also uses the MsgBlaster control, free available for download.

It seems common practice in Windows 95 to create a Contexthelp button in the titlebar of a dialog, rather than a 'normal' helpbutton. When the user chooses the Contexthelp button it will stay down and the mouse pointer changes into an arrow with question mark. When the user now chooses a control, Windows will send a WM_HELP message to the top-level window, releases the Contexthelp button and reloads the usual mouse-pointer.
It's up to the application to handle the WM_HELP message.

This page explains what's going on. It seems a lot of work, at least when you have to repeat all steps for every new dialog. The good news is that it must be very easy to wrap everything up into one single ActiveX control.

Added later: We actually have created this ActiveX control: cthelp.ocx and it is attached so you can download it.
The examples on this page show how to do this for a Dialog. The sources work equally well for a window but that's a bit unusual. If you do want to use this on a window please be warned that the Contexthelp-button can not be placed until the Minimize/Maximize buttons are removed from the title bar.
So on a normal window you will prefer to call context-help from a toolbar instead the title bar. In that case, see contexthelp from any button.
Let's start with adding the Help button. Create a dialog and add this source fragment to the main block:

  DEFINE VARIABLE hStyle AS HANDLE NO-UNDO.
  RUN WinStyle.p PERSISTENT SET hStyle.
  RUN AddHelpButton IN hStyle (FRAME {&frame-name}:HWND).
  DELETE PROCEDURE hStyle.
  FRAME {&frame-name}:LOAD-MOUSE-POINTER("Arrow":U).
  RUN AddContextIDs.

Load-mouse-pointer("Arrow") is necessary for a Dialog, not for a window. I don't understand why.
The button works now and sends WM_HELP messages to the dialog. Progress normally doesn't notify you when external messages occur, so we seem to need the msgblaster control.
Drop a msgblaster on the dialog and set it up as follows:

PROCEDURE MsgBlaster.Msgblst32.MESSAGE .
  DEFINE INPUT        PARAMETER p-MsgVal    AS INTEGER NO-UNDO.
  DEFINE INPUT        PARAMETER p-wParam    AS INTEGER NO-UNDO.
  DEFINE INPUT        PARAMETER p-lParam    AS INTEGER NO-UNDO.
  DEFINE INPUT-OUTPUT PARAMETER p-lplRetVal AS INTEGER NO-UNDO.
 
  IF p-MsgVal = 83 /* = WM_HELP */ THEN
     RUN HelpContextPopup(p-lParam).
 
END PROCEDURE.
 
 
PROCEDURE initialize-controls :
  DEFINE VARIABLE hparent AS INTEGER NO-UNDO.
  DEFINE VARIABLE hc AS COM-HANDLE NO-UNDO.
 
  &IF "{&window-name}" <> "" &THEN
     /* if this is a window: */
     hparent = GetParent({&window-name}:HWND).
  &ELSE
     /* if this is a dialog: */
     hParent = FRAME {&frame-name}:HWND.
  &ENDIF
 
  hc = chMsgBlaster:Msgblst32.
  hc:MsgList(0) = 83.   /* = WM_HELP */
  hc:MsgPassage(0) = 1. /* or -1 or 0, didn't notice any difference */
  hc:hWndTarget = hparent.
  RELEASE OBJECT hc.
 
END PROCEDURE.

So now we will be notified if a WM_HELP message occurs; the message event will run the procedure HelpContextPopup. HelpContextPopup is a very general procedure e.g. not specific for one dialog, so you can safely put it in a persistent library.

PROCEDURE HelpContextPopup :
/*------------------------------------------------------------------
  Purpose:     show context help in a popup window
  Parameters:  p-lParam contains a pointer to a HELPINFO structure
  Notes:       
-------------------------------------------------------------------- */
  DEFINE INPUT PARAMETER p-lParam AS INTEGER.
 
  DEFINE VARIABLE helpinfo AS MEMPTR.
  DEFINE VARIABLE ContextType AS INTEGER.
  DEFINE VARIABLE HWND AS INTEGER.
  DEFINE VARIABLE ContextID AS INTEGER.
  DEFINE VARIABLE ReturnValue AS INTEGER.
 
  SET-SIZE(helpinfo) = 28.
  SET-POINTER-VALUE(helpinfo) = p-lParam.
  ContextID = GET-LONG(helpinfo, 17).
 
  /* ContextID=0 will result in the standard text
     "No help topic is associated with this item" 
     You might want to test that and return or
     replace 0 by a different (translated) ContextID
  */
  /* Was WM_HELP called for HELPINFO_WINDOW or for HELPINFO_MENUITEM ? 
     We don't want to support help for MENUITEM right now */
 
  ContextType = GET-LONG(helpinfo, 5).
  IF ContextType<>1 /* 1=HELPINFO_WINDOW */ THEN DO:
     SET-SIZE(helpinfo)=0.
     RETURN.
  END.
 
  HWND = GET-LONG(helpinfo,13).
  RUN WinHelp{&A} IN hpApi (HWND, 
                            "myhelp.hlp", 
                            8,    /* 8 = HELP_CONTEXTPOPUP */
                            ContextID,
                            OUTPUT ReturnValue).
 
  SET-SIZE(helpinfo) = 0.
 
END PROCEDURE.

So WinHelp will be called and shows a certain ContextID from "myhelp.hlp" in a little yellow popup-window, aligned to the control where your mouse was on. Great. But what ContextID, you might wonder?

ContextID's

When you write a helpfile each topic will be assigned a unique integer identifier: the ContextID. The ContextHelp button feature requires that you write a lot of topics: at worst one for each widget, at best one topic for each group if widgets (like one for each (smart)frame).
The ContextID's supplied by your help authoring tool must be mapped to the widgets or widgetgroups in the program. From the main block we already called procedure AddContextIDs. Here's the implementation:

PROCEDURE AddContextIDs :
/*-------------------------------------------------------------------
  Purpose:     map widgets to ContextID's
  Parameters:  
--------------------------------------------------------------------- */
  DEFINE VARIABLE retval AS INTEGER NO-UNDO.
  RUN SetWindowContextHelpId IN hpApi(FRAME {&frame-name}:HWND, 101, OUTPUT retval).
  RUN SetWindowContextHelpId IN hpApi(FRAME FRAME-A:HWND, 102, OUTPUT retval).
  RUN SetWindowContextHelpId IN hpApi({&window-name}:HWND, 103, OUTPUT retval).
 
  DO WITH FRAME {&frame-name}:
     RUN SetWindowContextHelpId IN hpAPi(button-1:HWND,  143, OUTPUT retval).
     RUN SetWindowContextHelpId IN hpApi(button-2:HWND,  142, OUTPUT retval).
     RUN SetWindowContextHelpId IN hpApi(fill-in-1:HWND, 144, OUTPUT retval).
     RUN SetWindowContextHelpId IN hpApi(fill-in-2:HWND, 145, OUTPUT retval).
  END.
 
END PROCEDURE.

Of course these are all widgets your program probably don't have, it is just an example. The important part is that if you assign a ContextID to a window, all frames in that window will inherit that ContextID. If you assign a ContextID to a frame, all widgets in that frame will inherit that ContextID. And so on.
That makes it possible and convenient to assign ContextID's inside the sources of SmartObjects.

Attachments

cthelp.zip : cthelp.ocx

Formatting date and time

In Windows "Control Panel" / "Regional Settings" you can choose a Locale and change several formats for that Locale. However Progress displays dates and times using its own display formats.
You can use GetDateFormatA or GetTimeFormatA to format a date or time according to Windows settings. The resulting character string can be useful for reports or display-only fields. When you call GetDateFormatA or GetTimeFormatA you will probably want it to use the current locale, although it is also possible to use any non-current locale as demonstrated in the above example window.

/* these prototypes are declared in windows.p.
   constants are declared in {i18n.i}.
   i18n.i is available in everything.zip */
 
PROCEDURE GetDateFormatA EXTERNAL "KERNEL32" :
   DEFINE INPUT PARAMETER        Locale      AS LONG.
   DEFINE INPUT PARAMETER        dwFlags     AS LONG.
   DEFINE INPUT PARAMETER        lpTime      AS LONG.
   DEFINE INPUT PARAMETER        lpFormat    AS LONG.
   DEFINE INPUT-OUTPUT PARAMETER lpDateStr   AS CHARACTER.
   DEFINE INPUT PARAMETER        cchDate     AS LONG.
   DEFINE RETURN PARAMETER       cchReturned AS LONG.
END PROCEDURE.
 
PROCEDURE GetTimeFormatA EXTERNAL "KERNEL32" :
   DEFINE INPUT PARAMETER        Locale    AS LONG.
   DEFINE INPUT PARAMETER        dwFlags   AS LONG.
   DEFINE INPUT PARAMETER        lpTime    AS LONG.
   DEFINE INPUT PARAMETER        lpFormat  AS LONG.
   DEFINE INPUT-OUTPUT PARAMETER lpTimeStr AS CHARACTER.
   DEFINE INPUT PARAMETER        cchTime   AS LONG.
   DEFINE RETURN PARAMETER       cchReturned AS LONG.
END PROCEDURE.

Parameter lpTime is a MEMPTR to a SYSTEMTIME structure. lpTime=0 will use the current system date/time.
Parameter lpFormat is a pointer to a format string. lpFormat=0 will use the format as specified in Control Panel. There are numerous possibilities, you best check the help file in Control Panel for examples.
Parameter lpTimeString is the returned character string. The memory for this string must be allocated in your P4GL program as usual. The size of this allocated string must be supplied in cchTime.
The demo window was based on a radio set with a couple of Language ID's:

{i18n.i}
 
DEFINE VARIABLE RD-LANGID AS INTEGER 
     VIEW-AS RADIO-SET VERTICAL
     RADIO-BUTTONS 
          "LOCALE_USER_DEFAULT", {&LOCALE_USER_DEFAULT},
          "LOCALE_SYSTEM_DEFAULT", {&LOCALE_SYSTEM_DEFAULT},
          "Dutch", {&LANGID_DUTCH},
          "French", {&LANGID_FRENCH},
          "German", {&LANGID_GERMAN}, 
          "Spanish", {&LANGID_SPANISH},
          "English", {&LANGID_ENGLISH},
          "Italian", {&LANGID_ITALIAN}
     SIZE 34 BY 5.24 NO-UNDO.
--------------------------------------------------------------------------------
ON VALUE-CHANGED OF RD-LANGID IN FRAME DEFAULT-FRAME
DO:
  ASSIGN rd-langid.
 
  DEFINE VARIABLE chDate AS CHARACTER NO-UNDO.
  DEFINE VARIABLE cchRet AS INTEGER NO-UNDO.
 
  chDate = FILL("x",50).
  RUN GetDateFormatA IN hpApi( RD-LANGID ,
                               2,
                               0,
                               0,
                               INPUT-OUTPUT chDate,
                               LENGTH(chDate),
                               OUTPUT cchRet
                             ).  
  fill-in-longdate:SCREEN-VALUE = chDate.
 
 
  chDate = FILL("x",50).
  RUN GetDateFormatA IN hpApi( RD-LANGID ,
                               1,
                               0,
                               0,
                               INPUT-OUTPUT chDate,
                               LENGTH(chDate),
                               OUTPUT cchRet
                             ).  
  fill-in-shortdate:SCREEN-VALUE = chDate.
 
 
  chDate = FILL("x",50).
  RUN GetTimeFormatA IN hpApi( RD-LANGID ,
                               0,
                               0,
                               0,
                               INPUT-OUTPUT chDate,
                               LENGTH(chDate),
                               OUTPUT cchRet
                             ).  
  fill-in-time:SCREEN-VALUE = chDate.
END.

This example passes 0 for lpTime so it will always format the current system time. To format any other date or time you will have to pass a MEMPTR to an initialized SYSTEMTIME structure, for example:

{i18n.i}
 
  DEFINE VARIABLE cchRet AS INTEGER NO-UNDO.
  DEFINE VARIABLE lpTime AS MEMPTR  NO-UNDO.
  SET-SIZE (lpTime)    =   16.
  PUT-SHORT(lpTime, 1) = 1998.  /* = year                  */
  PUT-SHORT(lpTime, 3) =    6.  /* = month                 */
  PUT-SHORT(lpTime, 5) =    5.  /* = day of week, ignored  */
  PUT-SHORT(lpTime, 7) =   26.  /* = day                   */
  PUT-SHORT(lpTime, 9) =   21.  /* = hour                  */
  PUT-SHORT(lpTime,11) =   42.  /* = minute                */
  PUT-SHORT(lpTime,13) =   21.  /* = seconds               */
  PUT-SHORT(lpTime,15) =    4.  /* = milliseconds          */
 
  chDate = FILL("x",50).
  RUN GetDateFormatA IN hpApi( RD-LANGID ,
                               0,
                               GET-POINTER-VALUE(lpTime),
                               0,
                               INPUT-OUTPUT chDate,
                               LENGTH(chDate),
                               OUTPUT cchRet
                             ).  
  SET-SIZE(lpTime) = 0.

Local names for dates and months

Procedure GetLocaleInfoA can be used to retrieve all the information entered in "Control Panel / Regional Settings", both for the current locale and for all other locales. This can be useful for lots of things like displaying the actual names for days and months.
The demo window, shown in the picture, allows to choose a locale and fills a couple of selection lists showing the month names, abbreviated month names, day names and abbreviated day names. It uses the following definitions:

/* Procedure GetLocaleInfoA is declared in windows.p.
   Use includefile {i18n.i} to use declared constants.
   i18n.i is part of everything.zip */
 
PROCEDURE GetLocaleInfoA EXTERNAL "kernel32" :
   DEFINE INPUT PARAMETER        Locale      AS LONG.
   DEFINE INPUT PARAMETER        dwFlags     AS LONG.
   DEFINE INPUT-OUTPUT PARAMETER lpLCData    AS CHARACTER.
   DEFINE INPUT PARAMETER        cchData     AS LONG.
   DEFINE RETURN PARAMETER       cchReturned AS LONG.
END PROCEDURE.

The radio set in the window is defined as:

{i18n.i}
 
DEFINE VARIABLE RD-LANGID AS INTEGER 
     VIEW-AS RADIO-SET VERTICAL
     RADIO-BUTTONS 
          "LOCALE_USER_DEFAULT", {&LOCALE_USER_DEFAULT},
          "LOCALE_SYSTEM_DEFAULT", {&LOCALE_SYSTEM_DEFAULT},
          "Dutch", {&LANGID_DUTCH},
          "French", {&LANGID_FRENCH},
          "German", {&LANGID_GERMAN}, 
          "Spanish", {&LANGID_SPANISH},
          "English", {&LANGID_ENGLISH},
          "Italian", {&LANGID_ITALIAN}
     SIZE 34 BY 5.24 NO-UNDO.
 
--------------------------------------------------------------------------------
ON VALUE-CHANGED OF RD-LANGID IN FRAME DEFAULT-FRAME
DO:
  ASSIGN rd-langid.
 
  DEFINE VARIABLE chName AS CHARACTER    NO-UNDO.
  DEFINE VARIABLE i      AS INTEGER NO-UNDO.
  DEFINE VARIABLE cchRet AS INTEGER NO-UNDO.
 
  SELECT-day:LIST-ITEMS="".
  DO i=0 TO 6 :  
    chName = FILL("x",50).
    RUN GetLocaleInfoA IN hpApi ( RD-LANGID ,
                                  {&LOCALE_SDAYNAME1} + i,
                                  INPUT-OUTPUT chName,
                                  LENGTH(chName),
                                  OUTPUT cchRet
                                ).  
    SELECT-day:ADD-LAST(chName).
  END.
 
  SELECT-abbrevday:LIST-ITEMS="".
  DO i=0 TO 6 :  
    chName = FILL("x",50).
    RUN GetLocaleInfoA IN hpApi( RD-LANGID ,
                                 {&LOCALE_SABBREVDAYNAME1} + i,
                                 INPUT-OUTPUT chName,
                                 LENGTH(chName),
                                 OUTPUT cchRet
                               ).  
    SELECT-abbrevday:ADD-LAST(chName).
  END.
 
  SELECT-month:LIST-ITEMS="".
  DO i=0 TO 11 :  
    chName = FILL("x",50).
    RUN GetLocaleInfoA IN hpApi ( RD-LANGID ,
                                  {&LOCALE_SMONTHNAME1} + i,
                                  INPUT-OUTPUT chName,
                                  LENGTH(chName),
                                  OUTPUT cchRet
                                ).  
    SELECT-month:ADD-LAST(chName).
  END.
 
  SELECT-abbrevmonth:LIST-ITEMS="".
  DO i=0 TO 11 :  
    chName = FILL("x",50).
    RUN GetLocaleInfoA IN hpApi ( RD-LANGID ,
                                  {&LOCALE_SABBREVMONTHNAME1} + i,
                                  INPUT-OUTPUT chName,
                                  LENGTH(chName),
                                  OUTPUT cchRet
                                ).  
    SELECT-abbrevmonth:ADD-LAST(chName).
  END.
END.

Right to Left in FILL-INs and EDITORs etc

Found in an e-mail to Peg, sent by Torben Jensby Christensen

We have been experimenting with mixing Arabic and standard Western Eropean
fields on the same screen.

For this to work as seamlessly as possible for the users we are changing
keyboard and writing direction on every field entry.

Following code is working with Progress 9.1

DEFINE VARIABLE we-keyboard AS CHARACTER INIT "00000409":U  NO-UNDO.
DEFINE VARIABLE arabic-keyboard AS CHARACTER INIT "00000429":U  NO-UNDO.

/* Used for change input keyboard behaviour (Arabic) */
PROCEDURE LoadKeyboardLayoutA EXTERNAL "user32.dll":
   /*
   Input paramets
      klid : keyboard layout id
             00000401: Arabic (Saudi Arabia, Iraq, Egypt, Libya, Algeria,
Jordan ....)
             00000402: Bulgaria
             00000405: Czech
             00000406: Danish
             00000407: German Standard
             00000409: English US
             0000040a: Spanish
             0000040b: Finnish
             0000040c: French_Standard
             0000040d: Hebrew
             00000410: Italian
             00000413: Dutch_Standard
             00000414: Norwegian
             00000415: Polish
             0000041a: Croatian
             0000041d: Swedish
             00000429: Farsi

             00000807: German_Swiss
             00000809: English United Kingdom
             0000080a: Spanish Latin
             0000080c: French_Belgian
             00000813: Dutch_Belgian
             00000816: Portuguese
      flags: specifies how the keyboard layout is to be loaded
             KLF_ACTIVATE    &1H
             KLF_NOTELLSHEL
             KLF_REORDER
             KLF_REPLACELANG
             KLF_SUBSTITUTE_OK
             KLF_UNLOADPREVIOUS

   See keyboard layout id at:
http://www.microsoft.com/globaldev/winxp/xp-lcid.asp
   */
   DEFINE INPUT PARAMETER klid  AS CHARACTER.
   DEFINE INPUT PARAMETER flags AS LONG.
END.

FUNCTION set-keyboard RETURNS LOGICAL (INPUT lng AS CHAR ).
   DEFINE VARIABLE klid AS CHARACTER INIT "00000409":U NO-UNDO.
   IF lng <> "ARABIC":U AND lng <> "NORMAL":U THEN DO:
      MESSAGE "set-keyboard":U SKIP
         "Must be called with Arabic or normal":U SKIP
         lng
         VIEW-AS ALERT-BOX ERROR BUTTONS OK.
      RETURN FALSE.
   END.
   IF lng = "ARABIC":U THEN DO:
      /* klid = "00000429":U. arabic farsi keyboard */
      klid = arabic-keyboard.
   END.
   ELSE DO:
      /* klid = "00000409":U. English US keyboard */
      klid = we-keyboard.
   END.
   ASSIGN klid = "00000409":U WHEN klid = "".
   RUN LoadKeyboardLayoutA IN THIS-PROCEDURE (INPUT klid,INPUT 1). /* arabic farsi keyboard */
   RETURN TRUE.
END FUNCTION.

FUNCTION set-field-direction RETURNS LOGICAL (INPUT fillin-or-editor AS
HANDLE,INPUT direction AS CHAR).
   DEFINE VARIABLE styles AS INTEGER    NO-UNDO.
   IF direction <> "R2L":U AND direction <> "L2R":U THEN DO:
      MESSAGE "set-field-direction":U SKIP
         "Must be called with R2L or L2R":U SKIP
         direction
         VIEW-AS ALERT-BOX ERROR BUTTONS OK.
      RETURN FALSE.
   END.
   IF direction = "R2L":U THEN DO:
      /*
      styles = 4608. /* R2L arabic field */
      */
      styles = 29184. /* R2L + Scrollbar left Arabic field */
   END.
   ELSE DO:
      styles = 512. /* L2R Normal WE field */
   END.
   RUN SetWindowLongA IN THIS-PROCEDURE (INPUT fillin-or-editor:HWND ,INPUT -20,INPUT styles).
   RETURN TRUE.
END FUNCTION.

/* Used for fill-in and not large editor behaviour (Arabic) */
PROCEDURE SetWindowLongA EXTERNAL "user32.dll":
   /*
   Input parameters
      hdwnd   HWND handle of fill-in or editor
      offs    -20 for Extended windows styles
      newlong  4608 for arabic
              29184 for arabic with vertical scrollbar
                512 for WE

   */
   DEFINE INPUT PARAMETER hdwnd   AS LONG.
   DEFINE INPUT PARAMETER offs    As LONG.
   DEFINE INPUT PARAMETER newlong AS LONG.
END.

Disable and re-enable CTRL-ALT-DELETE, ALT-TAB and CTRL-ESC

by Stuart Morris

Usefull when that process really should not be interupted. Note: It can cripple the PC

&GLOBAL-DEFINE A A
&GLOBAL-DEFINE SPI_SCREENSAVERRUNNING 97
 
DEFINE VARIABLE retVal   AS INTEGER NO-UNDO.
DEFINE VARIABLE lv-dummy AS INTEGER NO-UNDO.
 
PROCEDURE SystemParametersInfo{&A} EXTERNAL "USER32.DLL":U :
  DEFINE INPUT  PARAMETER uAction  AS LONG NO-UNDO.
  DEFINE INPUT  PARAMETER uParam   AS LONG NO-UNDO.
  DEFINE INPUT  PARAMETER lpvParam AS LONG NO-UNDO.
  DEFINE INPUT  PARAMETER fuWinIni AS LONG NO-UNDO.
  DEFINE OUTPUT PARAMETER retVal   AS LONG NO-UNDO.
END.
 
  /* --- Disable */
 
  RUN SystemParametersInfo{&A} (INPUT  {&SPI_SCREENSAVERRUNNING},
                                       1, /* True */
                                       lv-dummy,
                                       0,
                                OUTPUT retVal
                               )
                               NO-ERROR.
 
  /* --- Enable */
 
  RUN SystemParametersInfo{&A} (INPUT  {&SPI_SCREENSAVERRUNNING},
                                       0, /* False */
                                       lv-dummy,
                                       0,
                                OUTPUT retVal
                               )
                               NO-ERROR.

The keyboard: reading and setting toggle states

This example reads the toggle states of the three most commonly used toggle keys: Capslock, Numlock and Insert. The example also changes these three toggle states: you will see the LED's on your keyboard change.
The GetKeyboardState procedure fetches the keystates of 256 keys at once. There's also a GetKeyState procedure to fetch the state for 1 particular key, but there is no SetKeyState procedure for one key so if you need to change a keystate you will have to use SetKeyboadState and set them all.

{windows.i}
 
DEFINE VARIABLE CapsLockToggle AS LOGICAL.
DEFINE VARIABLE NumLockToggle AS LOGICAL.
DEFINE VARIABLE InsertToggle AS LOGICAL.
 
RUN GetKeyToggleState (OUTPUT CapsLockToggle, 
                       OUTPUT NumLockToggle, 
                       OUTPUT InsertToggle).
 
/* alter all three of them, for demonstration purposes */
RUN SetKeyToggleState (NOT CapsLockToggle, 
                       NOT NumLockToggle, 
                       NOT InsertToggle).
 
 
 
&GLOB  VK_CAPITAL 20
&GLOB  VK_INSERT 45
&GLOB  VK_NUMLOCK 144
&GLOBAL-DEFINE VK_SCROLL    145   /* (hex 91) SCROLL LOCK key  */
&GLOBAL-DEFINE VK_SHIFT     16    /* (hex 10) either SHIFT key */
&GLOBAL-DEFINE VK_CONTROL   17    /* (hex 11) either Ctrl key  */
/* The following only work under Windows NT/2000/XP: */
&GLOBAL-DEFINE VK_LSHIFT    160   /* (hex A0) Left SHIFT key   */
&GLOBAL-DEFINE VK_RSHIFT    161   /* (hex A1) Right SHIFT key  */
&GLOBAL-DEFINE VK_LCONTROL  162   /* (hex A2) Left CTRL key    */
&GLOBAL-DEFINE VK_RCONTROL  163   /* (hex A3) Right CTRL key   */
 
PROCEDURE GetKeyToggleState :
 
  DEFINE OUTPUT PARAMETER CapsLockToggle AS LOGICAL.
  DEFINE OUTPUT PARAMETER NumLockToggle AS LOGICAL.
  DEFINE OUTPUT PARAMETER InsertToggle AS LOGICAL.
 
  DEFINE VARIABLE KBState AS MEMPTR.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
  SET-SIZE(KBState) = 256.
 
  /* Get the current state of the keyboard */
  RUN GetKeyboardState(GET-POINTER-VALUE(KBState), OUTPUT ReturnValue).
 
  CapsLockToggle = GET-BYTE(KBState, 1 + {&VK_CAPITAL}) MOD 2 = 1.
  NumLockToggle  = GET-BYTE(KBState, 1 + {&VK_NUMLOCK}) MOD 2 = 1.
  InsertToggle   = GET-BYTE(KBState, 1 + {&VK_INSERT})  MOD 2 = 1.
 
  SET-SIZE(KBState) = 0.   
 
END PROCEDURE.
 
/* ======================================================= */
 
PROCEDURE SetKeyToggleState :
 
   DEFINE INPUT PARAMETER CapsLockToggle AS LOGICAL.
   DEFINE INPUT PARAMETER NumLockToggle AS LOGICAL.
   DEFINE INPUT PARAMETER InsertLockToggle AS LOGICAL.
 
   DEFINE VARIABLE KBState AS MEMPTR.
   DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
   SET-SIZE(KBState) = 256.
 
   /* Get the current state of the keyboard */
   RUN GetKeyboardState(GET-POINTER-VALUE(KBState), OUTPUT ReturnValue).
 
   PUT-BYTE(KBState,1 + {&VK_CAPITAL})  = IF CapsLockToggle THEN 1 ELSE 0.
   PUT-BYTE(KBState,1 + {&VK_NUMLOCK})  = IF NumLockToggle THEN 1 ELSE 0.
   PUT-BYTE(KBState,1 + {&VK_INSERT})   = IF InsertLockToggle THEN 1 ELSE 0.
 
   RUN SetKeyboardState(INPUT GET-POINTER-VALUE(KBState), OUTPUT ReturnValue).
   SET-SIZE(KBState) = 0.   
 
END PROCEDURE.
 
PROCEDURE GetKeyboardState EXTERNAL {&USER}:
   DEFINE INPUT  PARAMETER KBState AS LONG. /* memptr */
   DEFINE RETURN PARAMETER RetVal  AS LONG. /* bool   */
END PROCEDURE.
 
PROCEDURE SetKeyboardState EXTERNAL {&USER} :
   DEFINE INPUT  PARAMETER KBState AS LONG. /* memptr */
   DEFINE RETURN PARAMETER RetVal  AS LONG. /* bool   */
END PROCEDURE.

explanation

GetKeyboardState fetches an array of 256 keystates, each keystate is one byte in size.
VK_CAPITAL (better known as Capslock) has index 20 in that array. Arrays in C are zero based while Progress starts counting at one, so the put-byte and get-byte statements are called with (1 + {&VK_CAPITAL}).
A key is toggled ON when the low-order bit of its keystate is set to 1. The example tests this by checking if the value is odd or even.
A key is pressed when the high-order bit is set to 1. This may be important to know, but not in this example.

notes

Although the code does change the toggle state for the Insert-button you will not notice it; for some reason the Progress fill-in and editor widgets will keep behaving as if Insert is toggled on.
The Statusbar ActiveX from Microsoft Common Controls V5 has panels that automatically represent the toggle states. However, these panels don't respond to the code.
Based on an idea by Paul Koufalis.

Asterisks in password

The Progress fill-in widget has a :blank attribute that you can use when creating a password field. But most Windows applications use asterisks instead of blanks.
It's fairly simple to have asterisks (or any other password-character) in Progress too:

  {windows.i}
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
  RUN SendMessage{&A} IN hpApi (fill-in_password:HWND, 
                                {&EM_SETPASSWORDCHAR}, 
                                ASC("*"),
                                0,
                                OUTPUT ReturnValue).

Explanation

The third parameter is the new passwordchar. When 0, you disable the password feature.

Notes

You may have trouble reading fill-in_password:screen-value so instead you have to ASSIGN the fill-in and test the associated field or variable.
There is a small security risc: if you use debugtools like Spy++ you will see the contents of the fill-in in readable format, e.g. with no asterisks. This means it is fairly simple for a hacker to create a program that logs your passwords. This is not only true for this particular fill-in, but for every password field in MS-Windows. The normal :BLANK attribute however can not be spied: it only shows blanks.

GetUserName

The 'name' field (in a login dialog) can be initialized with the name by which the user is known in Windows.
You can try to find this name in the registry but you better let Windows do it for you, using the GetUserName function.

{windows.i}
 
   DEFINE VARIABLE NAME AS CHARACTER NO-UNDO.
   RUN WinUserName(OUTPUT NAME).
   fill-in_name:SCREEN-VALUE = NAME.
 
PROCEDURE WinUserName :
   DEFINE OUTPUT PARAMETER NAME AS CHARACTER.
 
   DEFINE VARIABLE nr AS INTEGER NO-UNDO INITIAL 100.
   DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
   NAME = FILL(" ", nr).
   RUN GetUserName{&A} IN hpApi (INPUT-OUTPUT NAME,
                                 INPUT-OUTPUT nr,
                                 OUTPUT ReturnValue).
END PROCEDURE.

notes

The 'fill' statement is important because it allocates memory. Windows hardly ever allocates memory for you.
There is one important drawback: the function GetUserName does not exist in 16-bit windows. If you are using a Progress version prior to 8.2 on Windows 95 you can still use this function but you will have to thunk it.

Apply focus to a widget

Sometimes you may need to force focus to a certain widget.
There must be several solutions but I found this one to be fairly reliable: make Windows think the user clicked on the widget using his left mouse button. 'Click' is a combination of 'buttondown' and 'buttonup' so it involves two messages, but I assume you might be allowed to skip one of them.
So if you want to apply focus to FILL-IN-1 you might say:

  run MouseClick(FILL-IN-1:HANDLE).

{windows.i}
  
PROCEDURE MouseClick :
 DEFINE INPUT PARAMETER hWidget AS HANDLE NO-UNDO.
 
 DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 RUN PostMessage{&A} IN hpApi(hWidget:HWND,
                              {&WM_LBUTTONDOWN},
                              {&MK_LBUTTON},
                              0,
                              OUTPUT ReturnValue).
 RUN PostMessage{&A} IN hpApi(hWidget:HWND,
                              {&WM_LBUTTONUP},
                              0,
                              0,
                              OUTPUT ReturnValue).
END PROCEDURE.

Notes

You might have noticed the use of PostMessage instead of SendMessage like in apply the right mouse button. I have no idea why SendMessage doesn't work for the left mouse button.

Apply the right mouse button

Or: programatic dropping a popup-menu

Sometimes you will want to "apply" a mouse click to a widget, for example to give it focus (with the standard left button) or to force a popup-menu to pop up (with the alternate button).
In this example we have an image widget; the user can perform several actions on that image widget (like loading a new bmp-file or whatever). Those actions are listed in a popup-menu and now you want that popup-menu to appear whenever the user clicks the widget, even when he uses the left mouse button. Unfortunately the P4GL statement 'APPLY "MOUSE-MENU-CLICK" doesn't work but you can fool Progress by sending the appropriate mouse messages.

ON "MOUSE-SELECT-CLICK" OF IMAGE-1
DO:
  RUN CenterMouseCursor(SELF:HANDLE).
  RUN Apply-mouse-menu-click(SELF:HANDLE).
END.

The first statement, CenterMouseCursor, moves the mouse to the middle of the widget so this will be the exact location where the upper-left corner of the popup-menu will appear. This is by itself not very important and you may want to skip or change it. The real work is done by the Apply-mouse-menu-click.
Here is the api stuff:

{windows.i}  
 
PROCEDURE Apply-mouse-menu-click :
/*------------------------------------------------------------------------------
Purpose:     Programatic click the right mouse button on a widget
Parameters:  Widget-handle on which you want to click
------------------------------------------------------------------------------*/
   DEFINE INPUT PARAMETER  p-wh   AS WIDGET-HANDLE  NO-UNDO.
 
   DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
   RUN SendMessage{&A} IN hpApi (INPUT p-wh:HWND, 
                                 INPUT {&WM_RBUTTONDOWN},
                                 INPUT {&MK_RBUTTON},
                                 INPUT 0,
                                 OUTPUT ReturnValue).
   RUN SendMessage{&A} IN hpApi (INPUT p-wh:HWND, 
                                 INPUT {&WM_RBUTTONUP},
                                 INPUT 0, 
                                 INPUT 0,
                                 OUTPUT ReturnValue).
END PROCEDURE.
 
PROCEDURE CenterMouseCursor :
/*------------------------------------------------------------------------------
Purpose:     Move the mouse cursor to the middle of a widget
Parameters:  the widget-handle
------------------------------------------------------------------------------*/
   DEFINE INPUT PARAMETER  p-wh   AS WIDGET-HANDLE  NO-UNDO.
 
   DEFINE VARIABLE lppoint     AS MEMPTR  NO-UNDO.  /* POINT FAR*  */
   DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
   SET-SIZE(lppoint)= 2 * {&INTSIZE}.
 
   PUT-{&INT}(lppoint,1 + 0 * {&INTSIZE})=INTEGER(p-wh:WIDTH-PIXELS / 2).
   PUT-{&INT}(lppoint,1 + 1 * {&INTSIZE})=INTEGER(p-wh:HEIGHT-PIXELS / 2).
   RUN ClientToScreen IN hpApi (INPUT p-wh:HWND, 
                                INPUT GET-POINTER-VALUE(lppoint),
                                OUTPUT ReturnValue).
   RUN SetCursorPos IN hpApi   (INPUT GET-{&INT}(lppoint,1 + 0 * {&INTSIZE}), 
                                INPUT GET-{&INT}(lppoint,1 + 1 * {&INTSIZE}),
                                OUTPUT ReturnValue).
   SET-SIZE(lppoint)= 0.
END PROCEDURE.
 

Explanation:

Procedure SetCursorPos works with absolute screen coordinates where the upper left corner of your screen has coordinates (0,0).
But the widget coordinates p-wh:X and p-wh:Y are relative to p-wh:parent.
The conversion is done by function ClientToScreen (there is also a ScreenToClient function) which has two params: a handle and a memorypointer to a POINT structure.

Function ClientToScreen changes the contents of the POINT structure.

Based on a procedure by Rod Gaither

mouse-over event

based on an example by Chris Braddock

There is no real MOUSE-OVER event but this example shows one possible way to achieve the same effect.
The general idea is: use the PSTimer.OCX. Read the mouse coordinates on every tick of the timer using API-function GetCursorPos. The resulting coordinates are screen-coordinates. Then use API-function ScreenToClient to convert the screen-coordinates to client-coordinates, where "client" is the window you are interested in. Finally, test if those client coordinates are inside the client rectangle.
Attached example (in mousexy.zip) continuously shows the screen-coordinates and the client-coordinates. It also colors the frame green when the mouse moves over the frame, and colors the frame grey when the mouse moves away from the frame.
The example is based on these two API functions: GetCursorPos and ScreenToClient.

Attachments

mousexy.zip

Play an AVI file in a Progress window

It can be attractive to play an animation, for example while the user has to wait while your application communicates with the AppServer.
The source in this example uses some of the MCI series of API commands, making it possible to use this source on a window or on a dialog, and making it possible to play AVI's with or without soundtrack!

The complete example source (aviwin.w) is attached. It is a UIB-generated window (not SmartWindow) so the source is a bit too large to show on this page.

The source relies on the availablity of windows.i and windows.p, timestamp Sep 8, 1997 or later.

The window contains two buttons: button-open and button-stop.

Button-open is used to open (and play) an AVI file, button-close calls the procedure to stop (and close) the AVI file. The AVI file repeats infinitely and has a low priority in order to perform other Progress tasks, like FOR EACH processing in the meantime.
Normally you won't offer your users these buttons, they are here for demonstration purposes only.

The window also contains a frame (frame fdisplay): this will be the target window where the AVI output will be shown. It does not have to be a frame: you might also play the AVI on a button...

The AVI file is not opened in shared mode, so if you forget to Close the AVI-player you won't be able to open the AVI file again!
This makes it extremely important to run the 'close' procedure when the AVI is not needed anymore: you must never close the window without closing the AVI first! This is implemented by 'run PlayerClose' after the mainblock's 'WAIT-FOR' loop. If you use this code in a SmartObject you should run PlayerClose in local-destroy or somewhere around there.

Attachments

anim.zip : download source example

PlaySound

Function PlaySoundA plays a waveform sound. This function replaces the obsolete function sndPlaySoundA.

&GLOB SND_ASYNC 1
&GLOB SND_NODEFAULT 2
&GLOB SND_LOOP 8
&GLOB SND_PURGE 64
&GLOB SND_APPLICATION 128
&GLOB SND_ALIAS 65536
&GLOB SND_FILENAME 131072
&GLOB SND_RESOURCE 262148
 
PROCEDURE PlaySoundA EXTERNAL "winmm.dll" PERSISTENT :
  DEFINE INPUT PARAMETER  pszSound    AS LONG.
  DEFINE INPUT PARAMETER  hmod        AS LONG.
  DEFINE INPUT PARAMETER  fdwSound    AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.

Notice the 'persistent' option: if the procedure is not declared as persistent it will not be possible to use the SND_ASYNC flag. Also notice that pszSound is declared as LONG. This is not convenient in most cases when you need to pass a character string, but has to be long to support {&SND_PURGE}.

Examples

In the first example, the first parameter is interpreted as a filename. De default system sound ('ting') will be played if the specified filename can not be found, because the flag SND_NODEFAULT is not specified.

DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
DEFINE VARIABLE szSound     AS MEMPTR  NO-UNDO.
DEFINE VARIABLE wavfile     AS CHARACTER    NO-UNDO.
 
wavfile = "c:\windows\media\logoff.wav".
SET-SIZE(szSound) = LENGTH(wavfile, "raw":U) + 1.
PUT-STRING(szSound,1) = wavfile.
 
RUN PlaySoundA (GET-POINTER-VALUE(szSound), 
                0, 
                {&SND_FILENAME},
                OUTPUT ReturnValue). 
SET-SIZE(szSound) = 0.

The next example plays the system sound associated in Registry with eventname "SystemExit".
This sound and others are found in registry key "HKCU\AppEvents\Schemes\Apps\.Default".

DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
DEFINE VARIABLE szSound     AS MEMPTR  NO-UNDO.
DEFINE VARIABLE eventname   AS CHARACTER    NO-UNDO.
 
eventname = "SystemExit".
SET-SIZE(szSound) = LENGTH(eventname, "raw":U) + 1.
PUT-STRING(szSound,1) = eventname.
 
RUN PlaySoundA (GET-POINTER-VALUE(szSound), 
                0, 
                {&SND_ALIAS} + {&SND_NODEFAULT},
                OUTPUT ReturnValue).
SET-SIZE(szSound) = 0.

The next example plays an application-specific sound event.
These can be registered in key "HKCU\AppEvents\Schemes\Apps\prowin32".

DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
DEFINE VARIABLE szSound     AS MEMPTR  NO-UNDO.
DEFINE VARIABLE eventname   AS CHARACTER    NO-UNDO.
 
eventname = "CUSTOMER_DELETED".
SET-SIZE(szSound) = LENGTH(eventname, "raw":U) + 1.
PUT-STRING(szSound,1) = eventname.
 
RUN PlaySoundA (GET-POINTER-VALUE(szSound), 
                0, 
                {&SND_APPLICATION} + {&SND_NODEFAULT},
                OUTPUT ReturnValue).
SET-SIZE(szSound) = 0.

It is also possible to link WAV resources into an executable or DLL. Suppose the DLL is identified by handle hSounds and contains a sound resource named "LOGIN_REJECTED" :

DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
DEFINE VARIABLE szSound     AS MEMPTR  NO-UNDO.
DEFINE VARIABLE eventname   AS CHARACTER    NO-UNDO.
 
eventname = "LOGIN_REJECTED".
SET-SIZE(szSound) = LENGTH(eventname, "raw":U) + 1.
PUT-STRING(szSound,1) = eventname.
 
RUN PlaySoundA (GET-POINTER-VALUE(szSound), 
                hSounds, 
                {&SND_RESOURCE} + {&SND_NODEFAULT},
                OUTPUT ReturnValue).
SET-SIZE(szSound) = 0.

The last example is submitted by Nenad Orlovic [norlovic@zg.tel.hr].
Sounds should always be played asynchronous, especially when it is a long sound clip, so the program can continue while the sound is playing. This is done by adding the SND_ASYNC flag. This is only possible when the PlaySound procedure is declared as persistent: otherwise Progress would free the winmm.dll library immediately which would cause the sound to stop.
The example also uses SND_LOOP to repeat the sound. SND_LOOP can not be used without SND_ASYNC.

DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
DEFINE VARIABLE szSound     AS MEMPTR  NO-UNDO.
DEFINE VARIABLE wavfile     AS CHARACTER    NO-UNDO.
 
wavfile = "c:\windows\media\logoff.wav".
SET-SIZE(szSound) = LENGTH(wavfile, "raw":U) + 1.
PUT-STRING(szSound,1) = wavfile.
 
RUN PlaySoundA (GET-POINTER-VALUE(szSound),
                0,
                {&SND_FILENAME} + {&SND_ASYNC} + {&SND_LOOP} + {&SND_NODEFAULT},
                OUTPUT ReturnValue).
SET-SIZE(szSound) = 0.
 
MESSAGE "Press OK to stop the music" VIEW-AS ALERT-BOX.
 
RUN PlaySoundA (0,
                0,
                {&SND_PURGE},
                OUTPUT ReturnValue).
 
MESSAGE "The music stopped" VIEW-AS ALERT-BOX.

File download

by Todd G. Nist

This program utilizes the standard DoFileDownload API.
On the occasions when you simply need to download one file, this routine will display the IE file download dialog. The nice thing is that the dialog takes care of all aspects of the interface, including the progressbar, animation and statistics. This code can easily be integrated into any application requiring this type of functionality.
The program has been tested under Windows 2000 Server/Professional.
----
API-procedures used in this example are listed here to be included in the search index:

PROCEDURE DoFileDownload        EXTERNAL 'shdocvw.dll':U:
PROCEDURE WideCharToMultiByte   EXTERNAL "KERNEL32.dll":
PROCEDURE MultiByteToWideChar   EXTERNAL "KERNEL32.dll":

Attachments

ftpdownload.w.zip : demo

File Transfer Protocol (FTP)

by Todd G. Nist

Program source is available for download: winftp.w. Modified 20 July 2000.
This program demonstrates common FTP functionality: connect to an FTP server, list directory contents, change the current directory and of course: get, put and delete files.
See also FileDownload.

The code functions as follows:
* By default, it will connect to ftp.progress.com when you press the Connect FTP button.
* Once on the site, if you double click a directory in the directory selection list, it will open that directory and display the contents.
* By selecting the appropriate button, put, get, delete, you can achieve the desired request. These are all based on having permissions to the web site.

Notes

The function FtpFindFirstFile can only be invoked once within a given FTP Session. Therefore, when a double click occurs on the directory selection list, the current FTP session is closed, and then a new one established and the function FTPDirList invoked. This function is similar to the FindFirstFile and FindNextFile win32 API calls.
No username or password are used when connecting to the FTP server. This means the default username ("anonymous") and default password (something like "IE40USER@") will be used. This will probably not give you enough permissions to put or delete items. You may have to pass more specific username and password parameters in function InternetConnectionA.
The program has been tested under NT 4.0 with service pack 3 and IE4 or IE5, and also under Windows 98 with IE5.
----
API-procedures used in this example are listed here to be included in the search index:

PROCEDURE InternetConnectA             EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE InternetGetLastResponseInfoA EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE InternetOpenUrlA             EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE InternetOpenA                EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE InternetReadFile             EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE InternetCloseHandle          EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE FtpFindFirstFileA            EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE InternetFindNextFileA        EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE FtpGetCurrentDirectoryA      EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE FtpSetCurrentDirectoryA      EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE FtpOpenFileA                 EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE FtpPutFileA                  EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE FtpGetFileA                  EXTERNAL "wininet.dll" PERSISTENT:
PROCEDURE FtpDeleteFileA               EXTERNAL "wininet.dll" PERSISTENT:

Attachments

winftp.w.zip : demo program

Get MAC address

by Maurits van Rijnen

Every network adapter has a unique id: the MAC address. The MAC address may be used to identify a computer, at least for a while until its network adapter is replaced or until someone decides to flash a new MAC address into the adapter. Also, be carefull if the computer has more than one network adapter.
To read the MAC address you should read the ARP cache, but that's very complicated. Let's forget about the ARP cache.
Maurits found a neat "workaround" based on UuidCreate:
UuidCreate creates a new universally unique identifier, which can be used for creating new ActiveX controls and so on. Because it has to be universally unique it is based on a MAC address and probably some datetime-value (and perhaps some other hardware metrics). Maurits recognized how to read the MAC address from the uuid :

PROCEDURE UuidCreate EXTERNAL "rpcrt4.dll":U :
    DEFINE INPUT-OUTPUT PARAMETER opi-guid AS CHARACTER NO-UNDO.
END PROCEDURE.
 
PROCEDURE UuidCreateSequential EXTERNAL "rpcrt4.dll":U :
    DEFINE INPUT-OUTPUT PARAMETER opi-guid AS CHARACTER NO-UNDO.
END PROCEDURE.
 
FUNCTION inttohex RETURNS CHARACTER (INPUT i AS INTEGER): 
   /* only for 0..255 integer values */
   DEFINE VARIABLE cHex AS CHARACTER NO-UNDO INIT '0123456789ABCDEF':U.
   DEFINE VARIABLE j1   AS INTEGER NO-UNDO.
   DEFINE VARIABLE j2   AS INTEGER NO-UNDO.
 
   j1 = TRUNCATE(i / 16, 0) .
   j2 = i - (j1 * 16).
   RETURN SUBSTR(cHex, j1 + 1, 1) + SUBSTR(cHex, j2 + 1, 1).
END.
 
 
FUNCTION GetMacAddress RETURNS CHAR:
   DEFINE VARIABLE X AS CHARACTER NO-UNDO.
   DEFINE VARIABLE i AS INTEGER NO-UNDO.
   DEFINE VARIABLE j AS INTEGER NO-UNDO.
   DEFINE VARIABLE r AS CHARACTER NO-UNDO.
 
   X = FILL(' ':U, 16).
 
   IF RunningWindows2000() THEN 
      RUN UuidCreateSequential (INPUT-OUTPUT X).
   ELSE 
      RUN UuidCreate (INPUT-OUTPUT X).
 
   DO i = 11 TO 16:
      r = r + ' ':U + inttohex(ASC(SUBSTR(X,i,1))). 
   END.
   RETURN SUBSTR(R,2).
END.
 
DISPLAY GetMAcAddress() FORMAT "X(20)":U. 

Notes

Procedure UuidCreate() in Windows 2000 returns a uuid that can not be traced back to the MAC address. Procedure UuidCreateSequential is provided for backward compatibility: it behaves like UuidCreate() in Windows 95/98/NT4.

Mailslots

Introduction

There are several techniques for Inter Process Communication (IPC) like DDE, pipes, atoms, sockets and mailslots. Each technique has its own characteristics; this topic concentrates on Mailslots.
Mailslots offer an easy way for a process to broadcast a message to several other processes at once. A Mailslot is a pseudo-file created by one particular process, known as the Mailslot server. The Maislot server can read messages from the mailslot.
Other processes, known as Mailslot clients, can write messages to mailslots owned by Mailslot servers. A Mailslot client is not allowed to read from another process' mailslot.
Remember: a mailslot is a pseudo-file and lives in memory only for the lifetime of the process, or shorter. Don't confuse it with email where messages are persistently stored in an "inbox folder" or file.

A simple scenario

For the sake of simplicity it's easiest to think of processes as 'computers'. It is possible to set up mailsots between processes on the same computer but this has some limitations.
In it's simplest form, a server can receive messages from one or many clients but the clients can not receive anything.

In this case, Sue has set up a mailslot on her local machine. She named this mailslot

      \\.\mailslot\myapp\finance

(The "dot" means "local machine". "myapp" and "finance" are path and name to be picked by your application). This path and name have to be known by other processes. That won't be a problem if those other processes are running instances of the same application!
Bob and Pete are clients; they can write messages to Sue's mailslot by addressing

      \\Sue\mailslot\myapp\finance

Where "Sue" is a machine name. More realisticly, they would address to

     \\domainname\mailslot\myapp\finance

or even to

      \\*\mailslot\myapp\finance

where the asterisk stands for the primary domain. In these last two cases, the messages will also be picked up by anyone else in the domain who defined the mailslot like Sue did. Hence you have a broadcasting mechanism.

A more realistic scenario

Although Sue is the mailslot server for her own local mailslot, there is no reason why she shouldn't be able to send messages to other processes who also have a local mailslot named ".\mailslot\myapp\finance". Sue can be a server and a client at the same time.
Likewise, there is no reason why Bob and Pete should't be able to serve a mailslot each, also using this same mailslot name.
A message sent by either Bob, Pete or Sue (or anyone else) will now be recieved by all others.

Limitations

Only one process on a computer can serve a mailslot with a particular name. In other words: this broadcasting mechanism will not work between multiple instances of an application running on the same computer.
The maximum size of a message is 64K if it is not broadcast. A broadcasted message can be no longer than 400 byte.
Mailslots use datagrams. There is no way of knowing if a broadcasted message will actually be received by everyone.
If you need to broadcast across a WAN you may consider setting up sockets on an "IP Multicast" enabled network. See http:www.ipmulticast.com.

Procedures

A server creates a mailslot by calling procedure CreateMailslot(). This procedure returns a Mailslot-handle. The Mailslot-handle is somewhat compatible with a file-handle: the server can read messages from the mailslot by calling procedure ReadFile(). Procedure GetMailslotInfo() tells how many messages are in the pseudo-file and how long they are. The server calls CloseHandle() to destroy the mailslot.
A client writes to a mailslot just as if it writes to a file, except the filename must be a valid mailslot-name. In other words a client uses CreateFile(), WriteFile() and CloseHandle().
Note: CreateFile() doesn't create the file of course, it only gets a handle to the existing pseudo-file (the "share"-flags are especially important here).

RUN CreateMailSlot{&A} (INPUT  cMailslotName:SCREEN-VALUE,
                        INPUT  0, /* Maximum message length */
                        INPUT  0, /* Read timeout */
                        INPUT  0, /* security attributes */
                        OUTPUT hMailSlot). /* handle to mailslot 
                                              or INVALID_HANDLE_VALUE */
--------------------------------------------------------------------------------
FUNCTION ReadMailSlot RETURNS CHARACTER
  ( /* parameter-definitions */ ) :
 
  DEFINE VARIABLE cTempStr    AS CHARACTER NO-UNDO.
  DEFINE VARIABLE iBytesRead  AS INTEGER  NO-UNDO.
  DEFINE VARIABLE iResultCode AS INTEGER  NO-UNDO.
 
  /* allocate some space */
  cTempStr = FILL(' ', 512).
 
  RUN ReadFile (INPUT  hMailslot,
                OUTPUT cTempStr,
                INPUT  512,
                OUTPUT iBytesRead,
                INPUT  0,
                OUTPUT iResultCode).
 
 
  RETURN TRIM(cTempStr) + 
         (IF TRIM(cTempStr) = '' THEN '' ELSE CHR(10)).
 
END FUNCTION.
--------------------------------------------------------------------------------
  RUN CloseHandle(hMailslot,
                  OUTPUT iResultCode).

RUN CreateFile{&A}( INPUT cMailslotName:SCREEN-VALUE,
                    {&GENERIC_WRITE},
                    {&FILE_SHARE_READ},
                    0,
                    {&OPEN_EXISTING},
                    {&FILE_ATTRIBUTE_NORMAL},
                    0,   
                    OUTPUT hMailslot).
--------------------------------------------------------------------------------
FUNCTION WriteMailSlot RETURNS CHARACTER
  ( /* parameter-definitions */ ) :
 
  DEFINE VARIABLE iBytesWritten  AS  INTEGER     NO-UNDO.
  DEFINE VARIABLE iResultCode    AS  INTEGER     NO-UNDO.
 
  /* Write to the mailslot */
  cMsg =  "\\":U + cComputerName 
         + " - ":U 
         + cMsg:SCREEN-VALUE IN FRAME {&frame-name}.
 
  RUN WriteFile(INPUT  hMailslot,
                INPUT  cMsg,
                INPUT  LENGTH(cMsg) + 1,
                OUTPUT iBytesWritten,
                INPUT  0,
                OUTPUT iResultCode).
 
  IF iResultCode = 0 THEN
  DO:
    MESSAGE "Error on WriteFile. "  
            "Terminating client." 
            VIEW-AS ALERT-BOX.
    APPLY "window-close" TO {&window-name}.
  END.
  ELSE
    cMsg:SCREEN-VALUE = "".
 
 
  RETURN "".   /* Function return value. */
 
END FUNCTION.
--------------------------------------------------------------------------------
  RUN CloseHandle(hMailslot,
                  OUTPUT iResultCode).

Ping

by Marian EDU

Marian made a function to check if the host is alive or not. He wrote:

"if you want to get funky you can use gethostbyname to resolve the address, and use more options on IcmpSendEcho. but I don't see no utility in this. you probably want to check if a specific service is running on that machine. so it's more easy to use sockets and attempt to connect to the specific service."

/******************************************************************************
    Program:        ping.p
    
    Written By:     Marian EDU
    Written On:     September 2002
    
    Description:    Used to do ping or traceroute to one specific host address. 
                    Host name is not supported, works only with IP address.
    Parameters:     Input   -   IP address
                            -   ping && traceroute options
                            -   show result message flag
                    Output  -   host available flag
    Note:           Options:    You can specify ping && traceroute options 
                                as a comma delimited string.
                                ex: '-t,-n 10,-i 20,-l 32,-w 300'
                                    will send maximum 10 echo requests with
                                    32 bytes of data for each host on trace 
                                    route with the 300 milliseconds time-out
                                    and the maximum TTL is 20 and traceroute
                                    is enabled.
                            -t  enable traceroute
                            -n  number of request to send
                            -i  time to live TTL
                            -l  send packet size
                            -w  time-out in milliseconds to wait for reply
    Examples:       ping.p('66.218.71.86', '-t,-w 300,-n 10,-l 320,-i 20', TRUE, OUTPUT lAvail)
                            Will do a traceroute to yahoo servers using a 
                            320 bytes data packet, with a maximum hops number 
                            of 20 (TTL), for each host in trace route will send 
                            a maximum 10 echo request until will get an answer 
                            using 300 milliseconds time-out. 
                            Cause the show result message flag is true will 
                            display the traceroute result at the end.
                            
                                
    --------------------- Revision History ------------------
    
    Date:     Author        Change Description
    
    23/09/02  M EDU         Initial Release
    24/09/02  M EDU         Traceroute implemented, more options available
******************************************************************************/
DEFINE INPUT    PARAMETER pcHostAddr    AS CHARACTER NO-UNDO.
DEFINE INPUT    PARAMETER pcOptions     AS CHARACTER NO-UNDO.
DEFINE INPUT    PARAMETER plShowResults AS LOGICAL   NO-UNDO.
DEFINE OUTPUT   PARAMETER plAlive       AS LOGICAL   NO-UNDO.
DEFINE VARIABLE iNoRetry                AS INTEGER    NO-UNDO.
DEFINE VARIABLE iPacketSize             AS INTEGER    NO-UNDO.
DEFINE VARIABLE iTimeOut                AS INTEGER    NO-UNDO.
DEFINE VARIABLE iMaxHops                AS INTEGER    NO-UNDO.
DEFINE VARIABLE lEnableTrace            AS LOGICAL    NO-UNDO.
DEFINE VARIABLE ReqData                 AS MEMPTR     NO-UNDO.
DEFINE VARIABLE ReplyBuf                AS MEMPTR     NO-UNDO.
DEFINE VARIABLE PIP_OPTION_INFORMATION  AS MEMPTR     NO-UNDO.
DEFINE VARIABLE HopAddr                 AS MEMPTR     NO-UNDO.
DEFINE VARIABLE iCount      AS INTEGER    NO-UNDO   EXTENT 3.
DEFINE VARIABLE iRes        AS INTEGER    NO-UNDO.
DEFINE VARIABLE iIcmpHdl    AS INTEGER    NO-UNDO.
DEFINE VARIABLE iDstAddr    AS INTEGER    NO-UNDO.
DEFINE VARIABLE cHostAddr   AS CHARACTER  NO-UNDO.
DEFINE VARIABLE cEntry      AS CHARACTER  NO-UNDO.
DEFINE VARIABLE cMessage    AS CHARACTER  NO-UNDO.
/* API definitions                                  */
/* Microsoft has their own proprietary API for ping 
   and tracert implemented in ICMP.DLL.
   The functions in ICMP.DLL are not considered part 
   of the Win32 API and might not be supported in 
   future releases.                                 */
PROCEDURE IcmpCreateFile EXTERNAL 'ICMP.DLL':
    DEFINE RETURN PARAMETER phIcmp      AS LONG.
END PROCEDURE.
PROCEDURE IcmpCloseHandle EXTERNAL 'ICMP.DLL':
    DEFINE INPUT PARAMETER phIcmp       AS LONG.
END PROCEDURE.
PROCEDURE IcmpSendEcho EXTERNAL 'ICMP.DLL':
    DEFINE INPUT PARAMETER phIcmp       AS LONG.
    DEFINE INPUT PARAMETER DstAddr      AS LONG.
    DEFINE INPUT PARAMETER ReqData      AS LONG.
    DEFINE INPUT PARAMETER ReqSize      AS LONG.
    DEFINE INPUT PARAMETER ReqOptions   AS LONG. 
    DEFINE INPUT PARAMETER ReplyBuf     AS LONG.
    DEFINE INPUT PARAMETER ReplySize    AS LONG. 
    DEFINE INPUT PARAMETER Timeout      AS LONG.
    DEFINE RETURN PARAMETER ReplyCount  AS LONG.
END PROCEDURE.
PROCEDURE inet_addr EXTERNAL 'WS2_32.DLL':
    DEFINE INPUT  PARAMETER HostName AS CHARACTER.
    DEFINE RETURN PARAMETER HostAddr AS LONG.
END PROCEDURE.
PROCEDURE inet_ntoa EXTERNAL 'WS2_32.DLL':
    DEFINE INPUT  PARAMETER HostAddr AS LONG.
    DEFINE RETURN PARAMETER HostName AS MEMPTR.
END PROCEDURE.
/* default options                                  */
ASSIGN
    lEnableTrace = FALSE
    iPacketSize  = 32
    iTimeOut     = 5000
    iNoRetry     = 4
    iMaxHops     = 64 NO-ERROR.
/* parse options parameter                          */
DO iCount[1] = 1 TO NUM-ENTRIES(pcOptions):
    cEntry = ENTRY(iCount[1],pcOptions).
    CASE ENTRY(1,cEntry,' ':U):
        WHEN '-t':U THEN lEnableTrace = TRUE.
        WHEN '-w'   THEN iTimeOut     = INTEGER(ENTRY(NUM-ENTRIES(cEntry,' ':U),cEntry,' ':U)) NO-ERROR.
        WHEN '-n'   THEN iNoRetry     = INTEGER(ENTRY(NUM-ENTRIES(cEntry,' ':U),cEntry,' ':U)) NO-ERROR.
        WHEN '-l'   THEN iPacketSize  = INTEGER(ENTRY(NUM-ENTRIES(cEntry,' ':U),cEntry,' ':U)) NO-ERROR.
        WHEN '-i'   THEN iMaxHops     = INTEGER(ENTRY(NUM-ENTRIES(cEntry,' ':U),cEntry,' ':U)) NO-ERROR.
    END CASE.
END.
SET-SIZE(ReqData)  = iPacketSize + 1.
DO iCount[1] = 1 TO iPacketSize:
    PUT-STRING(ReqData,iCount[1]) = CHR(32 + iCount[2]).
    iCount[2] = iCount[2] + 1.
    IF iCount[2] >= 94 THEN iCount[2] = 0.
END.
SET-SIZE(ReplyBuf) = GET-SIZE(ReqData) + 28 + 1.
SET-SIZE(PIP_OPTION_INFORMATION) = 4 + 1.
SET-SIZE(HopAddr)  = 16.
RUN inet_addr(pcHostAddr, OUTPUT iDstAddr) NO-ERROR.
RUN IcmpCreateFile(OUTPUT iIcmpHdl) NO-ERROR.
/* if valid host IP address suplied                 */
IF iDstAddr NE -1 AND iIcmpHdl NE -1 THEN DO: 
    /* traceroute - increment TTL and send a new
                    echo request                    */
    IF lEnableTrace THEN DO iCount[1] = 1 TO iMaxHops:
        PUT-LONG(PIP_OPTION_INFORMATION,1) = iCount[1].
        DO iCount[2] = 1 TO iNoRetry:
            RUN IcmpSendEcho(iIcmpHdl,
                             iDstAddr,
                             GET-POINTER-VALUE(ReqData),
                             GET-SIZE(ReqData),
                             GET-POINTER-VALUE(PIP_OPTION_INFORMATION),
                             GET-POINTER-VALUE(ReplyBuf),
                             GET-SIZE(ReplyBuf),
                             iTimeOut,
                             OUTPUT iRes).
            IF iRes > 0 THEN LEAVE.
        END.
        RUN inet_ntoa(GET-LONG(ReplyBuf,1), OUTPUT HopAddr).
        /* format the treceroute result message     */
        IF plShowResults THEN 
            cMessage = cMessage + 
                        SUBSTITUTE('Reply from &1~t time=&2ms~t TTL=&3~n',
                                   GET-STRING(HopAddr,1),
                                   STRING(GET-LONG(ReplyBuf,9)),
                                   STRING(iCount[1])).
        IF iDstAddr = GET-LONG(ReplyBuf,1) THEN DO:
            plAlive = TRUE.
            LEAVE.
        END.
    END.
    /* ping - send a number of requests using 
              the given TTL, time-out, packet size  */
    ELSE DO iCount[1] = 1 TO iNoRetry:
        PUT-LONG(PIP_OPTION_INFORMATION,1) = iMaxHops.
        RUN IcmpSendEcho(iIcmpHdl,
                         iDstAddr,
                         GET-POINTER-VALUE(ReqData),
                         GET-SIZE(ReqData),
                         GET-POINTER-VALUE(PIP_OPTION_INFORMATION),
                         GET-POINTER-VALUE(ReplyBuf),
                         GET-SIZE(ReplyBuf),
                         iTimeOut,
                         OUTPUT iRes).
        IF iRes = 0 THEN NEXT.
        RUN inet_ntoa(GET-LONG(ReplyBuf,1), OUTPUT HopAddr).
        /* format the ping result message           */
        IF plShowResults THEN 
            cMessage = cMessage + 
                        SUBSTITUTE('Reply from &1~t bytes=&2~t~ttime=&3ms~t TTL=&4~n',
                                   GET-STRING(HopAddr,1),
                                   STRING(GET-LONG(ReplyBuf,13)),
                                   STRING(GET-LONG(ReplyBuf,9)),
                                   STRING(GET-LONG(ReplyBuf,21))).
        IF iRes > 0 THEN plAlive = TRUE.
    END.
END.
RUN IcmpCloseHandle(iIcmpHdl).
SET-SIZE(HopAddr)                   = 0.
SET-SIZE(PIP_OPTION_INFORMATION)    = 0.
SET-SIZE(ReqData)                   = 0.
SET-SIZE(ReplyBuf)                  = 0.
IF cMessage NE '':U THEN
    MESSAGE cMessage VIEW-AS ALERT-BOX.

The IP address of your local computer

by Bill Prew

The following procedure returns the ip adress and the host name for the local computer.

&SCOPED-DEFINE WSADESCRIPTION_LEN       256
&SCOPED-DEFINE WSASYS_STATUS_LEN        128
 
&SCOPED-DEFINE WSADATA_VERSION_LOW        1    /* WORD(2)  */
&SCOPED-DEFINE WSADATA_VERSION_HIGH       3    /* WORD(2)  */
&SCOPED-DEFINE WSADATA_DESCRIPTION        5    /* CHAR(WSADESCRIPTION_LEN + 1) */ 
&SCOPED-DEFINE WSADATA_SYSTEM_STATUS    262    /* CHAR(WSASYS_STATUS_LEN + 1)  */ 
&SCOPED-DEFINE WSADATA_MAX_SOCKETS      391    /* SHORT(4) */ 
&SCOPED-DEFINE WSADATA_MAX_UDP          395    /* SHORT(4) */ 
&SCOPED-DEFINE WSADATA_VENDOR_INFO      399    /* CHAR*(4) */ 
&SCOPED-DEFINE WSADATA_LENGTH           403   
 
&SCOPED-DEFINE HOSTENT_NAME               1    /* CHAR*(4)  */
&SCOPED-DEFINE HOSTENT_ALIASES            5    /* CHAR**(4) */ 
&SCOPED-DEFINE HOSTENT_ADDR_TYPE          9    /* SHORT(2)  */ 
&SCOPED-DEFINE HOSTENT_ADDR_LENGTH       11    /* SHORT(2)  */ 
&SCOPED-DEFINE HOSTENT_ADDR_LIST         13    /* CHAR**(4) */ 
&SCOPED-DEFINE HOSTENT_LENGTH            16
 
 
PROCEDURE i-GetTcpInfo:
/*------------------------------------------------------------------------
  Procedure   : i-GetTcpInfo
 
  Description : Return the windows TCP host name and address of this PC.
 
  Parms       : - Host name. (OUTPUT, CHARACTER)
                - Host address. (OUTPUT, CHARACTER):
 
  Sample usage: RUN i-GetTcpInfo (OUTPUT w-TcpName,
                                  OUTPUT w-TcpAddr).
 
  Notes       : -
------------------------------------------------------------------------*/
  DEFINE OUTPUT PARAMETER p-TcpName      AS CHARACTER NO-UNDO.
  DEFINE OUTPUT PARAMETER p-TcpAddr      AS CHARACTER NO-UNDO.
 
  DEFINE VARIABLE         w-TcpName      AS CHARACTER NO-UNDO.
  DEFINE VARIABLE         w-Length       AS INTEGER   NO-UNDO.
  DEFINE VARIABLE         w-Return       AS INTEGER   NO-UNDO.
  DEFINE VARIABLE         ptr-WsaData    AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE         w-Hostent      AS INTEGER   NO-UNDO.
  DEFINE VARIABLE         ptr-Hostent    AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE         ptr-AddrString AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE         ptr-AddrList   AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE         ptr-ListEntry  AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE         w-TcpLong      AS INTEGER   NO-UNDO.
 
  /* Initialize return values */
  ASSIGN p-TcpName = ?
         p-TcpAddr = ?
         .
 
  /* Allocate work structure for WSADATA */
  SET-SIZE(ptr-WsaData) = {&WSADATA_LENGTH}.
 
  /* Ask Win32 for winsock usage */
  RUN WSAStartup (INPUT  257,        /* requested version 1.1 */
                  INPUT  GET-POINTER-VALUE(ptr-WsaData),
                  OUTPUT w-Return).
 
  /* Release allocated memory */
  SET-SIZE(ptr-WsaData) = 0.
 
  /* Check for errors */
  IF w-Return NE 0 THEN DO:
    MESSAGE "Error accessing WINSOCK support." VIEW-AS ALERT-BOX.
    RETURN.
  END.
 
  /* Set up variables */
  ASSIGN w-Length  = 100
         w-TcpName = FILL(" ", w-Length)
         .
 
  /* Call Win32 routine to get host name */
  RUN gethostname (OUTPUT w-TcpName,
                   INPUT  w-Length,
                   OUTPUT w-Return).
 
  /* Check for errors */
  IF w-Return NE 0 THEN DO:
    MESSAGE "Error getting tcp name." VIEW-AS ALERT-BOX.
    RUN WSACleanup (OUTPUT w-Return).
    RETURN.
  END.
 
  /* Pass back gathered info */
  /* remember: the string is null-terminated so there is a CHR(0)
               inside w-TcpName. We have to trim it:  */
  p-TcpName = ENTRY(1,w-TcpName,CHR(0)).
 
  /* Call Win32 routine to get host address */
  RUN gethostbyname (INPUT  w-TcpName,
                     OUTPUT w-Hostent).
 
  /* Check for errors */
  IF w-Hostent EQ 0 THEN DO:
    MESSAGE "Error resolving host name." VIEW-AS ALERT-BOX.
    RUN WSACleanup (OUTPUT w-Return).
    RETURN.
  END.
 
  /* Set pointer to HostEnt data structure */
  SET-POINTER-VALUE(ptr-Hostent) = w-Hostent.
 
  /* "Chase" pointers to get to first address list entry */
  SET-POINTER-VALUE(ptr-AddrList)  = GET-LONG(ptr-Hostent, 
                                              {&HOSTENT_ADDR_LIST}).
  SET-POINTER-VALUE(ptr-ListEntry) = GET-LONG(ptr-AddrList, 1).
  w-TcpLong                        = GET-LONG(ptr-ListEntry, 1).
 
  RUN inet_ntoa (INPUT  w-TcpLong,
                 OUTPUT ptr-AddrString).
 
  /* Pass back gathered info */
  p-TcpAddr = GET-STRING(ptr-AddrString, 1).
 
  /* Terminate winsock usage */
  RUN WSACleanup (OUTPUT w-Return).
 
END PROCEDURE.

Definitions used in this procedure, not listed in windows.p :

PROCEDURE gethostname EXTERNAL "wsock32.dll" :
  DEFINE OUTPUT       PARAMETER p-Hostname      AS CHARACTER.
  DEFINE INPUT        PARAMETER p-Length        AS LONG.
  DEFINE RETURN       PARAMETER p-Return        AS LONG.
END PROCEDURE.
 
PROCEDURE gethostbyname EXTERNAL "wsock32.dll" :
  DEFINE INPUT        PARAMETER p-Name          AS CHARACTER.
  DEFINE RETURN       PARAMETER p-Hostent       AS LONG.
END PROCEDURE.
 
PROCEDURE inet_ntoa EXTERNAL "wsock32.dll" :
  DEFINE INPUT        PARAMETER p-AddrStruct    AS LONG.
  DEFINE RETURN       PARAMETER p-AddrString    AS MEMPTR.
END PROCEDURE.
 
PROCEDURE WSAStartup EXTERNAL "wsock32.dll" :
  DEFINE INPUT        PARAMETER p-VersionReq    AS SHORT.
  DEFINE INPUT        PARAMETER ptr-WsaData     AS LONG.
  DEFINE RETURN       PARAMETER p-Return        AS LONG.
END PROCEDURE.
 
PROCEDURE WSACleanup EXTERNAL "wsock32":
  DEFINE RETURN       PARAMETER p-Return        AS LONG.
END PROCEDURE.

Notes

On Windows 98 and perhaps other versions of Windows you may prefer to use "ws32_2.dll" instead "wsock32.dll".

bugfix

June 22, 1999

Joern Winther found and solved the following bug:

   p-TcpName = w-TcpName. 

should be

   p-TcpName = ENTRY(1,w-TcpName,CHR(0)).

to get rid of the terminating null.

Dump raw data to printer

By Nenad Orlovic, norlovic@zg.tel.hr

Suppose you have a file that contains printer control codes, and now you want to send this file to a printer. The file may have been created by a report engine when the port was set to "FILE:".
The following procedure copies the file to a printer.
This example will send file to printer even if in printer properties port is FILE:
This is because variable OutFileName = "", but it can be changed to a filename or perhaps even to a UNC-name for a printer.
See the notes near the bottom of this page.

DEFINE INPUT PARAMETER PrinterName AS CHARACTER NO-UNDO. /* As set in Printer properties */
DEFINE INPUT PARAMETER FILENAME AS CHARACTER NO-UNDO.
 
 
DEFINE VARIABLE X AS INTEGER NO-UNDO.
DEFINE VARIABLE hPrinter AS INTEGER NO-UNDO.
DEFINE VARIABLE hFile AS INTEGER NO-UNDO.
DEFINE VARIABLE pBuf AS MEMPTR NO-UNDO.
DEFINE VARIABLE FileSize AS INTEGER NO-UNDO.
DEFINE VARIABLE iSize AS INTEGER NO-UNDO.
DEFINE VARIABLE xSize AS INTEGER NO-UNDO.
DEFINE VARIABLE pFileName AS MEMPTR NO-UNDO.
DEFINE VARIABLE OutFileName AS CHARACTER  NO-UNDO.
DEFINE VARIABLE pOutFileName AS MEMPTR NO-UNDO.
DEFINE VARIABLE DataType AS CHARACTER  NO-UNDO.
DEFINE VARIABLE pDataType AS MEMPTR NO-UNDO.
DEFINE VARIABLE pDocInfo AS MEMPTR NO-UNDO.
 
   RUN OpenPrinterA (PrinterName,OUTPUT hPrinter,0, OUTPUT X).
   IF X = 0
   THEN MESSAGE "Error opening printer: " PrinterName VIEW-AS ALERT-BOX.
   ELSE DO:
     RUN CreateFileA (FILENAME , -2147483648,0,0,3,128,0,OUTPUT hFile). /* -2147483648 = $80000000 */
     IF hFile = -1
     THEN MESSAGE "Error opening file: " FILENAME VIEW-AS ALERT-BOX.
     ELSE DO:
       RUN GetFileSize (hFile,0,OUTPUT FileSize).
       IF FileSize = -1
       THEN MESSAGE "Wrong file size" VIEW-AS ALERT-BOX.
       ELSE DO:
         SET-SIZE(pBuf) = FileSize.
 
         RUN ReadFile(hFile,pBuf,FileSize,OUTPUT iSize,0, OUTPUT X).
         IF X = 0
         THEN MESSAGE "Error reading file: " FILENAME VIEW-AS ALERT-BOX.
         ELSE DO:
           IF iSize = 0
           THEN MESSAGE "Attempt to read beyond end of file:" FILENAME VIEW-AS ALERT-BOX.
           ELSE DO:
             OutFileName = "".
             DataType = "RAW".
             SET-SIZE(pDocInfo) = 12.
             SET-SIZE(pFileName) = LENGTH(FILENAME) + 1.
             PUT-STRING(pFileName,1) = FILENAME.
             SET-SIZE(pOutFileName) = LENGTH(OutFileName) + 1.
             PUT-STRING(pOutFileName,1) = OutFileName.
             SET-SIZE(pDataType) = LENGTH(DataType) + 1.
             PUT-STRING(pDataType,1) = DataType.
             PUT-LONG(pDocInfo,1) = GET-POINTER-VALUE(pFileName).
             PUT-LONG(pDocInfo,5) = GET-POINTER-VALUE(pOutFileName).
             PUT-LONG(pDocInfo,9) = GET-POINTER-VALUE(pDataType).
 
             RUN StartDocPrinterA (hPrinter,1,pDocInfo,OUTPUT X).
             IF X = 0 THEN DO:
                 RUN GetLastError(OUTPUT X).
                 MESSAGE "Error : " X VIEW-AS ALERT-BOX.
             END.
 
             RUN WritePrinter(hPrinter,pBuf,iSize,OUTPUT xSize,OUTPUT X).
             IF X = 0 THEN DO:
                 RUN GetLastError(OUTPUT X).
                 MESSAGE "Error writing to printer: " PrinterName iSize xsize X VIEW-AS ALERT-BOX.
             END.
 
             RUN EndDocPrinter(hPrinter,OUTPUT X).
           END.
         END.
       END.
       RUN CloseHandle(hFile,OUTPUT X).
       IF X = 0 THEN MESSAGE "Error closing file: " FILENAME.
     END.
 
 
     RUN ClosePrinter(hPrinter,OUTPUT X).
     IF X = 0
     THEN MESSAGE "Error closing printer: " PrinterName VIEW-AS ALERT-BOX.
   END.
 
   SET-SIZE(pBuf) = 0.
   SET-SIZE(pDocInfo) = 0.
   SET-SIZE(pFileName) = 0.
   SET-SIZE(pOutFileName) = 0.
   SET-SIZE(pDataType) = 0.
 
 
/******************/
/* DLL Procedures */
/******************/
PROCEDURE GetLastError EXTERNAL "kernel32.dll" :
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE StartDocPrinterA EXTERNAL "winspool.drv" :
    DEFINE INPUT PARAMETER hPrinter AS LONG.
    DEFINE INPUT PARAMETER Level AS LONG.
    DEFINE INPUT PARAMETER pDocInfo AS MEMPTR.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE EndDocPrinter EXTERNAL "winspool.drv" :
    DEFINE INPUT PARAMETER hPrinter AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE CreateFileA EXTERNAL "kernel32.dll" :
    DEFINE INPUT PARAMETER lpFileName AS CHARACTER.
    DEFINE INPUT PARAMETER dwDesiredAccess AS LONG.
    DEFINE INPUT PARAMETER dwShareMode AS LONG.
    DEFINE INPUT PARAMETER lpSecurityAttributes AS LONG.
    DEFINE INPUT PARAMETER dwCreationDistribution AS LONG.
    DEFINE INPUT PARAMETER dwFlagsAndAttributes AS LONG.
    DEFINE INPUT PARAMETER hTemplateFile AS LONG.
    DEFINE RETURN PARAMETER hFile AS LONG.
END PROCEDURE.
 
PROCEDURE ReadFile EXTERNAL "kernel32.dll" :
    DEFINE INPUT PARAMETER hFile AS LONG.
    DEFINE INPUT PARAMETER lpBuffer AS MEMPTR.
    DEFINE INPUT PARAMETER nNumberOfBytesToRead AS LONG.
    DEFINE OUTPUT PARAMETER  lpNumberOfBytesRead AS LONG.
    DEFINE INPUT PARAMETER lpOverlapped AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE WritePrinter EXTERNAL "winspool.drv" :
    DEFINE INPUT PARAMETER hPrinter AS LONG.
    DEFINE INPUT PARAMETER  pBuf AS MEMPTR.
    DEFINE INPUT PARAMETER cbBuf AS LONG.
    DEFINE OUTPUT PARAMETER lpdwWritten AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE OpenPrinterA EXTERNAL "winspool.drv" :
    DEFINE INPUT PARAMETER pPrinterName AS CHARACTER.
    DEFINE OUTPUT PARAMETER phPrinter AS LONG.
    DEFINE INPUT PARAMETER pDefault AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE ClosePrinter EXTERNAL "winspool.drv" :
    DEFINE INPUT PARAMETER hPrinter AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE GetFileSize EXTERNAL "kernel32.dll" :
    DEFINE INPUT PARAMETER hFile AS LONG.
    DEFINE INPUT PARAMETER lpFileSizeHigh AS LONG.
    DEFINE RETURN PARAMETER FileSize AS LONG.
END PROCEDURE.
 
PROCEDURE CloseHandle EXTERNAL "kernel32.dll" :
    DEFINE INPUT PARAMETER hObject AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.

notes

Note from Valther Bernardi:

The procedure fails if the printer is a local printer and not a network printer.
For local printers the variable OutFileName need to be initialized to the value of the device associated to printer (i.e. LPT1:). For retrieving the port name associated to the printer you can use EnumPrinters

Note from Brian Maher:

In Progress 4GL you could simply output to the printer and then do a PUT CONTROL NULL which switches us into "windows passthru printing" mode.

Get a list of available printers

using the EnumPrinters procedure

EnumPrinter retrieves a list of available printers, that is: local installed printers and also printers made available by the network.
Actually EnumPrinters retrieves an array of PRINTER_INFO_X records (where X stands for level: will be explained later). Each PRINTER_INFO_X record contains information about a single printer, in this example we will only show the Printername (like "HP Laserjet 4L") and Portname (like "LPT1:").
Let's take a look at the source first and explain later.

{windows.i}
 
DEFINE VARIABLE pPrinterEnum  AS MEMPTR NO-UNDO.
DEFINE VARIABLE pcbNeeded     AS INTEGER NO-UNDO.
DEFINE VARIABLE pcReturned    AS INTEGER NO-UNDO.
DEFINE VARIABLE RetValue      AS INTEGER NO-UNDO.
 
DEFINE VARIABLE pPrinterInfo  AS MEMPTR NO-UNDO.
DEFINE VARIABLE StructSize    AS INTEGER INITIAL 84.
 
DEFINE VARIABLE i             AS INTEGER NO-UNDO.
DEFINE VARIABLE lpPrinterName AS MEMPTR  NO-UNDO.
DEFINE VARIABLE lpPortName    AS MEMPTR  NO-UNDO.
 
  /* The first call to EnumPrinters is only to 
     get the required memory size */
 
   SET-SIZE(pPrinterEnum) = 30.  /* A default bobo value */
 
   RUN EnumPrinters{&A} IN hpApi(2, /* = PRINTER_ENUM_LOCAL */
                                 "", 
                                 2, 
                                 GET-POINTER-VALUE(pPrinterEnum),
                                 GET-SIZE(pPrinterEnum), 
                                 OUTPUT pcbNeeded, 
                                 OUTPUT pcReturned, 
                                 OUTPUT RetValue).
 
   /* RetValue will now be FALSE (=error) because we did not
      supply enough memory. But at least we know now how much
      memory was required (pcbNeeded) and also how many printers
      were found (pcReturned) */
 
   /* no printers installed, then return (rare) */
   IF pcbNeeded=0 THEN DO:
      MESSAGE "No printers found".
      RUN DeAlloc.
      RETURN.
   END.
 
   /* Reset the size of pPrinterEnum to the correct size */
   SET-SIZE(pPrinterEnum) = 0.
   SET-SIZE(pPrinterEnum) = pcbNeeded.
 
   /* The second call actually fills the pPrinterEnum structure */
 
   RUN EnumPrinters{&A} IN hpApi(2,  /* = PRINTER_ENUM_LOCAL */
                                 "", 
                                 2,
                                 GET-POINTER-VALUE (pPrinterEnum),
                                 GET-SIZE(pPrinterEnum), 
                                 OUTPUT pcbNeeded,
                                 OUTPUT pcReturned, 
                                 OUTPUT RetValue).
 
   /* pPrinterEnum holds a couple of PRINTER_INFO_2 records.
      the number of records is pcReturned.
      the number of bytes copied to pPrinterEnum is pcbNeeded.
      size of one PRINTER_INFO_2 record is 84 bytes.
   */
 
   DO i=0 TO pcReturned - 1 :       
 
      SET-POINTER-VALUE(pPrinterInfo) = GET-POINTER-VALUE(pPrinterEnum) + (i * StructSize).
 
      /* the second LONG field in the PRINTER_INFO_2 structure is 
         a pointer to a string holding the printer name */
      SET-POINTER-VALUE(lpPrinterName) = GET-LONG(pPrinterInfo, 5).
 
      /* the 4th LONG field in the PRINTER_INFO_2 structure is 
         a pointer to a string holding the port name */
      SET-POINTER-VALUE(lpPortName)    = GET-LONG(pPrinterInfo,13).
 
      MESSAGE "printername=" GET-STRING(lpPrinterName,1) SKIP
              "portname="    GET-STRING(lpPortName,1)
               VIEW-AS ALERT-BOX.
 
   END.
 
   /* Clean Up  */
   RUN DeAlloc.
 
PROCEDURE DeAlloc:
   SET-SIZE(pPrinterEnum) = 0.
END.

Explanations

OS-version considerations

The first parameter (flags) in EnumPrinters is set to PRINTER_ENUM_LOCAL but Windows 95 will also enumerate network printers because these are also handled by the local print provider. Windows NT will strictly enumerate locally installed printers. When you want to enumerate network printers on NT you will have to use other parameters.
The third parameter (level) is set to 2 indicating we expect records of type PRINTER_INFO_2. Windows 95 supports only levels 1,2,5 and NT supports only levels 1,2,4.
structsize=84 is only true for Level=2.
Brad Long enhanced the previous example to support all other PRINTER_INFO types and make it independent of Windows version. The sourcefile is attached.

About the memory pointers

This piece of source is also interesting for those who struggle with memptr variables (aren't we all?).
pPrinterEnum is a pointer to an array of PRINTER_INFO_2 records. The pointer to the first record is the same as the pointer to the array, the pointer to the second record is (first) + structsize, and so on.
A PRINTER_INFO_2 record does not contain strings but pointers to strings, this indirection is solved by the lpPortName and lpPrinterName MEMPTR variables. Of course you should always use statements like SET-SIZE(memptrvar)=0 for each MEMPTR variable near the end of your procedure, but in this particular example you should not do this for pPrinterInfo because the value of this variable points to memory inside the scope of pPrinterEnum. So if you deallocate pPrinterEnum you automatically deallocate pPrinterInfo. But what about the two string-pointers lpPortName and lpPrinterName, you wonder? Well, these also point to locations within pPrinterEnum as we will see:
There are only 2 printers installed on my PC, so I would expect that pcbNeeded=(2 * 84)=168 but the function returned 948. Almost 700 byte too much: this is where the strings are stored that are pointed to by the several string-pointers in the PRINTER_INFO_2 records.
That is smart thinking by Microsoft: you now have local copies of the strings so the pointers don't have to point to protected memory, and it also solves the important question which process should be responsible for deallocating the string space. The strings are inside Your block of memory so You deallocate them. And it is all done automatically by simple deallocating pPrinterEnum.
Here's a small map to illustrate it all:

Attachments

wingetprinters.p.zip : example

Get a List of Paper bins for a Printer

The attached code returns an array of Bin IDs and Bin Names for the printer/port specified in pcPrinterName and pcPrinterPort.

How to get the printer name

16 Bit

In 16-bit windows you can find the printer name in WIN.INI, section "windows" key "device".
For example:

[windows]
device=HP LaserJet 4L,HPPCL5MS,LPT1:

To read 'WIN.INI' you use the procedure GetProfileString.
To read any other ini-file you use the procedure GetPrivateProfileString.
Example:

{windows.i}
DEFINE VARIABLE printername AS CHARACTER    NO-UNDO.
DEFINE VARIABLE cchRet      AS INTEGER NO-UNDO.
 
printername = FILL(" ",100).  /* = allocate memory, don't forget! */
RUN GetProfileString{&A} IN hpApi ("windows",
                                   "device",
                                   "-unknown-,",
                                   OUTPUT printername,
                                   LENGTH(printername),
                                   OUTPUT cchRet).
 
/* split name from driver and port. Note that the 
   default "-unknown-," must have at leat one comma or 
   the ENTRY function may raise an error  */
printername = ENTRY(1,printername).
 
/* use the result */
IF printername="-unknown-" THEN
   MESSAGE "something is wrong with your WIN.INI" 
           VIEW-AS ALERT-BOX.
ELSE
   MESSAGE "your default printer is: " printername
           VIEW-AS ALERT-BOX.

The above example was used for an in-depth explanation of parameter types on page using a MEMPTR parameter for a CHAR. It also explains why the FILL statement is important.
Of course you can also use the 4GL procedure GET-KEY-VALUE to read this information, as shown in topic "printing: using StartDoc"

32 Bit

Here is the easiest way:

  Printername = SESSION:PRINTER-NAME.

Although INI files are obsolete in 32-bits Windows versions, you should still use GetProfileString to find the default printer. The function will not actually read the INI file but will read from Registry.
If you know the key where the printer name is stored in Registry, you could use the following code example but you should not do that. It is always a bad idea to use hardcoded paths because Microsoft does not commit to support those paths forever. For example: Windows 95 and NT 4.0 don't use the same key. Function GetProfileString however is guaranteed to return the right information on all 32-bit Windows versions.
but it's still interesting to have a registry example, so here it goes:

DEFINE VARIABLE Printername AS CHARACTER.
 
LOAD "System" BASE-KEY "HKEY_CURRENT_CONFIG".
USE "System".
GET-KEY-VALUE SECTION "CurrentControlSet\Control\Print\Printers"
    KEY "default" VALUE Printername.
UNLOAD "System".
 
/* code example by Joseph Richardson */

How to print an ASCII file

The example program printfile.p demonstrates how to print an ascii-file using GDI functions.
The program prints a header and a footer on every page using a proportional font. The page header contains the filename (right aligned). The page footer contains the date (left aligned), time (centered) and page number (right aligned).
The contents of the ascii-file is printed in a non-proportional font (Courier New).
The procedure printfile.p has currently only one input parameter: the filename of the ascii-file to print.
The definition section contains some variables who could also have been used as input parameters:

/* ================================================================= 
   file    : printfile.p
   purpose : print a text file
   usage   : RUN printfile.p ("printfile.p").
   tested  : only on Windows 98 with local printer (HP Laserjet 4)
   ================================================================= */
DEFINE INPUT PARAMETER p-Filename   AS CHARACTER NO-UNDO.
 
/* these variables could also be useful as input parameters: */
DEFINE VARIABLE p-Landscape   AS LOGICAL NO-UNDO INITIAL NO.   /* Orientation is Landscape or Portrait */
DEFINE VARIABLE p-Silent      AS LOGICAL NO-UNDO INITIAL YES.  /* show no message boxes (on error)     */
DEFINE VARIABLE p-Devicename  AS CHARACTER    NO-UNDO.         /* if "" then default printer           */
DEFINE VARIABLE p-docname     AS CHARACTER    NO-UNDO.         /* if "" then p-Filename                */
DEFINE VARIABLE p-Leftmargin  AS DECIMAL NO-UNDO INITIAL 1.0.  /* left margin (inches) from paper edge */
DEFINE VARIABLE p-fontsize    AS INTEGER NO-UNDO INITIAL 9.    /* pointsize for bodyfont               */

API-procedures used in printfile.zip: CreateDC, DeleteDC, DocumentProperties, GetProfileString, StartDoc, EndDoc, StartPage, EndPage, TextOut, SetTextAlign, GetDeviceCaps, MoveToEx, LineTo, SelectObject, DeleteObject, GetTextMetrics, CreateFont, MulDiv.

Attachments

printfile.zip : example

Print an HTML document

The attached example shows how to use the WebBrowser control (in shdocvw.dll) to print an HTML page. The example does __not__ show how to change headers/footers at run-time.

Attachments

printurl.zip : a dialog with WebBrowser control

Print Preview

by Nickolay Borshukov

Download attached file: preview.zip
The example programs in preview.zip are an extended version of printfile.zip (see topic how to print an ASCII file).
The most noticeable extensions are:
* long lines are wrapped to the next line.
* the print layout can be viewed in a Preview window. This window is made with P4GL and Windows API-calls

API-procedures used in preview.zip (in addition to the ones in printfile.p) : CreateCompatibleDC, CreateCompatibleBitmap, SetBkMode, SetTextColor, PatBlt, StretchBlt, GetTextExtentPoint32

Attachments

preview.zip : example by Nickolay Borshukov

printing: using StartDoc

Notice how this source uses the GET-KEY-VALUE function to retrieve information about the default printer. There are a couple of other methods to get the same information, see topic GetDefaultPrinter.
Besides using the default printer you can also use a different printer; those other printers can be picked using the EnumPrinters function.
code example by Roland the Pijper, converted to 32-bit by Jurjen

{windows.i}
 
  DEFINE VARIABLE windir        AS CHARACTER.
  DEFINE VARIABLE pdocname      AS MEMPTR.
  DEFINE VARIABLE poutbuf       AS MEMPTR.
  DEFINE VARIABLE lpdocinfo     AS MEMPTR.
  DEFINE VARIABLE pfilename     AS MEMPTR.
 
  DEFINE VARIABLE outsize       AS INTEGER   NO-UNDO.
  DEFINE VARIABLE printerhDC    AS INTEGER   NO-UNDO.     
  DEFINE VARIABLE apistatus     AS INTEGER   NO-UNDO.
 
  DEFINE VARIABLE docname       AS CHARACTER NO-UNDO.
  DEFINE VARIABLE devicebuf     AS CHARACTER NO-UNDO.
  DEFINE VARIABLE driverbuf     AS CHARACTER NO-UNDO.
  DEFINE VARIABLE initbuf       AS CHARACTER NO-UNDO.
  DEFINE VARIABLE outbuf        AS CHARACTER NO-UNDO.  
  DEFINE VARIABLE windowsdir    AS CHARACTER NO-UNDO.
  DEFINE VARIABLE winini        AS CHARACTER NO-UNDO.
  DEFINE VARIABLE printerdev    AS CHARACTER NO-UNDO.
  DEFINE VARIABLE FILENAME      AS CHARACTER NO-UNDO.
  DEFINE VARIABLE tekst         AS CHARACTER NO-UNDO.
 
  /* Get printer info from WIN.INI */
  windir = FILL("x", 260).
  RUN GetWindowsDirectoryA IN hpApi(OUTPUT windir,
                                    LENGTH(windir), 
                                    OUTPUT outsize).
  ASSIGN windowsdir = SUBSTRING(windir,1,outsize)
         winini     = windowsdir + "\WIN.INI".   
  LOAD winini.       
  USE winini.
  GET-KEY-VALUE SECTION "windows" KEY "device" VALUE printerdev. 
  UNLOAD winini.
  IF printerdev = "" THEN DO:
      RUN Err ("Could not locate printer device!"). 
      RETURN.
  END. 
  ASSIGN devicebuf = ENTRY(1,printerdev).
         driverbuf = ENTRY(2,printerdev).
         outbuf    = ENTRY(3,printerdev).  
 
  docname = "test".
  /* Setup pointers to the strings needed in the lpdocinfo STRUCT */
  SET-SIZE(pdocname)     = LENGTH(docname) + 1.
  PUT-STRING(pdocname,1) = docname.  
  SET-SIZE(poutbuf)      = LENGTH(outbuf) + 1.
  PUT-STRING(poutbuf,1)  = outbuf.
 
  /* Load up the lpdocinfo STRUCT */
  SET-SIZE(lpdocinfo)    =   4    /* INTEGER cbSize          */
                           + 4    /* pointer lpszDocName */
                           + 4.   /* pointer lpszOutput  */
  PUT-LONG(lpdocinfo,1) =  12.    /* size of the STRUCT  */ 
  PUT-LONG(lpdocinfo,5)  = GET-POINTER-VALUE(pdocname). /* pointer to CHARACTER */ 
  PUT-LONG(lpdocinfo,9)  = GET-POINTER-VALUE(poutbuf).  /* pointer to CHARACTER */
 
  tekst = "bla bla".
 
  /* Print it! */
  RUN adecomm/_setcurs.p ("WAIT").
  RUN CreateDCA (driverbuf, devicebuf, outbuf, 0, OUTPUT printerhDC). 
  RUN StartDocA IN hpApi(INPUT printerhDC, 
                         INPUT GET-POINTER-VALUE(lpdocinfo), 
                         OUTPUT apistatus). /* is printjob id */
  RUN StartPage IN hpApi(INPUT printerhDC, OUTPUT apistatus).
 
  RUN TextOutA IN hpApi(printerhDC, 800, 450, tekst, LENGTH(tekst), OUTPUT apistatus).
 
  IF apistatus=0  /* 0=FALSE */ THEN 
     MESSAGE "There was an error during TextOut "
             VIEW-AS ALERT-BOX ERROR.
 
  RUN EndPage IN hpApi(printerhDC, OUTPUT apistatus).
  RUN EndDoc IN hpApi(printerhDC, OUTPUT apistatus).
  RUN DeleteDC(printerhDC, OUTPUT apistatus).
 
  /* Clean Up */
  SET-SIZE(lpdocinfo) = 0.
  SET-SIZE(pdocname)  = 0.
  SET-SIZE(poutbuf)   = 0.
  RUN adecomm/_setcurs.p ("").

Printscreen

by Jurjen, improved by Ian Keene

/* ==============================================================
   file    : printscreen.p
   by      : Jurjen Dijkstra (Modified by Ian Keene Oct 2003)
   dd      : 05/16/1999
   purpose : draw a window to the default printer.
   usage   : RUN printscreen.p ({&WINDOW-NAME}:HWND, YES).
   parms   : hWindow (integer)
                HWND of the 'widget' to be drawn
             GetParent (logical)
               -Use YES if HWND is a Progress window widget
                so printscreen.p will draw the border/titlebar.
               -Use NO for all other widgets.
   ============================================================== */
DEFINE INPUT PARAMETER hWindow   AS INTEGER NO-UNDO.  /* HWND                        */
DEFINE INPUT PARAMETER GetParent AS LOGICAL NO-UNDO.  /* hWindow=GetParent(hWindow)? */

RUN MakeDocument.

/* API definitions used in this proc have been moved to printscreen.i */
{printscreen.i}

PROCEDURE MakeDocument :
  DEFINE VARIABLE hDC         AS INTEGER   NO-UNDO.
  DEFINE VARIABLE lpDocInfo   AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE lpDocName   AS MEMPTR    NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER   NO-UNDO.
  DEFINE VARIABLE prt-buf     AS CHARACTER NO-UNDO.
  DEFINE VARIABLE prt-out     AS CHARACTER NO-UNDO.
  DEFINE VARIABLE err-check   AS INTEGER   NO-UNDO.
  DEFINE VARIABLE drbuf       AS CHARACTER NO-UNDO.
  DEFINE VARIABLE out-buf     AS CHARACTER NO-UNDO.
  DEFINE VARIABLE prt-hwnd    AS INTEGER   NO-UNDO.

  ASSIGN prt-out = FILL(" ",127). /* ALLOCATE MEMORY */
  RUN GetProfileStringA (INPUT "WINDOWS",
                         INPUT "DEVICE",
                         INPUT "-unknown-,",
                         OUTPUT prt-out,
                         INPUT LENGTH(prt-out),
                         OUTPUT err-check). 

  IF prt-out = "-unknown-," THEN DO:
     MESSAGE "Aborted, Cannot Determine Default Printer." SKIP 
             VIEW-AS ALERT-BOX INFORMATION.
     RETURN. 
  END. 

  ASSIGN prt-buf = ENTRY(1,prt-out)
         drbuf   = ENTRY(2,prt-out)
         out-buf = ENTRY(3,prt-out).

  /* OPEN THE PRINTER */
  RUN OpenPrinterA (INPUT prt-buf,
                    OUTPUT prt-hwnd,
                    INPUT 0).
  RUN CreateDCA ( "WINSPOOL",
                  prt-buf,
                  0,
                  0,
                  OUTPUT hDC) .
  IF hDC = 0 THEN DO:
      MESSAGE "Error during CreateDCA in PrintScreen procedure" 
              view-as ALERT-BOX INFORMATION.
      RETURN.
  END.

  SET-SIZE  (lpDocName)   = LENGTH("PrintScreen") + 1.
  PUT-STRING(lpDocName,1) = "PrintScreen".
  SET-SIZE  (lpDocInfo)   = 12.
  PUT-LONG  (lpDocInfo,1) = 12.
  PUT-LONG  (lpDocInfo,5) = GET-POINTER-VALUE(lpDocName).
  PUT-LONG  (lpDocInfo,9) = 0.

  RUN StartDocA ( hDC,
                  GET-POINTER-VALUE(lpDocInfo),
                  OUTPUT ReturnValue).
  IF ReturnValue < 1 THEN
     MESSAGE "Error during StartDoc in PrintScreen procedure" 
             view-as ALERT-BOX INFORMATION.
  ELSE DO:
     RUN StartPage (hDC, OUTPUT ReturnValue).
     IF ReturnValue < 1 THEN
        MESSAGE "Error during StartPage in PrintScreen procedure" 
                view-as ALERT-BOX INFORMATION.
     ELSE DO:
        RUN PrintWindow (hDC, hWindow).
        RUN EndPage     (hDC, OUTPUT ReturnValue).
     END.
     RUN EndDoc   (hDC, OUTPUT ReturnValue).
  END.

  /* cleanup */
  RUN DeleteDC (hDC, OUTPUT ReturnValue).
  SET-SIZE(lpDocInfo) = 0.
  SET-SIZE(lpDocName) = 0.

END PROCEDURE. /* MakeDocument */

PROCEDURE PrintWindow :
/*------------------------------------------------------------------------------
  Notes: a couple of extra parameters would be nice, like:
         input  leftmargin, rightmargin, Ytop
         output Ybottom
------------------------------------------------------------------------------*/
  define input parameter hdcDest as INTEGER NO-UNDO.  /* Printer                    */
  define input parameter hWin    as INTEGER NO-UNDO.  /* windows handle to progress window to print */

  DEFINE VARIABLE hdcWin        as integer no-undo.   /* hdc window                      */
  DEFINE VARIABLE PrintHorzRes  as integer no-undo.   /* printer resolution              */
  DEFINE VARIABLE PrintVertRes  as integer no-undo.
  DEFINE VARIABLE WinHorzRes    as integer no-undo.   /* display resolution              */
  DEFINE VARIABLE WinVertRes    as integer no-undo.
  DEFINE VARIABLE hdcComp       as integer no-undo.   /* hdc memory                      */
  DEFINE VARIABLE hbmpComp      as integer no-undo.   /* bitmap in memory                */
  DEFINE VARIABLE hbmpDest      as integer no-undo.   /* bitmap on paper                 */
  DEFINE VARIABLE WinWidth      as INTEGER NO-UNDO.   /* dimensions of window            */
  DEFINE VARIABLE WinHeight     as INTEGER NO-UNDO.
  DEFINE VARIABLE PictureWidth  as integer no-undo.   /* dimensions of picture on paper  */
  DEFINE VARIABLE PictureHeight as integer no-undo.
  DEFINE VARIABLE Scale         as decimal no-undo.
  DEFINE VARIABLE xMargin       as INTEGER NO-UNDO.   /* center picture horizontally     */
  DEFINE VARIABLE numrows       as integer no-undo.   /* split large pics into rows/cols */
  DEFINE VARIABLE numcols       as integer no-undo.
  DEFINE VARIABLE rw            as integer no-undo.
  DEFINE VARIABLE cl            as integer no-undo.
  DEFINE VARIABLE lpRect        as MEMPTR  NO-UNDO.
  DEFINE VARIABLE ReturnValue   as integer no-undo.
  DEFINE VARIABLE lpOrigin      as MEMPTR  NO-UNDO.

  IF getParent THEN
     RUN GetParent(hWin, OUTPUT hWin).

  /* get the window resolution */
  run GetDC (hWin, output hdcWin).
  run GetDeviceCaps(hdcWin,  8 /* = HorzRes */, output WinHorzRes).
  run GetDeviceCaps(hdcWin, 10 /* = VertRes */, output WinVertRes).
  
  /* get the printer resolution */
  run GetDeviceCaps(hdcDest,  8 /* = HorzRes */, output PrintHorzRes).
  run GetDeviceCaps(hdcDest, 10 /* = VertRes */, output PrintVertRes).

  /* determine dimensions of the window */
  /* Also determine the coordinates of the upper-left corner. 
     This is (0,0) for a client window, but will be somewhere around (-4,-20) for
     a window with titlebar  */
  SET-SIZE (lpOrigin)   =  8.
  SET-SIZE (lpRect)     = 16.
  RUN GetWindowRect     (hWin, GET-POINTER-VALUE(lpRect) , OUTPUT ReturnValue).
  WinWidth              = GET-LONG(lpRect, 9) - GET-LONG(lpRect, 1).
  WinHeight             = GET-LONG(lpRect,13) - GET-LONG(lpRect, 5).
  PUT-LONG(lpOrigin, 1) = GET-LONG(lpRect, 1).
  PUT-LONG(lpOrigin, 5) = GET-LONG(lpRect, 5).
  RUN ScreenToClient    (hWin, GET-POINTER-VALUE(lpOrigin), OUTPUT ReturnValue).
  SET-SIZE (lpRect)     = 0.
  Scale         = MINIMUM(PrintHorzRes / WinWidth,
                          PrintVertRes / WinHeight).
  IF Scale < 1 THEN Scale = 1.
  
  run CreateCompatibleDC     (hdcWin, output hdcComp).
  run CreateCompatibleBitmap (hdcComp, 
                              integer(winWidth  * Scale),
                              integer(winHeight * Scale), 
                              output hbmpComp).
  run CreateCompatibleBitmap (hdcDest, 
                              integer(winWidth  * Scale),
                              integer(winHeight * Scale), 
                              output hbmpDest).
  run SelectObject (hdcComp, hbmpComp, output ReturnValue).
  run SelectObject (hdcDest, hbmpDest, output ReturnValue).
  run StretchBlt (hdcDest,
                  0,
                  0,
                  integer(winwidth  * Scale) ,
                  integer(winHeight * Scale) ,
                  hdcWin,
                  get-long(lpOrigin,1),
                  get-long(lpOrigin,5),
                  winwidth,
                  winheight,
                  13369376,  /* = SRCCOPY */
                  output ReturnValue).

  /* cleanup */
  run ReleaseDC    (hWin, hdcWin, output ReturnValue).
  run DeleteDC     (hdcComp, output ReturnValue).
  run DeleteObject (hbmpComp, output ReturnValue).
  run DeleteObject (hbmpDest, output ReturnValue).
  SET-SIZE(lpOrigin)=0.
  
END PROCEDURE. /* PrintWindow */

/* ==============================================================
   file    : printscreen.i
   by      : Jurjen Dijkstra (Modified by Ian Keene Oct 2003)
   dd      : 05/16/1999
   purpose : API definitions used in printscreen.p
   ============================================================== */
&GLOB GDI "gdi32.dll"
&GLOB USER "user32.dll"
&GLOB BOOL LONG
&GLOB COLORREF LONG
&GLOB DWORD LONG
&GLOB HANDLE LONG
&GLOB HDC LONG
&GLOB HGDIOBJ LONG
&GLOB HWND LONG
&GLOB INTEGER LONG
&GLOB LONG LONG
&GLOB LP LONG
&GLOB LPCSTR CHARACTER
&GLOB LPCTSTR CHARACTER
&GLOB LPSECURITY_ATTRIBUTES LONG
&GLOB LPSTRUCT LONG
&GLOB LPTSTR CHARACTER
&GLOB SHORT SHORT
&GLOB UINT LONG
&GLOB WORD SHORT

PROCEDURE CreateDCA EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER lpszDriver   AS {&LPCTSTR} NO-UNDO.
  DEFINE INPUT  PARAMETER lpszDevice   AS {&LPCTSTR} NO-UNDO.
  DEFINE INPUT  PARAMETER lpszOutput   AS {&LP} NO-UNDO.
  DEFINE INPUT  PARAMETER lpInitData   AS {&LPSTRUCT} NO-UNDO.
  DEFINE RETURN PARAMETER hDC          AS {&HDC} NO-UNDO.
END PROCEDURE.

PROCEDURE StartDocA EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc   AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER lpdi  AS {&LPSTRUCT} NO-UNDO.
  DEFINE RETURN PARAMETER JobId AS {&int} NO-UNDO.
END PROCEDURE.

PROCEDURE StartPage EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc         AS {&HDC} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&int} NO-UNDO.
END PROCEDURE.

PROCEDURE EndPage EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc         AS {&HDC} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&int} NO-UNDO.
END PROCEDURE.

PROCEDURE EndDoc EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc         AS {&HDC} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&int} NO-UNDO.
END PROCEDURE.

PROCEDURE GetParent EXTERNAL {&USER} :
  DEFINE INPUT  PARAMETER hWinHdl    AS {&HWND} NO-UNDO.
  DEFINE RETURN PARAMETER hwndParent AS {&HWND} NO-UNDO.
END PROCEDURE.

PROCEDURE GetDC EXTERNAL {&USER} :
  DEFINE INPUT  PARAMETER hWinHdl AS {&HWND} NO-UNDO.
  DEFINE RETURN PARAMETER hdc     AS {&HDC} NO-UNDO.
END PROCEDURE.

PROCEDURE GetDeviceCaps EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc    AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER nIndex AS {&int} NO-UNDO.
  DEFINE RETURN PARAMETER dwCaps AS {&int} NO-UNDO.
END PROCEDURE.

PROCEDURE GetWindowRect EXTERNAL {&USER} :
  DEFINE INPUT  PARAMETER hWinHdl     AS {&HWND} NO-UNDO.
  DEFINE INPUT  PARAMETER lpRect      AS {&LPSTRUCT} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&BOOL} NO-UNDO.
END PROCEDURE.

PROCEDURE ScreenToClient EXTERNAL {&USER} :
  DEFINE INPUT  PARAMETER hWinHdl     AS {&HWND} NO-UNDO.
  DEFINE INPUT  PARAMETER lpPoint     AS {&LPSTRUCT} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&BOOL} NO-UNDO.
END PROCEDURE.

PROCEDURE CreateCompatibleDC EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc      AS {&HDC} NO-UNDO.
  DEFINE RETURN PARAMETER hdcComp  AS {&HDC} NO-UNDO.
END PROCEDURE.

PROCEDURE CreateCompatibleBitmap EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc     AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER nWidth  AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nHeight AS {&int} NO-UNDO.
  DEFINE RETURN PARAMETER hbmp    AS {&HANDLE} NO-UNDO.
END PROCEDURE.

PROCEDURE SelectObject EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc         AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER hgdiobj     AS {&HGDIOBJ} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&HGDIOBJ} NO-UNDO.
END PROCEDURE.

PROCEDURE StretchBlt EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdcDest      AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER nXOriginDest AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nYOriginDest AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nWidthDest   AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nHeightDest  AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER hdcSrc       AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER nXOriginSrc  AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nYOriginSrc  AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nWidthSrc    AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nHeightSrc   AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER dwRop        AS {&DWORD} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue  AS {&BOOL} NO-UNDO.
END PROCEDURE.

PROCEDURE BitBlt EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdcDest      AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER nXOriginDest AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nYOriginDest AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nWidthDest   AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nHeightDest  AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER hdcSrc       AS {&HDC} NO-UNDO.
  DEFINE INPUT  PARAMETER nXOriginSrc  AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER nYOriginSrc  AS {&int} NO-UNDO.
  DEFINE INPUT  PARAMETER dwRop        AS {&DWORD} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue  AS {&BOOL} NO-UNDO.
END PROCEDURE.

PROCEDURE ReleaseDC EXTERNAL {&USER} :
  DEFINE INPUT  PARAMETER hWinHdl     AS {&HWND} NO-UNDO.
  DEFINE INPUT  PARAMETER hdc         AS {&HDC} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&BOOL} NO-UNDO.
END PROCEDURE.

PROCEDURE DeleteDC EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hdc         AS {&HDC} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&BOOL} NO-UNDO.
END PROCEDURE.

PROCEDURE DeleteObject EXTERNAL {&GDI} :
  DEFINE INPUT  PARAMETER hObject     AS {&HGDIOBJ} NO-UNDO.
  DEFINE RETURN PARAMETER ReturnValue AS {&BOOL} NO-UNDO.
END PROCEDURE.

PROCEDURE GetProfileStringA EXTERNAL "kernel32.dll":
   DEFINE INPUT PARAMETER in-appname AS CHARACTER NO-UNDO.
   DEFINE INPUT PARAMETER in-keyname AS CHARACTER NO-UNDO.
   DEFINE INPUT PARAMETER in-default AS CHARACTER NO-UNDO.
   DEFINE OUTPUT PARAMETER in-ret-str AS CHARACTER NO-UNDO.
   DEFINE INPUT PARAMETER in-n-size AS LONG NO-UNDO.
   DEFINE RETURN PARAMETER out-nuchr AS LONG NO-UNDO. 
END PROCEDURE.

PROCEDURE OpenPrinterA EXTERNAL "winspool.drv":
   DEFINE INPUT PARAMETER in-prtname AS CHARACTER NO-UNDO.
   DEFINE OUTPUT PARAMETER out-hwnd AS LONG NO-UNDO.
   DEFINE INPUT PARAMETER in-def AS LONG NO-UNDO.
END PROCEDURE.

Set default printer

Method 1

Based on an idea by Richard Gordon.

The question was: how to get a list of available printers and set a new default printer. Here is a solution that uses the win.ini file.
It is recommended for a 32-bit application to use the EnumPrinters procedure to get a list of available printers.
One might think it's not modern to change the default printer by writing in win.ini but this is still the recommended way according to MS documentation.

{windows.i}
 
DEFINE VARIABLE list-of-printers AS CHARACTER.
DEFINE VARIABLE newdefault AS CHARACTER.
DEFINE VARIABLE driver-and-port AS CHARACTER.
 
RUN getkey
  (INPUT  "devices",    /* The section name */
   INPUT  "",           /* The key name  */
   INPUT  "win.ini",    /* Name of ini file */
   OUTPUT list-of-printers).     /* Returned stuff */
 
/* you now have a comma separated list of printer names. Check it: */
/* message list-of-printers view-as alert-box. */
/* allow the user to pick one, suppose he picks the third entry: */
 
newdefault = ENTRY(3, list-of-printers).
 
/* read driver and port for the new default printer */
RUN getkey
  (INPUT  "devices",        /* The section name */
   INPUT  newdefault,       /* The key name  */
   INPUT  "win.ini",        /* Name of ini file */
   OUTPUT driver-and-port). /* Returned stuff */
 
/* and write it back */
RUN putkey 
  (INPUT "windows",
   INPUT "device",
   INPUT "win.ini",
   INPUT newdefault + "," + driver-and-port).
 
/* check it: 
message session:printer-name view-as alert-box.
*/
 
RETURN.
 
/* ------------- internal procedures ------------ */
 
PROCEDURE getkey :
 
DEFINE INPUT PARAMETER i-section AS CHARACTER.
DEFINE INPUT PARAMETER i-key AS CHARACTER.
DEFINE INPUT PARAMETER i-filename AS CHARACTER.
DEFINE OUTPUT PARAMETER o-value AS CHARACTER.
 
DEFINE VARIABLE EntryPointer AS INTEGER NO-UNDO.
DEFINE VARIABLE mem1 AS MEMPTR NO-UNDO.
DEFINE VARIABLE mem2 AS MEMPTR NO-UNDO.
DEFINE VARIABLE mem1size AS INTEGER NO-UNDO.
DEFINE VARIABLE mem2size AS INTEGER NO-UNDO.
DEFINE VARIABLE i       AS INTEGER    NO-UNDO.
DEFINE VARIABLE cbReturnSize  AS INTEGER    NO-UNDO.
 
ASSIGN
  SET-SIZE(mem1)  = 4000
  mem1size = 4000.
 
IF i-key = "" THEN EntryPointer = 0.
 
ELSE DO:
  /* Must fill memory with desired key name and EntryPointer must point to it */
 
  ASSIGN
  SET-SIZE(mem2) = 128
  mem2size = 128
  EntryPointer = GET-POINTER-VALUE(mem2)
  PUT-STRING(mem2,1) = i-key.
END.
 
RUN getprivateprofilestring{&A} IN hpApi
                              (i-section, 
                               EntryPointer, 
                               "",
                               GET-POINTER-VALUE(mem1),
                               INPUT mem1size, 
                               i-filename,
                               OUTPUT cbReturnSize).
 
/* if i-key was "", Windows will return a list of all keys in i-section.
   This list is not comma-separated but separated by CHR(0). Progress
   can not handle that easily so we'll now replace every 0 by a comma: */ 
 
DO i = 1 TO cbReturnSize:
  /* If this is a list convert null character into a comma to generate a csv
     type variable */
  o-value = IF (GET-BYTE(mem1, i) = 0 AND i NE cbReturnSize) 
               THEN o-value + ","
               ELSE o-value + CHR(GET-BYTE(mem1, i)).
END.
 
  SET-SIZE(mem1) = 0.
  SET-SIZE(mem2) = 0.
 
END PROCEDURE.
 
 
PROCEDURE putkey :
DEFINE INPUT PARAMETER i-section AS CHARACTER.
DEFINE INPUT PARAMETER i-key AS CHARACTER.
DEFINE INPUT PARAMETER i-filename AS CHARACTER.
DEFINE INPUT PARAMETER i-value AS CHARACTER.
 
DEFINE VARIABLE cbReturnSize AS INTEGER.
 
RUN writeprivateprofilestring{&A} IN hpApi
                               (i-section, 
                                i-key, 
                                i-value,
                                i-filename, 
                                OUTPUT cbReturnSize ).
 
END PROCEDURE.

Method 2

By Nenad Orlovic

Nenad Orlovic writes: "Here is another example for same purpose that uses SetPrinter API function. I don't know which way is better. Both have the same problem, they can't change SESSION:PRINTER-NAME when it was already changed by SYSTEM-DIALOG PRINTER-SETUP command."
usage:

   run SetDefaultPrinter("HP LaserJet 4L").

Additional note from Jurjen: Microsoft knowledgebase article Q140560 says this SetPrinter() call does not work on Windows NT4. Probably because NT4 does not support the PRINTER_INFO_5 structure. The good news is: Windows 2000 finally has the new API function we have all been waiting for: "SetDefaultPrinterA". The usage of this new API function is exactly similiar to the SetDefaultPrinter procedure by Nenad.
I did not try but it may be a good idea to call SendNotifyMessage(HWND_BROADCAST,WM_SETTINGCHANGE,0,"windows") to solve the SESSION:PRINTER-NAME problem.

/* Nenad Orlovic */
/* Change default printer example */
 
FUNCTION CheckBit RETURNS LOGICAL
  ( INPUT ip_dword AS INT,
    INPUT ip_bit AS INTEGER ) :
/*------------------------------------------------------------------------------
  Purpose:  Checks if ip_bit in ip_dword is set
    Notes:  ip_bit = 0,1,...,31
------------------------------------------------------------------------------*/
DEFINE VARIABLE iBit AS INTEGER EXTENT 32 INIT 
    [
     1       ,2       ,4       ,8        ,16       ,32       ,64        ,128,
     256     ,512     ,1024    ,2048     ,4096     ,8192     ,16384     ,32768,
     65536   ,131072  ,262144  ,524288   ,1048576  ,2097152  ,4194304   ,8388608,
     16777216,33554432,67108864,134217728,268435456,536870912,1073741824,-2147483648
    ] NO-UNDO.
 
    IF ip_bit > 31 OR ip_bit < 0 then return ?.
 
    ip_dword = TRUNC(ip_dword / iBit[ip_bit + 1],0).
    RETURN (ip_dword MOD 2 = 1).
 
END FUNCTION.
 
PROCEDURE SetDefaultPrinter:
/*------------------------------------------------------------------------------
  Purpose:     Sets ip_printer to be windows default printer 
  Parameters:  input - Printer name
  Notes:       
------------------------------------------------------------------------------*/
DEFINE INPUT PARAMETER ip_printer AS CHARACTER NO-UNDO.
 
DEFINE VARIABLE iRet AS INTEGER NO-UNDO.
DEFINE VARIABLE pPrinter AS MEMPTR NO-UNDO.
DEFINE VARIABLE hPrinter AS INTEGER NO-UNDO.
DEFINE VARIABLE iSize AS INTEGER NO-UNDO.
DEFINE VARIABLE iAttr AS INTEGER NO-UNDO.
 
DEFINE VARIABLE cMessage AS CHARACTER NO-UNDO.
 
  RUN OpenPrinterA (ip_printer,OUTPUT hPrinter,0, OUTPUT iRet).
  IF iRet = 0 THEN cMessage = "ERROR: OpenPrinterA " + ip_printer.
  ELSE DO:
    SET-SIZE(pPrinter) = 1. 
    /* First call is only to get needed size for pPrinter */
    RUN GetPrinterA(hPrinter,5,pPrinter,1,OUTPUT iSize,OUTPUT iRet). 
    SET-SIZE(pPrinter) = 0.
    SET-SIZE(pPrinter) = iSize. 
    RUN GetPrinterA(hPrinter,5,pPrinter,iSize,OUTPUT iSize,OUTPUT iRet).
    /* pPrinter points to PRINTER_INFO_5 */
 
    IF iRet = 0 THEN cMessage = "ERROR: GetPrinterA " + ip_printer.
    ELSE DO:
        iAttr = GET-LONG(pPrinter,9).
 
        IF NOT CheckBit(iAttr,2) THEN DO:
            PUT-LONG(pPrinter,9) = iAttr + 4. /* 4 = PRINTER_ATTRIBUTE_DEFAULT */
            RUN SetPrinterA(hPrinter,5,pPrinter,0,OUTPUT iRet).
            IF iRet = 0 THEN cMessage = "ERROR: SetPrinterA " + ip_printer.
        END.
 
        RUN ClosePrinter(hPrinter,OUTPUT iRet).
        IF iRet = 0 THEN cMessage = cMessage + "ERROR: ClosePrinter " + ip_printer.
    END.        
  END.
  SET-SIZE(pPrinter) = 0.
  RETURN cMessage.
END PROCEDURE.
 
PROCEDURE OpenPrinterA EXTERNAL "WINSPOOL.DLL":
   DEFINE INPUT PARAMETER pPrinterName AS CHARACTER.
   DEFINE OUTPUT PARAMETER phPrinter AS LONG.
   DEFINE INPUT PARAMETER pDefault AS LONG.
   DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE ClosePrinter EXTERNAL "WINSPOOL.DLL":
   DEFINE INPUT PARAMETER hPrinter AS LONG.
   DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE SetPrinterA EXTERNAL "WINSPOOL.DLL":
    DEFINE INPUT PARAMETER hPrinter AS LONG.
    DEFINE INPUT PARAMETER Level AS LONG.
    DEFINE INPUT PARAMETER pPrinter AS MEMPTR.
    DEFINE INPUT PARAMETER COMMAND AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.
 
PROCEDURE GetPrinterA EXTERNAL "WINSPOOL.DLL":
    DEFINE INPUT PARAMETER hPrinter AS LONG.
    DEFINE INPUT PARAMETER Level AS LONG.
    DEFINE INPUT PARAMETER pPrinter AS MEMPTR.
    DEFINE INPUT PARAMETER cbBuf AS LONG.
    DEFINE OUTPUT PARAMETER pcbNeeded AS LONG.
    DEFINE RETURN PARAMETER X AS LONG.
END PROCEDURE.

The printer properties dialog

by Johan Bouduin

The next procedure calls the properties dialog for any available printer.
The properties dialog is more or less part of the printer driver, so the appearance will be different for each printer.

the source

It's only tested on Win95.

/********************************************************************
  name        : prg/de/de_prop.p
  author      : Johan Bouduin
  date        : 13/02/1998
  purpose     : get printers
  syntax      : run prg/de/de_prop.p
  parameters  : input PC_PRINTER_NAME as character
                input PH_CALLER as handle
  internal procedures : 
                PROC_FREEMEM : de-allocate reserved memory
  internal functions :
  external functions :
                OpenPrinter "winspool.drv"
                ClosePrinter "winspool.drv"
                PrinterProperties "winspool.drv"
  modifications :
                Jurjen moved external procedures to windows.i/p
*********************************************************************/
 
/***** Parameter definitions ****************************************/
  DEFINE INPUT PARAMETER PC_PRINTER_NAME AS CHARACTER NO-UNDO.
  DEFINE INPUT PARAMETER PH_CALLER       AS HANDLE NO-UNDO.
 
/***** Variable definitions *****************************************/
  DEFINE VARIABLE VM_PRINTER_HANDLE AS MEMPTR NO-UNDO.
  DEFINE VARIABLE VI_RETURN_VALUE   AS INTEGER NO-UNDO.
  DEFINE VARIABLE VM_PRINTER_NAME   AS MEMPTR NO-UNDO.
  DEFINE VARIABLE VM_DEFAULTS       AS MEMPTR NO-UNDO.
 
/***** External procedures ******************************************/
 
{windows.i}
 
/***** Main-block ***************************************************/
DO:
 
  /***** get a printer handle ***************************************/
  SET-SIZE(VM_PRINTER_HANDLE) = 4. 
  RUN OpenPrinter{&A} IN hpApi(
    INPUT PC_PRINTER_NAME,
    INPUT GET-POINTER-VALUE(VM_PRINTER_HANDLE),
    INPUT GET-POINTER-VALUE(VM_DEFAULTS),
    OUTPUT VI_RETURN_VALUE).
 
  IF  VI_RETURN_VALUE EQ 0
  THEN DO:
    MESSAGE "An error occurred while trying to open the printer"
      VIEW-AS ALERT-BOX.
    RETURN "not open".
  END.
 
  /***** call printerproperties *************************************/
  RUN PrinterProperties IN hpApi(
    INPUT PH_CALLER:HWND,
    INPUT GET-LONG(VM_PRINTER_HANDLE,1),
    OUTPUT VI_RETURN_VALUE).
 
  /***** close the printer ******************************************/
  RUN ClosePrinter IN hpApi(
    INPUT GET-LONG(VM_PRINTER_HANDLE,1),
    OUTPUT VI_RETURN_VALUE).    
  IF  VI_RETURN_VALUE EQ 0
  THEN DO:
    MESSAGE "An error occurred while trying to close the printer"
      VIEW-AS ALERT-BOX.
    RETURN "not closed".
  END.
  RUN PROC_FREEMEM.
  RETURN.
END.
 
/***** internal procedures ******************************************/
 
PROCEDURE PROC_FREEMEM:   
  SET-SIZE(VM_PRINTER_HANDLE) = 0. 
END.
 

Usage

Suppose you have used the EnumPrinters function to populate a selection list widget (SELECT-1) with names of all available printers:

On choose of the button do:

  run prg/de/de_prop.p (select-1:screen-value,  c-win:handle).

The first parameter is the name of the printer, the second parameter is the Progress widget handle of the current window. This window will be the parent window for the property dialog; you will not be able to activate c-win while the property dialog is opened.

change title and icon in Windows Task Manager

by Jurjen Dijkstra and Edwin van Elk

When you look at the "Applications" tab in Windows Task Manager, you see that every Progress session has the same title and icon. When you run multiple Progress sessions you may wish to change the icon and/or title of each individual entry in this list.
The Progress session creates one hidden window, which is the owner of all other Progress window. This ultimate owner is the window whos icon and title are displayed in the Task Manager. There is no Progress widget for this window, so you need API functions in order to manipulate it.

&Scoped-Define WM_GETICON 127
&Scoped-Define WM_SETICON 128
/* WM_SETICON / WM_GETICON Type Codes */
&Scoped-Define ICON_SMALL 0
&Scoped-Define ICON_BIG 1
/* some GetWindow() Constants */
&Scoped-Define GW_OWNER 4
DEFINE VARIABLE hParent   AS INTEGER NO-UNDO.
DEFINE VARIABLE hOwner    AS INTEGER NO-UNDO.
DEFINE VARIABLE i_ApiStat AS INTEGER NO-UNDO.
DEFINE VARIABLE hIcon     AS INTEGER NO-UNDO.
/* find the hidden owner window */
RUN GetParent (DEFAULT-WINDOW:HWND, OUTPUT hParent).
RUN GetWindow (hParent, {&GW_OWNER}, OUTPUT hOwner).
/* change the title: */
RUN SetWindowTextA (hOwner, "This is the new application title").
/* change the icon: */
RUN ExtractIconA (0, SEARCH("ICON.ICO":U), 0, OUTPUT hIcon).   
IF hIcon > 0 THEN DO:
   RUN SendMessageA( hOwner, {&WM_SETICON}, {&ICON_BIG},   hIcon, OUTPUT i_ApiStat ).
   RUN SendMessageA( hOwner, {&WM_SETICON}, {&ICON_SMALL}, hIcon, OUTPUT i_ApiStat ).
END.      
/* ----------- API definitions: ----------------------- */
PROCEDURE SetWindowTextA EXTERNAL "user32.dll" :
  DEFINE INPUT PARAMETER HWND AS LONG.
  DEFINE INPUT PARAMETER txt  AS CHARACTER.
END PROCEDURE.
PROCEDURE SendMessageA EXTERNAL "USER32.DLL":
  DEFINE INPUT  PARAMETER h_Widget    AS LONG.
  DEFINE INPUT  PARAMETER i_Message   AS LONG.
  DEFINE INPUT  PARAMETER i_wParam    AS LONG.
  DEFINE INPUT  PARAMETER i_lParam    AS LONG.
  DEFINE RETURN PARAMETER i_ApiStatus AS LONG.
END PROCEDURE.
PROCEDURE GetWindow EXTERNAL "user32.dll" :
  DEFINE INPUT PARAMETER  HWND      AS LONG.
  DEFINE INPUT PARAMETER  uCmd      AS LONG.
  DEFINE RETURN PARAMETER hwndOther AS LONG.
END PROCEDURE.
PROCEDURE GetParent EXTERNAL "user32.dll" :
  DEFINE INPUT PARAMETER  hwndChild  AS LONG.
  DEFINE RETURN PARAMETER hwndParent AS LONG.
END PROCEDURE.
PROCEDURE ExtractIconA EXTERNAL "shell32.dll":
  DEFINE INPUT  PARAMETER hInst           AS LONG.
  DEFINE INPUT  PARAMETER lpszExeFileName AS CHARACTER.
  DEFINE INPUT  PARAMETER nIconIndex      AS LONG.
  DEFINE RETURN PARAMETER i_Return        AS LONG.
END PROCEDURE.

Notes

If you only want to set the BIG icon you don't need API functions:

   SESSION:LOAD-ICON ("example.ico").

However, the BIG icon does not affect the Task Manager listview. It only affects the Alt-Tab window.

Disallowing multiple instances of your application

_Based on an example from Microsofts whitepaper 'Optimizing Applications for Windows NT Server Terminal Server Edition, version 4.0'_
Suppose you want to prevent your Progress application to be launched more than once on each computer. The startup procedure would contain something like this:

IF IsAppAlreadyRunning(NO, "MyProgressApplication") THEN DO:
   MESSAGE "'MyProgressApplication' is already running on this machine,"
           SKIP
           "only one instance is allowed."
           VIEW-AS ALERT-BOX.
   QUIT.
END.
 
...
 
RUN LetAnotherInstanceRun("MyProgressApplication").

There are several ways to implement this functionality. This topic will use a mutex.
A mutex is an object that can only be owned by one thread at a time. The general purpose of a mutex is to synchronize threads, ie to have other threads wait until the mutex is released. So if your application creates and owns a named mutex, other applications can not get ownership of the same mutex. Function IsAppAlreadyRunning creates a named mutex, procedure LetAnotherInstanceRun closes the mutex.

{windows.i}
DEFINE VARIABLE hAppRunningMutex AS INTEGER NO-UNDO INITIAL 0.
 
FUNCTION IsAppAlreadyRunning RETURN LOGICAL
   (p-OnePerSystem AS LOGICAL, p-AppName AS CHARACTER):
 
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
  DEFINE VARIABLE MutexName   AS CHARACTER    NO-UNDO.
  MutexName = ''.
 
  IF p-OnePerSystem AND ValidateProductSuite("Terminal Server") THEN 
     MutexName = MutexName + "Global\".
 
  MutexName = MutexName + p-AppName + ' is running'.
  RUN CreateMutexA IN hpApi(0,0,MutexName, OUTPUT hAppRunningMutex).
  IF hAppRunningMutex NE 0 THEN DO:
 
     /* we should check GetLastError = ERROR_ALREADY_EXISTS, 
        but unfortunately GetLastError doesn't work with Progress until 9.0B */
     /* Instead we will try to get ownership of the Mutex.
        This will be easy if we created the mutex, but will be impossible if 
        another instance created the mutex (and still holds ownership) */
     RUN WaitForSingleObject IN hpApi (hAppRunningMutex,100, OUTPUT ReturnValue).
     IF NOT (ReturnValue={&WAIT_ABANDONED} OR 
             ReturnValue={&WAIT_OBJECT_0}) THEN DO:
        RUN CloseHandle IN hpApi(hAppRunningMutex, OUTPUT ReturnValue).
        hAppRunningMutex = 0.
     END.
  END.
  RETURN (hAppRunningMutex=0).  
END.

The first parameter, p-OnePerSystem specifies if the application is allowed to run more than once per system. This is useful when the application is installed on Microsoft Windows Terminal Server hosting multiple users. If p-OnePerSystem=No, the application can be launched once by each user. If p-OnePerSystem=Yes the application can run only once on the entire Terminal Server system, in other words: by only one user at a time. This might be useful for batch processes perhaps?
Procedure LetAntotherInstanceRun closes the mutex, making it available to other threads. This decreases the usage-count of the mutex. If the usage-count decreases to zero (like now) the mutex will be deleted. It is not very important to run this procedure because the mutex will be closed automatically by Windows when the Progress session quits.

PROCEDURE LetAnotherInstanceRun :
  DEFINE INPUT PARAMETER p-AppName AS CHARACTER NO-UNDO.
  DEFINE  VARIABLE ReturnValue AS INTEGER NO-UNDO.
  IF hAppRunningMutex NE 0 THEN DO:
        RUN CloseHandle IN hpApi(hAppRunningMutex, OUTPUT ReturnValue).
        hAppRunningMutex = 0.
  END.
END PROCEDURE.

Function ValidateProductSuite checks if the application is installed on and running on a Windows Terminal Server machine :

{windows.i}
FUNCTION ValidateProductSuite RETURN LOGICAL (SuitName AS CHARACTER):
 
   DEFINE VARIABLE key-hdl        AS INTEGER NO-UNDO.
   DEFINE VARIABLE lpBuffer       AS MEMPTR  NO-UNDO.
   DEFINE VARIABLE lth            AS INTEGER NO-UNDO.
   DEFINE VARIABLE datatype       AS INTEGER NO-UNDO.
   DEFINE VARIABLE ReturnValue    AS INTEGER NO-UNDO.
   DEFINE VARIABLE retval         AS LOGICAL NO-UNDO INITIAL FALSE.
 
   RUN RegOpenKeyA IN hpApi 
                  ( {&HKEY_LOCAL_MACHINE},
                    "System\CurrentControlSet\Control\ProductOptions",
                    OUTPUT key-hdl,
                    OUTPUT ReturnValue).
 
   IF ReturnValue NE {&ERROR_SUCCESS} THEN
      RETURN FALSE.
 
   /* make buffer large enough
     The maximum size is supposed to be MAX_PATH + 1 */
 
   ASSIGN lth                = {&MAX_PATH} + 1
          SET-SIZE(lpBuffer) = lth.
 
   RUN RegQueryValueExA IN hpApi 
                       ( key-hdl,
                         "ProductSuite",
                         0, /* reserved, must be 0 */
                         OUTPUT datatype,
                         GET-POINTER-VALUE(lpBuffer),
                         INPUT-OUTPUT lth,
                         OUTPUT ReturnValue).
 
   IF ReturnValue = {&ERROR_SUCCESS} THEN
       retval =  (GET-STRING(lpBuffer,1)=SuitName).
   SET-SIZE(lpBuffer)=0.
   IF key-hdl NE 0 THEN 
      RUN RegCloseKey IN hpApi (key-hdl,OUTPUT ReturnValue).
   RETURN retval.
 
END FUNCTION.

get a list of processes

This procedure can be used to show a list of all running processes, for example to see if Netscape.exe is running. The process indentifier (pid) can be used for getting additional information about the process, or for terminating the process.
This method uses the psapi.dll which only works on NT (and Windows 2000 etc). On Windows 95 or Windows 98 you can not use psapi.dll, instead you can use the much nicer CreateToolhelp32 functions.
To check if you are running Windows NT4.0 see page: which version of Windows is running.

FUNCTION GetProcessName RETURNS CHARACTER (INPUT PID AS INTEGER) :
 
  DEFINE VARIABLE hProcess      AS INTEGER NO-UNDO.
  DEFINE VARIABLE cbNeeded      AS INTEGER NO-UNDO.
  DEFINE VARIABLE lphMod        AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE szProcessName AS CHARACTER    NO-UNDO.
  DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
  /* OpenProcess returns a handle (hProcess),
     needed for querying info about the process */
  RUN OpenProcess ( {&PROCESS_QUERY_INFORMATION} + {&PROCESS_VM_READ},
                    0,
                    PID,
                    OUTPUT hProcess).
 
  /* some system processes can not be queried, 
     like "System" and "System Idle Process" and "csrss.exe".
     ProcessName will be initialized to [unknown] for these processes: */
  szProcessName = "[unknown]" + FILL(" ", {&MAX_PATH}).
  IF hProcess NE 0 THEN DO:
 
     /* EnumProcessModules fills an array of module handles */
     /* The first module handle is a handle to the main module, and that's the 
        only handle you need  */
     SET-SIZE (lphMod) = 4. /* need only one hMod  */
     RUN EnumProcessModules ( hProcess,
                              GET-POINTER-VALUE(lphMod),
                              GET-SIZE(lphMod),
                              OUTPUT cbNeeded,
                              OUTPUT ReturnValue).
     IF ReturnValue NE 0 THEN DO:
        /* GetModuleBaseNameA returns the name of a module.
           Because this module is the main module, it's also considered to 
           be the name of the process */
        RUN GetModuleBaseNameA (hProcess,
                                GET-LONG(lphMod,1),
                                OUTPUT szProcessName,
                                LENGTH(szProcessName),
                                OUTPUT ReturnValue).
        /* ReturnValue is the number of returned bytes (chars): */
        szProcessName = SUBSTRING(szProcessName,1,ReturnValue).
        SET-SIZE (lphMod) = 0.
     END.
     RUN CloseHandle ( hProcess, OUTPUT ReturnValue).
  END.
  RETURN TRIM(szProcessName).
 
END FUNCTION.
 
/* =============== TEST ================ */
 
DEFINE VARIABLE lpId          AS MEMPTR  NO-UNDO.
DEFINE VARIABLE PID           AS INTEGER NO-UNDO.
DEFINE VARIABLE cbNeeded      AS INTEGER NO-UNDO.
DEFINE VARIABLE i             AS INTEGER NO-UNDO.
DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
 
/* lpID is an array of PID's (Process Identifiers) */
SET-SIZE(lpId) = 1000. /* assume room for 250 pid's */
 
/* EnumProcesses fills an array of PID's */
RUN EnumProcesses (INPUT GET-POINTER-VALUE(lpId),
                   INPUT GET-SIZE(lpID),
                   OUTPUT cbNeeded,
                   OUTPUT ReturnValue).
 
DO i = 1 TO cbNeeded / 4 :
  PID = GET-LONG(lpID, 4 * (i - 1) + 1).
 
  /* display what you have found (for testing purposes) */
  MESSAGE 'PID='  PID 
          SKIP
          'Name=' GetProcessName(PID)
           VIEW-AS ALERT-BOX.
END.
 
SET-SIZE(lpId) = 0.

Definitions used in this procedure:

&GLOB PROCESS_QUERY_INFORMATION 1024
&GLOB PROCESS_VM_READ 16
&GLOB MAX_PATH 260
 
PROCEDURE EnumProcesses EXTERNAL "psapi.dll" :
  DEFINE INPUT  PARAMETER lpIdProcess AS LONG.
  DEFINE INPUT  PARAMETER cb          AS LONG.
  DEFINE OUTPUT PARAMETER cbNeeded    AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.
 
PROCEDURE EnumProcessModules EXTERNAL "psapi.dll" :
  DEFINE INPUT  PARAMETER hProcess    AS LONG.
  DEFINE INPUT  PARAMETER lphModule   AS LONG.  /* lp to array of module handles */
  DEFINE INPUT  PARAMETER cb          AS LONG.
  DEFINE OUTPUT PARAMETER cbNeeded    AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.
 
PROCEDURE GetModuleBaseNameA EXTERNAL "psapi.dll" :
  DEFINE INPUT  PARAMETER hProcess      AS LONG.
  DEFINE INPUT  PARAMETER hModule       AS LONG.
  DEFINE OUTPUT PARAMETER lpBaseName    AS CHARACTER.
  DEFINE INPUT  PARAMETER nSize         AS LONG.
  DEFINE RETURN PARAMETER nReturnedSize AS LONG.
END PROCEDURE.
 
PROCEDURE OpenProcess EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER dwDesiredAccess AS LONG.
  DEFINE INPUT  PARAMETER bInheritHandle  AS LONG.
  DEFINE INPUT  PARAMETER dwProcessId     AS LONG.
  DEFINE RETURN PARAMETER hProcess        AS LONG.
END PROCEDURE.
 
PROCEDURE CloseHandle EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER hObject     AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.

Get a list of processes (Windows 95/98/2000)

based on an example by Michael Rüsweg-Gilbert

This procedure can be used to show a list of all running processes, for example to see if Netscape.exe is running. The process indentifier (pid) can be used for getting additional information about the process, or for terminating the process. See TerminateProcess.

This method only works on Windows 95, Windows 98 and Windows 2000. For Windows NT4.0 you have to use procedure EnumProcesses instead.
To check if you are running Windows NT4.0 see page: which Windows version is running.

RUN ListProcesses.
 
PROCEDURE ListProcesses:
 
    DEFINE VARIABLE hSnapShot   AS INTEGER   NO-UNDO.
    DEFINE VARIABLE lpPE        AS MEMPTR    NO-UNDO. /* PROCESSENTRY32 structure */
    DEFINE VARIABLE ReturnValue AS INTEGER   NO-UNDO.
    DEFINE VARIABLE list        AS CHARACTER NO-UNDO INITIAL "Process-List:".
 
 
    /* Create and open SnapShot-list */
    RUN CreateToolhelp32Snapshot({&TH32CS_SNAPPROCESS}, 
                                 0, 
                                 OUTPUT hSnapShot).
    IF hSnapShot = -1 THEN RETURN.
 
    /* init buffer for lpPE */
    SET-SIZE(lpPE)    = 336.
    PUT-LONG(lpPE, 1) = GET-SIZE(lpPE).
 
    /* Cycle thru process-records */
    RUN Process32First(hSnapShot, 
                       lpPE,
                       OUTPUT ReturnValue).
    DO WHILE ReturnValue NE 0:
       list = list + "~n".
 
       /* show process identifier (pid): */
       list = list + STRING(GET-LONG(lpPE, 9)) + " ".
 
       /* show path and filename of executable: */
       list = list + GET-STRING(lpPE, 37).
 
       RUN Process32Next(hSnapShot, 
                         lpPE,
                         OUTPUT ReturnValue).
    END.
 
    /* Close SnapShot-list */
    RUN CloseHandle(hSnapShot, OUTPUT ReturnValue).
 
    MESSAGE list VIEW-AS ALERT-BOX.
 
END PROCEDURE.

Definitions used in this procedure:

&GLOB TH32CS_SNAPPROCESS 2
 
PROCEDURE CreateToolhelp32Snapshot EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER dwFlags           AS LONG.
  DEFINE INPUT  PARAMETER th32ProcessId     AS LONG.
  DEFINE RETURN PARAMETER hSnapShot         AS LONG.
END PROCEDURE.
 
PROCEDURE Process32First EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER hSnapShot         AS LONG.
  DEFINE INPUT  PARAMETER lpProcessEntry32  AS MEMPTR.
  DEFINE RETURN PARAMETER ReturnValue       AS LONG.
END PROCEDURE.
 
PROCEDURE Process32Next EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER hSnapShot         AS LONG.
  DEFINE INPUT  PARAMETER lpProcessEntry32  AS MEMPTR.
  DEFINE RETURN PARAMETER ReturnValue       AS LONG.
END PROCEDURE.
 
PROCEDURE CloseHandle EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER hObject           AS LONG.
  DEFINE RETURN PARAMETER ReturnValue       AS LONG.
END PROCEDURE.

Get the memory usage of all running processes.

Does anyone know a good way of getting the memory usage of all running processes.

GetProcessTimes

sourcecode by Michael Rüsweg-Gilbert

Function GetProcessTimes works on Windows NT only.
GetProcessTimes obtains timing information about a specified process: the creation time, exit time, kernel time and user time. All these are returned as FILETIME structures (a 64 bit count of 100-nanosecond units).
Creation time and exit time are expressed as time elapsed since midnight January 1, 1601 (UTC). Function FileTimeToSystemTime converts this to system time - which may also be UTC.
Function FileTimeToLocalFileTime can be called prior to FileTimeToSystemTime if you want the output to be displayed in local time.
Kernel time and user time are amounts of time: the FILETIME structures will contain the amount of 100 nanosecond units (ten million units is one second).
This example uses GetProcessTimes for the current (Progress) process. The exit time is null or random because the current process did not exit yet.

/* -----------------------------------------------------------
// File: tst_procTime.p 
// Desc: query the process-times of the current process
// 
// Parm: --- 
// 
// 
// Author: Michael Rüsweg-Gilbert
// Created: 20. Sept. 1999
-------------------------------------------------------------- */
DEFINE VARIABLE RetVal           AS INTEGER    NO-UNDO. 
DEFINE VARIABLE me_Crea          AS MEMPTR NO-UNDO. 
DEFINE VARIABLE me_Exit          AS MEMPTR NO-UNDO. 
DEFINE VARIABLE me_Kern          AS MEMPTR NO-UNDO. 
DEFINE VARIABLE me_User          AS MEMPTR NO-UNDO. 
DEFINE VARIABLE hProc            AS INTEGER    NO-UNDO. 
DEFINE VARIABLE PID              AS INTEGER    NO-UNDO.
 
&GLOB TRUE  1
&GLOB FALSE 0
&GLOB PROCESS_ALL_ACCESS 2035711   /* 0x0F0000 | 0x100000 | 0x000FFF */
 
/* Convert FileTime into a readable LocalTime-String */
FUNCTION proTimeString RETURNS CHAR
( ip_filetime AS MEMPTR):
DEFINE VARIABLE tmp_sysTime AS MEMPTR NO-UNDO.
DEFINE VARIABLE Ret         AS INTEGER    NO-UNDO.
DEFINE VARIABLE cTime       AS CHARACTER   NO-UNDO INIT ?.
 
    SET-SIZE(tmp_sysTime) = 16.
    /* Convert UTC-Time to Local Time */
    RUN FileTimeToSystemTime ( INPUT ip_filetime,
                               OUTPUT tmp_systime,
                               OUTPUT Ret ).
    IF Ret = {&TRUE} THEN DO:
       /* a DAY.MONTH.YEAR HOUR:MINUTE:SECOND-string */
       cTime = STRING(GET-SHORT(tmp_sysTime,  7)) + "." +
               STRING(GET-SHORT(tmp_sysTime,  3)) + "." +
               STRING(GET-SHORT(tmp_sysTime,  1)) + " " +
               STRING(GET-SHORT(tmp_sysTime,  9)) + ":" +
               STRING(GET-SHORT(tmp_sysTime, 11)) + ":" +
               STRING(GET-SHORT(tmp_sysTime, 13)).
    END.
 
    SET-SIZE(tmp_sysTime) = 0.
 
    IF cTime = ?
       THEN RETURN "Error in FileTimeToSystemTime; Ret=" + STRING(Ret).
       ELSE RETURN cTime.
END FUNCTION.
 
 
/* first obtain the current Process Token (add Debug rights) */
RUN GetCurrentProcessId(OUTPUT PID).
 
RUN OpenProcess ( {&Process_All_Access},
                  0,
                  PID,
                  OUTPUT hProc).
IF hProc LT 1 THEN DO:
    MESSAGE "Can't open current PID" PID
            VIEW-AS ALERT-BOX INFO BUTTONS OK.
    RETURN.
END.
 
HProc0:
DO:
 
    SET-SIZE(me_Crea) =  8.
    SET-SIZE(me_Exit) =  8.
    SET-SIZE(me_Kern) =  8.
    SET-SIZE(me_User) =  8.
 
    RUN GetProcessTimes ( hProc,
                          me_Crea,
                          me_Exit,
                          me_Kern,
                          me_User,
                          OUTPUT RetVal).
    IF RetVal NE {&TRUE} THEN DO:
        MESSAGE "GetProcessTimes returned" RetVal
           VIEW-AS ALERT-BOX.
        LEAVE.
    END.
 
    MESSAGE "Creation Time: " ProTimeString(me_Crea) SKIP
            "    Exit Time: " ProTimeString(me_Exit) SKIP
            "  Kernel Time: " ProTimeString(me_Kern) SKIP
            "    User Time: " ProTimeString(me_User)
       VIEW-AS ALERT-BOX.
 
 
END.
 
SET-SIZE(me_Crea) =  0.
SET-SIZE(me_Exit) =  0.
SET-SIZE(me_Kern) =  0.
SET-SIZE(me_User) =  0.
 
RUN CloseHandle ( hProc, OUTPUT RetVal).
 
RETURN.
 
 
PROCEDURE CloseHandle EXTERNAL "kernel32":
  DEFINE INPUT  PARAMETER hObject         AS LONG .
  DEFINE RETURN PARAMETER retval          AS LONG .
END PROCEDURE.
 
PROCEDURE GetCurrentProcessId EXTERNAL "kernel32":
  DEFINE RETURN PARAMETER PID             AS LONG .
END PROCEDURE.
 
PROCEDURE GetLastError EXTERNAL "kernel32":
  DEFINE RETURN PARAMETER dwError         AS LONG .
END PROCEDURE.
 
PROCEDURE OpenProcess EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER dwDesiredAccess AS LONG.
  DEFINE INPUT  PARAMETER bInheritHandle  AS LONG.
  DEFINE INPUT  PARAMETER dwProcessId     AS LONG.
  DEFINE RETURN PARAMETER hProcess        AS LONG.
END PROCEDURE.
 
PROCEDURE GetProcessTimes EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER hProcess        AS LONG.
  DEFINE INPUT  PARAMETER lpCreationTime  AS MEMPTR. /* FILETIME */
  DEFINE INPUT  PARAMETER lpExitTime      AS MEMPTR. /* FILETIME */
  DEFINE INPUT  PARAMETER lpKernelTime    AS MEMPTR. /* FILETIME */
  DEFINE INPUT  PARAMETER lpUserTime      AS MEMPTR. /* FILETIME */
  DEFINE RETURN PARAMETER RetBool         AS LONG.
END PROCEDURE.
 
PROCEDURE FileTimeToSystemTime EXTERNAL "kernel32.dll":
  DEFINE INPUT  PARAMETER lpFileTime      AS MEMPTR. /* L = 8 */
  DEFINE OUTPUT PARAMETER lpSystemTime    AS MEMPTR. /* L = 16 */
  DEFINE RETURN PARAMETER retBool         AS LONG.   /* = 0, if failure */
END PROCEDURE.

Modules in the current process

It is possible to list all modules (exe, dll, ocx, drv) that are in use by a particular process. This example lists all modules loaded by the current process, which is of course the running Progress process.
The resulting list can be useful during development, to check if a certain DLL or OCX really got released, but can also be useful for support engineers to check if a customer site has the appropriate module versions.
Unfortunately the procedure for Windows NT4 is very different compared to 95/98/2000.

   DEFINE TEMP-TABLE module 
      FIELD hModule        AS INTEGER  FORMAT "->>>>>>>>>>>9"
      FIELD cntUsage       AS INTEGER
      FIELD ModuleName     AS CHARACTER     FORMAT "x(20)"
      FIELD ModulePath     AS CHARACTER     FORMAT "x(150)"
      FIELD FileVersion    AS CHARACTER     FORMAT "x(15)"
      FIELD ProductVersion AS CHARACTER     FORMAT "x(15)"
      INDEX key_name       IS PRIMARY ModuleName.
 
   RUN FindModules. 
 
   /* assuming you want to display the contents of the 
      module temp-table in a browse widget: */
   {&OPEN-BROWSERS-IN-QUERY-DEFAULT-FRAME}

PROCEDURE FindModules :
 
    FOR EACH module :
        DELETE module.
    END.
 
    IF RunningWindowsNT4() THEN 
       RUN FindModules_NT4.
    ELSE
       RUN FindModules_notNT4.
 
    FOR EACH module :
        RUN GetProductVersion(module.modulePath,
                              OUTPUT module.ProductVersion,
                              OUTPUT module.FileVersion).
    END.
 
END PROCEDURE.

Windows 9x and Windows 2000 support the fairly new toolhelp procedures for finding process information.

PROCEDURE FindModules_notNT4 :
 
    DEFINE VARIABLE hSnapShot   AS INTEGER   NO-UNDO.
    DEFINE VARIABLE lpME        AS MEMPTR    NO-UNDO. /* MODULEENTRY32 structure */
    DEFINE VARIABLE ReturnValue AS INTEGER   NO-UNDO.
 
    FOR EACH module : 
        DELETE module.
    END.
 
    IF RunningWindowsNT4() THEN DO:
       MESSAGE "Sorry, this procedure does not work with NT4"
               VIEW-AS ALERT-BOX.
       RETURN.
    END.
 
    /* Create and open SnapShot-list */
    RUN CreateToolhelp32Snapshot({&TH32CS_SNAPMODULE}, 
                                 0, 
                                 OUTPUT hSnapShot).
    IF hSnapShot = -1 THEN RETURN.
 
    /* init buffer for lpPE */
    SET-SIZE(lpME)    = 32 + 256 + 260.
    PUT-LONG(lpME, 1) = GET-SIZE(lpME).
 
    /* Cycle thru process-records */
    RUN Module32First(hSnapShot, 
                      lpME,
                      OUTPUT ReturnValue).
    DO WHILE ReturnValue NE 0:
 
       CREATE module.
       ASSIGN module.moduleName = GET-STRING(lpME, 33)
              module.modulePath = GET-STRING(lpME, 33 + 256)
              module.cntUsage   = GET-LONG(lpME, 17)
              module.hModule    = GET-LONG(lpME, 29).
 
       RUN Module32Next(hSnapShot, 
                        lpME,
                        OUTPUT ReturnValue).
    END.
 
    /* Close SnapShot-list */
    RUN CloseHandle(hSnapShot, OUTPUT ReturnValue).
 
END PROCEDURE.

In NT 4 the only way to find process information is by reading the registry in the HK_PERFORMANCE_DATA key. Interpreting the data in this registry interface is very complicated but there is a library, PSAPI.DLL, which contains a couple of higher-level procedures and reads the registry interface for you. PSAPI.DLL does not reveal every possible info from the registry but enough for this purpose.

PROCEDURE FindModules_NT4 :
    DEFINE VARIABLE ReturnValue AS INTEGER   NO-UNDO.
 
    DEFINE VARIABLE ProcessId      AS INTEGER NO-UNDO.
    DEFINE VARIABLE hProcess       AS INTEGER NO-UNDO.
    DEFINE VARIABLE lphMod         AS MEMPTR  NO-UNDO.
    DEFINE VARIABLE hModule        AS INTEGER NO-UNDO.
    DEFINE VARIABLE cbNeeded       AS INTEGER NO-UNDO.
    DEFINE VARIABLE szModuleName   AS CHARACTER    NO-UNDO.
    DEFINE VARIABLE szModuleNameEx AS CHARACTER    NO-UNDO.
    DEFINE VARIABLE i              AS INTEGER NO-UNDO.
 
    RUN GetCurrentProcessId (OUTPUT ProcessId).
    RUN OpenProcess ( {&PROCESS_QUERY_INFORMATION} + {&PROCESS_VM_READ},
                      0,
                      ProcessID,
                      OUTPUT hProcess).
 
    /* if process handle for the current process is found, then: */
    IF hProcess NE 0 THEN DO:
       SET-SIZE (lphMod) = 4 * 1024. /* should be more than enough */
 
       RUN EnumProcessModules ( hProcess,
                                GET-POINTER-VALUE(lphMod),
                                GET-SIZE(lphMod),
                                OUTPUT cbNeeded,
                                OUTPUT ReturnValue).
       IF ReturnValue NE 0 THEN DO:
 
          DO i=1 TO cbNeeded / 4 :
            hModule = GET-LONG(lphMod, (i - 1) * 4 + 1).
            szModuleName = "" + FILL(" ", {&MAX_PATH}).
            RUN GetModuleBaseNameA (hProcess,
                                    hModule,
                                    OUTPUT szModuleName,
                                    LENGTH(szModuleName),
                                    OUTPUT ReturnValue).
            /* ReturnValue is the number of returned bytes (chars): */
            szModuleName = TRIM(SUBSTRING(szModuleName,1,ReturnValue)).
 
            szModuleNameEx = "" + FILL(" ", {&MAX_PATH}).
            RUN GetModuleFileNameExA (hProcess,
                                      hModule,
                                      OUTPUT szModuleNameEx,
                                      LENGTH(szModuleNameEx),
                                      OUTPUT ReturnValue).
            /* ReturnValue is the number of returned bytes (chars): */
            szModuleNameEx = TRIM(SUBSTRING(szModuleNameEx,1,ReturnValue)).
 
            CREATE module.
            ASSIGN module.moduleName = szModuleName
                   module.modulePath = szModuleNameEx
                   module.cntUsage   = ?
                   module.hModule    = hModule.
 
          END.
 
          SET-SIZE (lphMod) = 0.
       END.
       RUN CloseHandle(hProcess, OUTPUT ReturnValue).
    END.
END PROCEDURE.

Definitions used in this procedure, not listed in windows.p :

&GLOB TH32CS_SNAPMODULE 8
&GLOB PROCESS_QUERY_INFORMATION 1024
&GLOB PROCESS_VM_READ 16
 
PROCEDURE CreateToolhelp32Snapshot EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER dwFlags        AS LONG.
  DEFINE INPUT  PARAMETER th32ProcessId  AS LONG.
  DEFINE RETURN PARAMETER hSnapShot      AS LONG.
END PROCEDURE.
 
PROCEDURE Module32First EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER hSnapShot        AS LONG.
  DEFINE INPUT  PARAMETER lpModuleEntry32  AS MEMPTR.
  DEFINE RETURN PARAMETER ReturnValue      AS LONG.
END PROCEDURE.
 
PROCEDURE Module32Next EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER hSnapShot        AS LONG.
  DEFINE INPUT  PARAMETER lpModuleEntry32  AS MEMPTR.
  DEFINE RETURN PARAMETER ReturnValue      AS LONG.
END PROCEDURE.
 
PROCEDURE EnumProcessModules EXTERNAL "psapi.dll" :
  DEFINE INPUT  PARAMETER hProcess    AS LONG.
  DEFINE INPUT  PARAMETER lphModule   AS LONG.  /* lp to array of module handles */
  DEFINE INPUT  PARAMETER cb          AS LONG.
  DEFINE OUTPUT PARAMETER cbNeeded    AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.
 
PROCEDURE GetModuleBaseNameA EXTERNAL "psapi.dll" :
  DEFINE INPUT  PARAMETER hProcess      AS LONG.
  DEFINE INPUT  PARAMETER hModule       AS LONG.
  DEFINE OUTPUT PARAMETER lpBaseName    AS CHARACTER.
  DEFINE INPUT  PARAMETER nSize         AS LONG.
  DEFINE RETURN PARAMETER nReturnedSize AS LONG.
END PROCEDURE.
 
PROCEDURE GetModuleFileNameExA EXTERNAL "psapi.dll" :
  DEFINE INPUT  PARAMETER hProcess      AS LONG.
  DEFINE INPUT  PARAMETER hModule       AS LONG.
  DEFINE OUTPUT PARAMETER lpFileName    AS CHARACTER.
  DEFINE INPUT  PARAMETER nSize         AS LONG.
  DEFINE RETURN PARAMETER nReturnedSize AS LONG.
END PROCEDURE.

Notes:

Function RunningWindowsNT4( ) is covered on page which version of Windows is running.

Procedure GetProductVersion(..) is covered on page File version information.

If you only want to find the path and name of the the current Progress executable module ("prowin32.exe") it is much more convenient to call GetModuleFileName.

NT Services Status

by Todd G. Nist

Program source is available for download: w-findservice.w
This is a program for an NT environment which will determine all of the computers on a given network and which services they are running. You can then inquire of a given server what the status is of a services and it will return weather it is running, in error, etc...

It has only been tested under NT 4.0 with service pack 3. You will have to be logged into and authenticated on the network in order to inquire of the status of services running on other machines in the network.

API-procedures used in this example are listed here to be included in the search index: 
PROCEDURE CloseServiceHandle     EXTERNAL "advapi32.dll"
PROCEDURE EnumServicesStatusA    EXTERNAL "advapi32.dll"
PROCEDURE OpenSCManagerA         EXTERNAL "advapi32.dll"
PROCEDURE OpenServiceA           EXTERNAL "advapi32.dll"
PROCEDURE QueryServiceConfigA    EXTERNAL "advapi32.dll"
PROCEDURE QueryServiceStatus     EXTERNAL "advapi32.dll"
PROCEDURE NetServerEnum          EXTERNAL "Netapi32.dll"
PROCEDURE NetApiBufferFree       EXTERNAL "Netapi32.dll"
PROCEDURE lstrcpyW               EXTERNAL "kernel32.dll"
PROCEDURE lstrlen                EXTERNAL "kernel32.dll"
PROCEDURE RtlMoveMemory          EXTERNAL "kernel32.dll"
PROCEDURE WideCharToMultiByte    EXTERNAL "kernel32.dll"
PROCEDURE GetComputerNameA       EXTERNAL "kernel32.dll"

Attachments

w-findservice.w.zip : example program

sleep (milliseconds)

The P4GL PAUSE function can only be used for whole seconds, not fractions of seconds.
A loop using the ETIME function can be used to wait for fractions of a second, but will keep the processor busy in the current thread.
The following call will wait for 0.5 seconds and minimize system load :

 
/* by Michael Rüsweg-Gilbert */
RUN sleep ( 500 ).
 
PROCEDURE Sleep EXTERNAL "KERNEL32":
  DEFINE INPUT  PARAMETER lMilliseconds AS LONG      NO-UNDO.
END PROCEDURE.

How does Sleep minimize system load?

Windows works multi-tasking, sort of. A thread is allowed to work for a certain time quantum. When that quantum is over, the running thread is suspended and one of the other threads can start its own time quantum. Which thread? Well, that is decided based on priorities and is not easy to understand, but one thing is clear: a thread is skipped when it has requested a Sleep.
As a matter of fact, the time quantum for the running thread will immediately be suspended when the thread calls Sleep.
In other words: Sleep gives extra time to other threads.

What is the meaning of Sleep(0)?

Sometimes you see Sleep(0) in source code. Sleep(0) does not take very long, it just gives the remainder of the current time quantum back to the operating system. Each of the other threads will have a turn (well, I am ignoring priority issues here) before the thread who called Sleep(0) will execute again.
So Sleep(0) can be useful when you need an other thread to respond to one of your actions.

Don't sleep too long

A window **has to** respond to messages within a fair amount of time, that's one of the rules of the GUI system. That is to say, the window has to be able to repaint itself and respond swiftly to user actions and system messages. A sleeping thread does not respond. In other words, a thread that owns windows should not sleep too long. More precisely: a thread that directly or indirectly creates windows. This also includes threads involved in DDE.
Somewhat off-topic: a thread that owns windows should also not do things like

FOR EACH order: 
   DELETE order.
END.

without PROCESS EVENTS inside the loop. Such actions should be performed by a second thread while the GUI thread continues. Oh well.

terminate a process gently

Topic TerminateProcess introduced the equivalent to the Unix "kill -9" command.
The following 4GL procedure KillProcess(pid) also terminates a process, but tries to avoid the use of TerminateProcess.
Procedure CloseProcessWindows is based on API-function EnumWindows. This API-function can not be called from within P4GL because it needs a callback, so I wrote procedure CloseProcessWindows in Pascal and added it to proextra.dll (see page ProExtra.dll). Of course I might as well have included all the rest in Pascal too, but then I would not allow myself to post it on this Progress site :-)
By the way, the topic on CreateProcess shows how to create a process and return a PID.

{windows.i}
{proextra.i}  /* version August 21, 1999 */
 
&GLOBAL-DEFINE PROCESS_QUERY_INFORMATION 1024
&GLOBAL-DEFINE PROCESS_TERMINATE 1
&GLOBAL-DEFINE STILL_ACTIVE 259
 
/* =======================================================
   IsProcessRunning
     Returns TRUE if the process is not terminated. 
     (also returns TRUE if the process is hanging)
   ------------------------------------------------------- */
FUNCTION IsProcessRunning RETURNS LOGICAL (PID AS INTEGER) :
 
  DEFINE VARIABLE IsRunning   AS LOGICAL NO-UNDO INITIAL NO.
  DEFINE VARIABLE hProcess    AS INTEGER NO-UNDO.
  DEFINE VARIABLE ExitCode    AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  RUN Sleep IN hpApi (0).
   /* Sleep(0) just gives the remainder of this
      thread's time quantum back to the task switcher so the other 
      process gets the opportunity to finish and release itself. */
 
  RUN OpenProcess IN hpApi
                  ( {&PROCESS_QUERY_INFORMATION},
                    0,
                    PID,
                    OUTPUT hProcess).
  IF hProcess NE 0 THEN DO:
     RUN GetExitcodeProcess IN hpApi
                  ( hProcess,
                    OUTPUT ExitCode,
                    OUTPUT ReturnValue).
     IsRunning = (ExitCode={&STILL_ACTIVE}) AND (ReturnValue NE 0).
     RUN CloseHandle IN hpApi(hProcess, OUTPUT ReturnValue).
  END.
  RETURN IsRunning.
END FUNCTION.
 
 
/* =======================================================
   KillProcess
     terminates a process as gently as possible.
     pHow tells you how it is done, for debugging purposes
   ------------------------------------------------------- */
PROCEDURE KillProcess :
   DEFINE INPUT  PARAMETER PID   AS INTEGER NO-UNDO.
   DEFINE OUTPUT PARAMETER pHow  AS CHARACTER    NO-UNDO.
 
   DEFINE VARIABLE cName         AS CHARACTER    NO-UNDO.
   DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
   DEFINE VARIABLE ProcessHandle AS INTEGER NO-UNDO.
 
   /* first step:  */
   /* ------------ */
   /* verify if the process is really running */
   pHow='not running'.
   IF NOT IsProcessRunning(PID) THEN RETURN.
 
   /* second step: */
   /* ------------ */
   /* does the process have windows?
      If it does, the nicest way to stop the process is 
      send a WM_CLOSE message to each window, as if a human operator 
      pressed the [x]-titlebar button.  */
 
   /* If the process is very young it might not have created a window yet.
      Use WaitForInputIdle to wait until the process has a window and is 
      ready to receive messages. */
 
   pHow='close'.
   RUN OpenProcess IN hpApi({&PROCESS_QUERY_INFORMATION}, 
                            0, 
                            PID, 
                            OUTPUT ProcessHandle).
   IF ProcessHandle NE 0 THEN
      RUN WaitForInputIdle IN hpApi(ProcessHandle,
                                    1000,  /* one second maximum */
                                    OUTPUT ReturnValue).
 
   RUN CloseProcessWindows IN hpExtra (PID, OUTPUT ReturnValue).
   /* ReturnValue=0 if the PID didn't own any windows.
      The windows may be too busy to close immediately. 
      Give them 5 seconds to respond. 
      That's what the Windows Task Manager would also do. */
   IF ReturnValue NE 0 THEN
      RUN WaitForSingleObject IN hpApi (ProcessHandle,
                                        5000, /* five seconds maximum */
                                        OUTPUT ReturnValue).
   RUN CloseHandle IN hpApi(ProcessHandle, OUTPUT ReturnValue).
 
   /* third step: */
   /* ----------- */
   /* If PID is a Progress session it would be nice to execute PROSHUT.
      You would first have to find the user number 
      via the VST _Connect table. And you would have
      to repeat this for every database the process is connected to. */
 
   /* I am not going to do this, but it would have been nice...   */
 
 
   /* last step: */
   /* ---------- */
   /* because everything else failed: TerminateProcess.
      This is similar to "kill -9" in Unix so should be avoided  */
 
   /* Must assume we have sufficient rights for terminating this process. */
   IF NOT IsProcessRunning(PID) THEN RETURN.
   pHow='kill'.
   RUN OpenProcess IN hpApi({&PROCESS_TERMINATE}, 0, PID, OUTPUT ProcessHandle).
   IF ProcessHandle NE 0 THEN DO:
      RUN TerminateProcess IN hpApi(ProcessHandle, 0, OUTPUT ReturnValue).
      RUN CloseHandle IN hpApi(ProcessHandle, OUTPUT ReturnValue).
   END.
 
   /* if everything failed the process will keep running. How could this happen? */
   IF IsProcessRunning(PID) THEN pHow='failed'.
 
END PROCEDURE.

terminating a process

To terminate a process for which you know the process handle, you can use function TerminateProcess.
If you don't know the process handle but the process identifier, you can get the handle by calling OpenProcess first.

DEFINE INPUT PARAMETER ProcessId AS INTEGER NO-UNDO.
 
DEFINE VARIABLE ProcessHandle AS INTEGER NO-UNDO.
DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
RUN OpenProcess ({&PROCESS_TERMINATE}, 0, ProcessId, OUTPUT ProcessHandle).
IF ProcessHandle NE 0 THEN DO:
   RUN TerminateProcess (ProcessHandle, 0, OUTPUT ReturnValue).
   RUN CloseHandle(ProcessHandle, OUTPUT ReturnValue).
END.

Definitions used in this procedure:

&GLOB PROCESS_TERMINATE 1
 
PROCEDURE OpenProcess EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER dwDesiredAccess AS LONG.
  DEFINE INPUT  PARAMETER bInheritHandle  AS LONG.
  DEFINE INPUT  PARAMETER dwProcessId     AS LONG.
  DEFINE RETURN PARAMETER hProcess        AS LONG.
END PROCEDURE.
 
PROCEDURE CloseHandle EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER hObject     AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.
 
PROCEDURE TerminateProcess EXTERNAL "kernel32" :
  DEFINE INPUT  PARAMETER hProcess  AS LONG.
  DEFINE INPUT  PARAMETER uExitCode AS LONG.
  DEFINE RETURN PARAMETER retval    AS LONG.
END PROCEDURE.

notes

TerminateProcess is guaranteed to free all resources allocated by the process.
But, similar to "kill -9" in Unix, the process will not get the opportunity to perform any of its shutdown code. Examples of shutdown code can be: writing "recent actions" in registry, notifying other processes, saving data etc.
Because of this, TerminateProcess should only be used as an emergency measure.
A more cautious way to terminate a process would be to find all its top-level windows and send a WM_CLOSE message to each of those windows. If this does not succeed within some time interval ("not responding") you can still use TerminateProcess.
An example of how to do this is on page terminate a process gently

the current Progress executable

by Sturla Johnsen

This procedure is convenient for tech support: it shows some information about the currently running Progress process like path and name of the Progress executable ("D:\DLC\BIN\PROWIN32.EXE"), the Progress version ("8.2C") and the serial number (believe me).

DEFINE VARIABLE hModule   AS INTEGER   NO-UNDO.
DEFINE VARIABLE cFileName AS CHARACTER NO-UNDO.
DEFINE VARIABLE RetVal    AS INTEGER   NO-UNDO.
 
ASSIGN hModule   = ?
       cFileName = FILL(" ",256).
 
RUN GetModuleFileNameA(hModule, OUTPUT cFileName, 256, OUTPUT RetVal).
 
MESSAGE "Progress exe :" SUBSTRING(cFileName, 1, RetVal) SKIP
        "version:"       PROVERSION SKIP
        "Serial number:" _SERIAL 
   VIEW-AS ALERT-BOX.     

Definitions used in this procedure, not listed in windows.p :

PROCEDURE GetModuleFileNameA EXTERNAL "kernel32.dll" :
  DEFINE INPUT  PARAMETER hModule    AS LONG.
  DEFINE OUTPUT PARAMETER lpFilename AS CHARACTER.
  DEFINE INPUT  PARAMETER nSize      AS LONG.
  DEFINE RETURN PARAMETER ReturnSize AS LONG.
END PROCEDURE.

Notes:

It is not required to find the actual module handle, because GetModuleFileName with module=NULL (or =? as we say in Progress) is documented to return the name of the module that started the process.
This makes it a light and convenient alternative for the source in example Modules in the current process which enumerates the names of all the modules in the current process.
An other advantage of this example is that function GetModuleFileName is available in every Windows version.

which version of Windows is running

** note: this topic is outdated, needs to be adjusted for ME and XP **
The API is not exactly the same for the different Windows versions so it is sometimes usefull to know which Windows version is running. However the differences may disappear when Windows 95/98 and Windows NT mature (or when add-ons are installed) so checking for the Windows version may become less interesting: you should prefer to check for features instead versions.
This procedure here shows what Windows version you are running providing it's a 32-bit version. These are:
* Windows 3.1 with win32s
* Windows 95
* Windows 95 OSR 2
* Windows 98
* NT 3.51
* NT 4.0
* Windows 2000
* Windows CE also runs a subset of WIN32 but CE isn't interesting for us.
The procedure also shows buildnumber and CSDversion. What a CSDversion is, is not always clear: on NT it's a string describing the latest installed Service Pack. On 95 it can be anything but CSDversion will be "a" if Service Pack 1 is installed.

{windows.i}
 
DEFINE VARIABLE lpVersionInfo AS MEMPTR.
DEFINE VARIABLE dwPlatformID AS INTEGER NO-UNDO.
DEFINE VARIABLE chPlatformID AS CHARACTER NO-UNDO.
DEFINE VARIABLE BuildNumber AS INTEGER NO-UNDO.
DEFINE VARIABLE MajorVersion AS INTEGER NO-UNDO.
DEFINE VARIABLE MinorVersion AS INTEGER NO-UNDO.
DEFINE VARIABLE ReturnValue  AS INTEGER NO-UNDO.
 
SET-SIZE(lpVersionInfo)   = 148.
PUT-LONG(lpVersionInfo,1) = 148.
RUN GetVersionExA IN hpApi( GET-POINTER-VALUE(lpVersionInfo), 
                            OUTPUT ReturnValue).
dwPlatformID = GET-LONG(lpVersionInfo,17).
 
CASE dwPlatformID :
  WHEN 0 THEN chPlatformID = "Win32s on Windows 3.1".
  WHEN 1 THEN chPlatformID = "Win32 on Windows 95 or 98".
  WHEN 2 THEN chPlatformID = "Win32 on Windows NT".
END.        
 
CASE dwPlatformID :
  WHEN 1 THEN BuildNumber = GET-SHORT(lpVersionInfo,13).
  WHEN 2 THEN BuildNumber = GET-LONG (lpVersionInfo,13).
  /* what about 'when 0' for 3.1 with win32s ?? */
END.
 
/* You have Windows 95 OSR 2 if:
     dwPlatformID=1
         and 
     LOWORD(BuildNumber)=1111 (probably hex??)
   Unfortunately I have not had a chance to test that.
*/
 
CASE dwPlatformID :
  WHEN 1 THEN DO:
                 MinorVersion = GET-BYTE(lpVersionInfo,15).
                 MajorVersion = GET-BYTE(lpVersionInfo,16).
              END.
  OTHERWISE DO:
                 MajorVersion = GET-LONG(lpVersionInfo, 5).
                 MinorVersion = GET-LONG(lpVersionInfo, 9).
              END.
END.
 
MESSAGE "MajorVersion=" MajorVersion SKIP
        "MinorVersion=" MinorVersion SKIP
        "BuildNumber="  BuildNumber SKIP
        "PlatformID="   chPlatFormId SKIP
        "CSDversion="   GET-STRING(lpVersionInfo,21) SKIP(2)
        "on NT, CSDversion contains version of latest Service Pack" SKIP
        "on 95/98, CSDversion contains arbitrary extra info, if any"
        VIEW-AS ALERT-BOX.
 
SET-SIZE(lpVersionInfo) = 0.

NT4 Terminal Server Edition

To check if you are running on Terminal Server Edition you can use function ValidateProductSuite("Terminal Server").
Old documentation suggested that this function would be added to the WIN32 API in Windows 2000. But newer documentation for Windows 2000 describes a new function VerifyVersionInfo - to be called with wSuiteMask = VER_SUITE_TERMINAL. We will see.
In the meantime you can write your own function ValidateProductSuite in Progress 4GL and some registry functions. An example is on page Disallowing multiple instances of your application.

A couple of convenient functions

FUNCTION RunningWindows95 RETURNS LOGICAL () :
  /* returns TRUE if you are running Windows 95 */
 
  DEFINE VARIABLE Win95         AS LOGICAL NO-UNDO.
  DEFINE VARIABLE lpVersionInfo AS MEMPTR.
  DEFINE VARIABLE dwPlatformID  AS INTEGER NO-UNDO.
  DEFINE VARIABLE MinorVersion  AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
  SET-SIZE(lpVersionInfo)   = 148.
  PUT-LONG(lpVersionInfo,1) = 148.
  RUN GetVersionExA IN hpApi( GET-POINTER-VALUE(lpVersionInfo), 
                              OUTPUT ReturnValue).
  dwPlatformID = GET-LONG(lpVersionInfo,17).
  MinorVersion = GET-BYTE(lpVersionInfo,15).
 
  Win95 = (dwPlatformId=1 AND MinorVersion=0).
 
  SET-SIZE(lpVersionInfo) = 0.
  RETURN Win95.
 
END FUNCTION.
 
FUNCTION RunningWindows98 RETURNS LOGICAL () :
  /* returns TRUE if you are running Windows 98 */
 
  DEFINE VARIABLE Win98         AS LOGICAL NO-UNDO.
  DEFINE VARIABLE lpVersionInfo AS MEMPTR.
  DEFINE VARIABLE dwPlatformID  AS INTEGER NO-UNDO.
  DEFINE VARIABLE MinorVersion  AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
  SET-SIZE(lpVersionInfo)   = 148.
  PUT-LONG(lpVersionInfo,1) = 148.
  RUN GetVersionExA IN hpApi( GET-POINTER-VALUE(lpVersionInfo), 
                              OUTPUT ReturnValue).
  dwPlatformID = GET-LONG(lpVersionInfo,17).
  MinorVersion = GET-BYTE(lpVersionInfo,15).
 
  Win98 = (dwPlatformId=1 AND MinorVersion=10).
 
  SET-SIZE(lpVersionInfo) = 0.
  RETURN Win98.
 
END FUNCTION.
 
FUNCTION RunningWindowsNT4 RETURNS LOGICAL () :
  /* returns TRUE if you are running Windows NT4.
     I have not had a chance to test this yet */
 
  DEFINE VARIABLE NT4           AS LOGICAL NO-UNDO.
  DEFINE VARIABLE lpVersionInfo AS MEMPTR.
  DEFINE VARIABLE dwPlatformID  AS INTEGER NO-UNDO.
  DEFINE VARIABLE MajorVersion  AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
  SET-SIZE(lpVersionInfo)   = 148.
  PUT-LONG(lpVersionInfo,1) = 148.
  RUN GetVersionExA IN hpApi( GET-POINTER-VALUE(lpVersionInfo), 
                              OUTPUT ReturnValue).
 
  dwPlatformID = GET-LONG(lpVersionInfo,17).
  MajorVersion = GET-BYTE(lpVersionInfo, 5).
 
  NT4 = (dwPlatformId=2 AND MajorVersion=4).
 
  SET-SIZE(lpVersionInfo) = 0.
  RETURN NT4.
 
END FUNCTION.
 
FUNCTION RunningWindows2000 RETURNS LOGICAL () :
  /* returns TRUE if you are running Windows 2000 */
 
  DEFINE VARIABLE Win2000       AS LOGICAL NO-UNDO.
  DEFINE VARIABLE lpVersionInfo AS MEMPTR.
  DEFINE VARIABLE dwPlatformID  AS INTEGER NO-UNDO.
  DEFINE VARIABLE MajorVersion  AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
 
  SET-SIZE(lpVersionInfo)   = 148.
  PUT-LONG(lpVersionInfo,1) = 148.
  RUN GetVersionExA IN hpApi( GET-POINTER-VALUE(lpVersionInfo), 
                              OUTPUT ReturnValue).
 
  dwPlatformID = GET-LONG(lpVersionInfo,17).
  MajorVersion = GET-BYTE(lpVersionInfo, 5).
 
  Win2000 = (dwPlatformId=2 AND MajorVersion=5).
 
  SET-SIZE(lpVersionInfo) = 0.
  RETURN Win2000.
 
END FUNCTION.

Another convenient function

Brad Long added this procedure which is indeed convenient.

FUNCTION WINGetVersion RETURNS CHARACTER () :
/*-----------------------------------------------------------------------------
  Purpose: Calls the WINAPI function GetVersionExA to determine the version
           of the Windows operating system that is running on the machine.
    Notes: Returns "95" for Windows 95, "98" for Windows 98, "NT" for Windows NT
           Returns "undef" if unable to determine platform.
------------------------------------------------------------------------------*/
 
    DEFINE VARIABLE v_version-buf AS MEMPTR.
    DEFINE VARIABLE v_platform-id AS INTEGER NO-UNDO.
    DEFINE VARIABLE v_platform-desc AS CHARACTER NO-UNDO.
    DEFINE VARIABLE v_major-version AS INTEGER NO-UNDO.
    DEFINE VARIABLE v_minor-version AS INTEGER NO-UNDO.
    DEFINE VARIABLE v_return-value  AS INTEGER NO-UNDO.
 
    SET-SIZE(v_version-buf)   = 148.
    PUT-LONG(v_version-buf,1) = 148.
 
    RUN GetVersionExA (INPUT GET-POINTER-VALUE(v_version-buf),
                       OUTPUT v_return-value).
 
    v_platform-id = GET-LONG(v_version-buf,17).
 
    CASE v_platform-id:
        WHEN 1 THEN DO:
            v_minor-version = GET-BYTE(v_version-buf,15).
            v_major-version = GET-BYTE(v_version-buf,16).
        END.
        OTHERWISE DO:
            v_major-version = GET-LONG(v_version-buf,5).
            v_minor-version = GET-LONG(v_version-buf,9).
        END.
    END.
 
    CASE v_platform-id:
        WHEN 0 THEN v_platform-desc = "3.1".
        WHEN 1 THEN
        DO:
            IF v_minor-version EQ 0 THEN v_platform-desc = "95".
            ELSE IF v_minor-version GT 0 THEN v_platform-desc = "98".
            ELSE v_platform-desc = "undef".
        END.
        WHEN 2 THEN
            v_platform-desc = "NT".
        OTHERWISE
            v_platform-desc = "undef".
    END.
 
    SET-SIZE(v_version-buf) = 0.
 
    RETURN v_platform-desc.
 
END FUNCTION.

(hexa)decimal values in registry

Suppose there is a registry key

     HKEY_LOCAL_MACHINE\Software\Nerdware\Test

and suppose it contains a DWORD value, named "count".
This source example will read the value of "count", identifies the datatype, and increment the value of "count" by one.

{windows.i} /* March 28, 1998 or later */
 
DEFINE VARIABLE key-hdl        AS INTEGER NO-UNDO.
DEFINE VARIABLE lpBuffer       AS MEMPTR  NO-UNDO.
DEFINE VARIABLE lth            AS INTEGER NO-UNDO.
DEFINE VARIABLE reslt          AS INTEGER NO-UNDO.
DEFINE VARIABLE datatype       AS INTEGER NO-UNDO.             
DEFINE VARIABLE icount         AS INTEGER NO-UNDO.
 
 
RUN RegOpenKeyA IN hpApi ( {&HKEY_LOCAL_MACHINE},
                           "Software\Nerdware\Test",
                           OUTPUT key-hdl,
                           OUTPUT reslt).
 
IF reslt NE {&ERROR_SUCCESS} THEN DO:
   MESSAGE "key not found in registry" VIEW-AS ALERT-BOX.
   RETURN.
END.
 
/* read value of "count" into lpBuffer */
/* make buffer large, because we don't know 
   for sure if it is really a DWORD.
   The maximum size is supposed to be MAX_PATH + 1 */
 
ASSIGN lth                = {&MAX_PATH} + 1
       SET-SIZE(lpBuffer) = lth.
 
RUN RegQueryValueExA IN hpApi (key-hdl,
                               "count",
                               0, /* reserved, must be 0 */
                               OUTPUT datatype,
                               GET-POINTER-VALUE(lpBuffer),
                               INPUT-OUTPUT lth,
                               OUTPUT reslt).
 
IF reslt NE {&ERROR_SUCCESS} THEN
   MESSAGE "value not found in registry" VIEW-AS ALERT-BOX.
ELSE DO:
     CASE datatype :
        WHEN 1 THEN  MESSAGE "datatype=STRING" SKIP
                             "value="  GET-STRING(lpBuffer,1)
                             VIEW-AS ALERT-BOX.
        WHEN 4 THEN  MESSAGE "datatype=DWORD" SKIP
                             "value="  GET-LONG(lpBuffer,1)
                             VIEW-AS ALERT-BOX.
        OTHERWISE    MESSAGE "unexpected datatype:" SKIP
                             "datatype=" datatype   SKIP
                              VIEW-AS ALERT-BOX.
     END CASE.
 
 
     /* if it is a DWORD, then increment the value */
     IF datatype=4 THEN DO:
 
        icount = GET-LONG(lpBuffer,1). 
        SET-SIZE(lpBuffer)   = 4. /* =sizeof(DWORD) */
        PUT-LONG(lpBuffer,1) = icount + 1. 
 
        RUN RegSetValueExA IN hpApi (key-hdl,
                                     "count",
                                     INPUT 0, /* reserved, must be 0 */
                                     INPUT 4, /* = REG_DWORD */
                                     INPUT GET-POINTER-VALUE(lpBuffer),
                                     INPUT 4, /* = get-size(lpBuffer) */
                                     OUTPUT reslt).
        IF reslt NE {&ERROR_SUCCESS} THEN
           MESSAGE "can not write value in registry" VIEW-AS ALERT-BOX.
     END.
END.
 
SET-SIZE(lpBuffer)=0.
RUN RegCloseKey IN hpApi (key-hdl,OUTPUT reslt).

notes

function RegSetValueEx will create the value "count" if it did not exist yet. So even if RegQueryValue did not find the value, you can still set one. Of course you will have to change the logic of this source example to allow that.
There are more datatypes than just REG_SZ (=1) and REG_DWORD (=4). Check your API documentation for a complete list.

Enumerating registry values

This example enumerates all values in a given registry key.
In this case, it will return a list of all installed printers (with their names and ports), so it actually does the same as the EnumPrinters function.
As explained in the registry introduction you should prefer to use the EnumPrinters function instead of this RegEnumA stuff, because Microsoft may decide to store the printers info elsewhere in the future, while the EnumPrinters API will be maintained.

{windows.i}  /* March 28, 1998 or later */
 
DEFINE VARIABLE hKey        AS INTEGER NO-UNDO.
DEFINE VARIABLE hPrinterkey AS INTEGER NO-UNDO.
DEFINE VARIABLE subkey      AS CHARACTER    NO-UNDO.
DEFINE VARIABLE port        AS MEMPTR  NO-UNDO.
DEFINE VARIABLE lth         AS INTEGER NO-UNDO.
DEFINE VARIABLE reslt       AS INTEGER NO-UNDO.
DEFINE VARIABLE datatype    AS INTEGER NO-UNDO.
DEFINE VARIABLE ITEM        AS INTEGER NO-UNDO.
 
RUN RegOpenKeyA IN hpApi( {&HKEY_LOCAL_MACHINE},
                          "System\CurrentControlSet\control\Print\Printers",
                          OUTPUT hKey,
                          OUTPUT reslt).
 
ASSIGN ITEM  = 0
       reslt = 0.
 
DO WHILE reslt NE {&ERROR_NO_MORE_ITEMS} :
 
   ASSIGN lth     = {&MAX_PATH} + 1
          subkey  = FILL("x", lth).
 
   RUN RegEnumKeyA IN hpApi (hKey, 
                             ITEM, 
                             OUTPUT subkey, 
                             INPUT LENGTH(subkey), 
                             OUTPUT reslt).
 
   IF reslt NE {&ERROR_NO_MORE_ITEMS} THEN DO:
 
      /* get the printer port (or description..) */
      RUN RegOpenKeyA IN hpApi ( hKey,
                                 subkey,
                                 OUTPUT hPrinterkey,
                                 OUTPUT reslt).
      lth  = {&MAX_PATH} + 1.
      SET-SIZE(port) = lth.
      RUN RegQueryValueExA IN hpApi (hPrinterkey,
                                     "port",
                                     0,  /* reserved, must be 0 */
                                     OUTPUT datatype,
                                     GET-POINTER-VALUE(port),
                                     INPUT-OUTPUT lth,
                                     OUTPUT reslt).
      RUN RegCloseKey IN hpApi (hPrinterkey,OUTPUT reslt).
 
      MESSAGE "printer name=" subkey SKIP 
              "port="         GET-STRING(port,1)
              VIEW-AS ALERT-BOX.
 
   END.
 
   ITEM = ITEM + 1.
END. /* do while not ERROR_NO_MORE_ITEMS */
 
SET-SIZE(port)=0.       
RUN RegCloseKey IN hpApi (hKey,OUTPUT reslt).

Notes

Obviously a (sub)key may contain values with different datatypes, like strings and numbers. You should test the 'datatype' parameter before you interpret a value. For an example of this, see RegQueryValueEx

RegCreateKeyEx

Function RegCreateKeyEx creates a registry key and opens it. If the key already exists, the function will just open it.

{windows.i}
 
&SCOPED-DEFINE KEY_ALL_ACCESS 983103
&SCOPED-DEFINE REG_OPTION_NON_VOLATILE 0
&SCOPED-DEFINE REG_OPTION_VOLATILE 1
&SCOPED-DEFINE REG_CREATED_NEW_KEY 1
&SCOPED-DEFINE REG_OPENED_EXISTING_KEY 2                                                 
 
PROCEDURE RegCreateKeyEx{&A} EXTERNAL {&ADVAPI} :
  DEFINE INPUT  PARAMETER hkey                 AS LONG.
  DEFINE INPUT  PARAMETER lpszSubKey           AS CHARACTER.
  DEFINE INPUT  PARAMETER dwReserved           AS LONG.
  DEFINE INPUT  PARAMETER plszClass            AS CHARACTER.
  DEFINE INPUT  PARAMETER dwOptions            AS LONG.
  DEFINE INPUT  PARAMETER samDesired           AS LONG.
  DEFINE INPUT  PARAMETER lpSecurityAttributes AS LONG.
  DEFINE OUTPUT PARAMETER phkResult            AS LONG.
  DEFINE OUTPUT PARAMETER lpdwDisposition      AS LONG.
  DEFINE RETURN PARAMETER lpResult             AS LONG.
END PROCEDURE.
 
 
/* example : */
 
DEFINE VARIABLE key-hdl    AS INTEGER NO-UNDO.
DEFINE VARIABLE dwDisposition     AS INTEGER NO-UNDO.  
DEFINE VARIABLE reslt      AS INTEGER NO-UNDO.
 
  RUN RegCreateKeyEx{&A} IN /* hpApi */ THIS-PROCEDURE 
    ( {&HKEY_CLASSES_ROOT},
    "SoftWare\MyCompany",
    0,
    '':U, 
    {&REG_OPTION_NON_VOLATILE},
    {&KEY_ALL_ACCESS}, 
    0,
    OUTPUT key-hdl,
    OUTPUT dwDisposition,
    OUTPUT reslt).
 
  IF reslt NE 0 THEN 
     MESSAGE "function RegCreateKeyEx failed" VIEW-AS ALERT-BOX.
  ELSE 
     CASE dwDisposition :
       WHEN {&REG_CREATED_NEW_KEY}     THEN MESSAGE "created new key" 
                                                    VIEW-AS ALERT-BOX.
       WHEN {&REG_OPENED_EXISTING_KEY} THEN MESSAGE "opened existing key"
                                                    VIEW-AS ALERT-BOX.
     END.   
 
 
  /* use the key */
  ....
 
  /* close it */
  RUN RegCloseKey IN hpApi (key-hdl, OUTPUT reslt).
 

notes

The example creates key "Software\MyCompany" or opens it if the key already exists.
Variable key-hdl returns a handle to the open key. This handle can be used in subsequent functions and must eventually be closed by function RegCloseKey.

Associated icon

Chris Herring submitted the following code to draw the associated icon for any document on a button. For example: you created a button to open a file like "c:\invoices\abc001.doc", the file extension "doc" is associated with MS-Word so you want the icon for Word-documents displayed on the Progress button.
The remainder of the text is from Chris. As you see, he has some issues left. If you know the solution, please click the "Edit"-link near the bottom of this page to help out.
There were two ways I found to add the icon, using SendMessageA and ImageList_Draw. SendMessageA works ok except it suffers from the same limitations and the toggle button - can't remove focus. ImageList_Draw seems to be able to draw the icon on progress widgets that have the HWND attribute( at least the button and frame anyway ) but the image is release whenever the display for the image is refreshed. On the plus side it would work with flat buttons if you could get the image to stay. Anyway I've put some of my code below. Only thing that I'm aware of that is not entirely correct is the size of the fileinfo memptr regarding the last two string parameters. I wasn't sure of the size so I set them to 1 which only returns the first char of the string if the display name and type tags are added to the flag.

&GLOBAL-DEFINE GWL_STYLE -16 
&GLOBAL-DEFINE BM_SETIMAGE 247 
&GLOBAL-DEFINE IMAGE_ICON 1 
&GLOBAL-DEFINE SHGFI_ICON 256 
&GLOBAL-DEFINE SHGFI_SYSICONINDEX 16384 
&GLOBAL-DEFINE SHGFI_USEFILEATTRIBUTES 16 
&GLOBAL-DEFINE FILE_ATTRIBUTE_NORMAL 128 
&GLOBAL-DEFINE BS_ICON 64 
PROCEDURE SHGetFileInfo EXTERNAL 'shell32': 
    DEFINE INPUT  PARAMETER pszPath AS CHARACTER. 
    DEFINE INPUT  PARAMETER dwFileAttributes AS LONG. 
    DEFINE OUTPUT PARAMETER SBFileInfo AS MEMPTR. 
    DEFINE INPUT  PARAMETER cbSizeFileInfo AS LONG. 
    DEFINE INPUT  PARAMETER uFlags AS LONG. 
    DEFINE RETURN PARAMETER ReturnValue AS LONG. 
END PROCEDURE. 
PROCEDURE ImageList_Draw EXTERNAL "comctl32": 
    DEFINE INPUT  PARAMETER himl AS LONG. 
    DEFINE INPUT  PARAMETER iIndex AS LONG. 
    DEFINE INPUT  PARAMETER hdc AS LONG. 
    DEFINE INPUT  PARAMETER X AS LONG. 
    DEFINE INPUT  PARAMETER Y AS LONG. 
    DEFINE INPUT  PARAMETER iStyle AS LONG. 
    DEFINE RETURN PARAMETER lBool AS LONG. 
END PROCEDURE. 
PROCEDURE setButton :
/*-- Purpose: gets the icon from a program, file, or extension and draws the icon 
                on the specified button 
      Notes:  the button must not be flat or no-focus     
    ------------------------------------------------------------------------------*/ 
    DEFINE INPUT  PARAMETER iHwnd            AS INTEGER    NO-UNDO. 
    DEFINE INPUT  PARAMETER iphButton        AS HANDLE     NO-UNDO.
    DEFINE INPUT  PARAMETER pcProgram        AS CHARACTER  NO-UNDO. 
    DEFINE INPUT  PARAMETER plExtension      AS LOGICAL    NO-UNDO. 
    DEFINE VARIABLE iSize AS INTEGER NO-UNDO. 
    DEFINE VARIABLE fileinfo AS MEMPTR NO-UNDO. 
    DEFINE VARIABLE iFlags AS INTEGER NO-UNDO. 
    DEFINE VARIABLE iReturn AS INTEGER NO-UNDO. 
    DEFINE VARIABLE hIcon AS INTEGER NO-UNDO. 
    DEFINE VARIABLE iIcon AS INTEGER NO-UNDO. 
    DEFINE VARIABLE iAttr AS INTEGER NO-UNDO. 
    DEFINE VARIABLE cDName AS CHARACTER NO-UNDO. 
    DEFINE VARIABLE cType AS CHARACTER NO-UNDO. 
    DEFINE VARIABLE iStyles AS INTEGER NO-UNDO. 
    DEFINE VARIABLE iOldIcon AS INTEGER NO-UNDO. 
    SET-SIZE(fileinfo) = 4 + 4 + 4 + 1 + 1. 
    iSize = GET-SIZE(fileinfo). 
    IF iSize NE 0 THEN DO: 
        /*RUN SHGetFileInfo( "C:\Program Files\Internet Explorer\IEXPLORE.EXE", 0, OUTPUT fileinfo, iSize, iFlags, OUTPUT lReturn ).*/
        /*RUN SHGetFileInfo( ".html", 128, OUTPUT fileinfo, iSize, iFlags, OUTPUT lReturn ).*/ 
        IF plExtension THEN DO: 
            iFlags = {&SHGFI_ICON} + {&SHGFI_USEFILEATTRIBUTES}. 
            RUN SHGetFileInfo( pcProgram, {&FILE_ATTRIBUTE_NORMAL}, OUTPUT fileinfo, iSize, iFlags, OUTPUT iReturn ). 
        END. 
        ELSE DO: 
            iFlags = {&SHGFI_ICON}. 
            RUN SHGetFileInfo( pcProgram, 0, OUTPUT fileinfo, iSize, iFlags, OUTPUT iReturn ). 
        END. 
        hIcon = GET-LONG(fileinfo, 1). 
        iIcon = GET-LONG(fileinfo, 5). 
        iAttr = GET-LONG(fileinfo, 9). 
        cDName = GET-STRING(fileinfo, 13). 
        cType = GET-STRING(fileinfo, 14). 
        SET-SIZE(fileinfo) = 0. 
    END.
    RUN GetWindowLongA(iHwnd, {&GWL_STYLE}, OUTPUT iStyles). 
    IF iphButton:PRIVATE-DATA EQ ? 
        THEN ASSIGN iStyles = iStyles + {&BS_ICON}
                    iphButton:PRIVATE-DATA = "loaded". 
        ELSE ASSIGN iStyles = iStyles. 
    RUN SetWindowLongA(iHwnd, {&GWL_STYLE}, iStyles, OUTPUT iStyles). 
    RUN SendMessageA( iHwnd, {&BM_SETIMAGE}, {&IMAGE_ICON}, hIcon, OUTPUT iOldIcon). 
END PROCEDURE.

Buttons in pushed state

This example has some advantages over the older example. This example shows an easy way to create buttons that can have a "pushed" state. These buttons are actually toggle-box widgets with an alternative layout. That is convenient because you don't need any special code to read and set the logical value: the usual statement toggle-1=TRUE will be sufficient to show the button in pushed state.

Width and height are set high enough to fit the image. You can simply use the UIB/AB to do this.
You don't really need to put images on these buttons: just don't use the BS_ICON style (or BS_BITMAP) if you want to keep the label.
Note: I could not manage to get a NO-FOCUS effect. If you have ideas about this please let me know.

    
RUN ToggleToButton (toggle-1:HWND).
 
/* show an icon or bitmap on the button. There are several ways of 
   doing this. I got lazy so I chose this method for 32x32 icons. */
RUN SetIcon (toggle-1:HWND, 'winupd.ico').

    
PROCEDURE ToggleToButton :                   
/* -------------------------------------------------------------------
   purpose: convert a toggle-box widget to a button.
   note   : don't call this more than once for each toggle-box widget 
   ------------------------------------------------------------------- */
  DEFINE INPUT PARAMETER HWND AS INTEGER.
 
  DEFINE VARIABLE styles      AS INTEGER NO-UNDO.
  DEFINE VARIABLE returnvalue AS INTEGER NO-UNDO.
 
  /* find the current style and add some extra flags to it */
  RUN GetWindowLongA(HWND, {&GWL_STYLE}, OUTPUT styles).
  styles = styles + {&BS_ICON} + {&BS_PUSHLIKE}.
 
  /* according to MSDN you should apply the new style 
     using SendMessage(hwnd,BM_SETSTYLE,....) but it does not work for me */
  RUN SetWindowLongA(HWND, {&GWL_STYLE}, styles, OUTPUT styles).
 
  /* force a repaint: */
  RUN InvalidateRect(HWND,0,1,OUTPUT returnvalue).
 
END PROCEDURE.

 
    
PROCEDURE SetIcon :
  DEFINE INPUT PARAMETER HWND         AS INTEGER.
  DEFINE INPUT PARAMETER IconFilename AS CHARACTER.
 
  DEFINE VARIABLE hInstance   AS INTEGER NO-UNDO.
  DEFINE VARIABLE OldIcon     AS INTEGER NO-UNDO.
  DEFINE VARIABLE hIcon       AS INTEGER NO-UNDO.
 
  RUN GetWindowLongA(HWND,
                     {&GWL_HINSTANCE},
                     OUTPUT hInstance).
  RUN ExtractIconA (hInstance, IconFilename, 0, OUTPUT hIcon).
 
  RUN SendMessageA( HWND, 
                    {&BM_SETIMAGE}, 
                    {&IMAGE_ICON}, 
                    hIcon, 
                    OUTPUT OldIcon).
 
/* free resources when the window closes, or earlier:
     run DestroyIcon (hIcon). */
 
   IF OldIcon NE 0 THEN 
      RUN DestroyIcon (OldIcon).
 
END PROCEDURE.

Definitions used in this example:

&GLOBAL-DEFINE GWL_HINSTANCE -6  
&GLOBAL-DEFINE GWL_STYLE -16
&GLOBAL-DEFINE BS_PUSHLIKE 4096
&GLOBAL-DEFINE BS_ICON 64
&GLOBAL-DEFINE BS_BITMAP 128
&GLOBAL-DEFINE BM_SETIMAGE 247
&GLOBAL-DEFINE IMAGE_ICON 1
&GLOBAL-DEFINE IMAGE_BITMAP 0
&GLOBAL-DEFINE BM_SETSTYLE 244
 
 
PROCEDURE ExtractIconA EXTERNAL "shell32.dll" :
  DEFINE INPUT  PARAMETER hInst AS LONG.
  DEFINE INPUT  PARAMETER lpszExeFileName AS CHARACTER.
  DEFINE INPUT  PARAMETER nIconIndex AS LONG.
  DEFINE RETURN PARAMETER hIcon  AS LONG.
END PROCEDURE.
 
PROCEDURE DestroyIcon EXTERNAL "user32.dll" :
  DEFINE INPUT PARAMETER hIcon AS LONG.
END PROCEDURE.
 
PROCEDURE GetWindowLongA EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER phwnd       AS LONG.
  DEFINE INPUT  PARAMETER cindex      AS LONG.
  DEFINE RETURN PARAMETER currentlong AS LONG.
END PROCEDURE.
 
PROCEDURE SetWindowLongA EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER phwnd   AS LONG.
  DEFINE INPUT  PARAMETER cindex  AS LONG.
  DEFINE INPUT  PARAMETER newlong AS LONG.
  DEFINE RETURN PARAMETER oldlong AS LONG.
END PROCEDURE.
 
PROCEDURE InvalidateRect EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER HWND        AS LONG.
  DEFINE INPUT  PARAMETER lpRect      AS LONG.
  DEFINE INPUT  PARAMETER bErase      AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.
 
PROCEDURE SendMessageA EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER HWND        AS LONG.
  DEFINE INPUT  PARAMETER umsg        AS LONG.
  DEFINE INPUT  PARAMETER wparam      AS LONG.
  DEFINE INPUT  PARAMETER lparam      AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.

Buttons in pushed state

See for an improved version: Buttons in pushed state

This example works best with Progress version 9.
When you create a 'toolbar' with buttons, you may sometimes want to keep a button in a 'pushed' state indicating if the functionality for the button is toggled 'on'.
In that case you could run the following ToggleButton procedure during the ON CHOOSE event of the button widget:

{windows.i}
PROCEDURE ToggleButton :
  DEFINE INPUT PARAMETER hbutton AS HANDLE.
 
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
  &SCOP BM_SETSTATE 243
 
  IF hbutton:TYPE NE 'button' THEN RETURN.
 
  IF hbutton:PRIVATE-DATA = 'pushed' THEN DO:
     hbutton:PRIVATE-DATA = ''.
     RUN SendMessageA IN hpApi ( hbutton:HWND, 
                                 {&BM_SETSTATE}, 
                                 0,   /* FALSE, remove BST_PUSHED style */
                                 0, 
                                 OUTPUT ReturnValue).
  END.
  ELSE DO: 
     hbutton:PRIVATE-DATA = 'pushed'.
     RUN SendMessageA IN hpApi ( hbutton:HWND, 
                                 {&BM_SETSTATE}, 
                                 1,  /* TRUE, set BST_PUSHED style */
                                 0, 
                                 OUTPUT ReturnValue).
  END.
 
END PROCEDURE.

Notes

There are several button types in Progress: flat, no-focus, buttons with images and 'normal' buttons with text. In version 9 this procedure works for all button types, but in version 8 it works only for buttons with no images.

This enhancement is undocumented.

I have used the private-data attribute to store the current state of the button. It would also be possible to use the BM_GETSTATE message to query if the button is in it's 'pushed' state, but this is not useful during the ON CHOOSE event. After all, the button is always pushed during the ON CHOOSE event!
There is a however a problem: when focus moves away to another (non-Progress) application, all pushed buttons become 'unpushed'. This problem is reported to PSC and may be fixed in the future, but unfortunately it has a very low priority.

Changing the shape of a window

example by Simon de Kraa

This example program replaces the rectangular region of a window by a polygon. The technique is basically the same as described on page round widgets. You can download the example source from the attachments table.
A polygon is an array of points. The coordinates for the points in this example are calculated using the trigonometry functions sin and cos (found in the Visual C runtime module which is available on almost every PC). The number of points can be selected using the slider control; selecting a large number of points is somewhat slow but gives an interesting result as shown in the picture.
API declarations used in this example:

PROCEDURE CreatePolygonRgn EXTERNAL "gdi32.dll":
  DEFINE INPUT  PARAMETER lpPoint       AS MEMPTR.
  DEFINE INPUT  PARAMETER nCount        AS LONG.
  DEFINE INPUT  PARAMETER nPolyFillMode AS LONG.
  DEFINE RETURN PARAMETER ReturnValue   AS LONG.
END PROCEDURE.  
 
PROCEDURE sin EXTERNAL "MSVCRT40.DLL" CDECL:
  DEFINE INPUT  PARAMETER dblValue  AS DOUBLE NO-UNDO.
  DEFINE RETURN PARAMETER dblResult AS DOUBLE NO-UNDO.
END PROCEDURE.
 
PROCEDURE cos EXTERNAL "MSVCRT40.DLL" CDECL:
  DEFINE INPUT  PARAMETER dblValue  AS DOUBLE NO-UNDO.
  DEFINE RETURN PARAMETER dblResult AS DOUBLE NO-UNDO.
END PROCEDURE.

Attachments

polygon.zip : demo source

Combo-box with item-data

Page Selection-list with item-data shows how and when to use itemdata with a selection list. The same works for a combo-box, except the message constants are different.
Let's skip the background info and go right to the source:

{windows.i}
PROCEDURE AddComboItem :
/*------------------------------------------------------------------------------
  Purpose:     add an item to the combo-box. Each item can be associated with 
               itemdata (is low-level implementation of PRIVATE-DATA).
------------------------------------------------------------------------------*/
  DEFINE INPUT PARAMETER ip_hCombobox AS HANDLE  NO-UNDO.
  DEFINE INPUT PARAMETER ip_ItemText  AS CHARACTER    NO-UNDO.
  DEFINE INPUT PARAMETER ip_ItemData  AS INTEGER NO-UNDO.
 
  DEFINE VARIABLE lpString AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE SelIndex AS INTEGER NO-UNDO.
  DEFINE VARIABLE retval   AS INTEGER NO-UNDO.
 
  SET-SIZE(lpString)     = 0.
  SET-SIZE(lpString)     = LENGTH(ip_ItemText) + 1.
  PUT-STRING(lpString,1) = ip_ItemText.
 
  RUN SendMessageA IN hpAPi
                   (ip_hCombobox:HWND,
                    323, /* = CB_ADSTRING */
                    0,
                    GET-POINTER-VALUE(lpString),
                    OUTPUT selIndex).
 
  RUN SendMessageA IN hpApi
                   (ip_hCombobox:HWND IN FRAME frame-tools ,
                    337, /* = CB_SETITEMDATA */
                    SelIndex,
                    ip_ItemData,
                    OUTPUT retval).
  SET-SIZE(lpString)=0.
 
  RETURN.
END PROCEDURE.

The first call to SendMessage adds a text to the combo-box, so it does the same as combo-1:ADD-LAST(ip_ItemText). However it also returns a SelIndex, which is the unique and constant index number for the new combo item. This SelIndex is used in the second call to SendMessage.
The second call to SendMessage adds an integer data value to the combo-item.

{windows.i}
ON VALUE-CHANGED OF COMBO-1 IN FRAME FRAME-tools /* Procedure */
DO:
  DEFINE VARIABLE SelIndex AS INTEGER NO-UNDO.
  DEFINE VARIABLE ItemData AS INTEGER NO-UNDO.
 
  RUN SendMessageA (combo-1:HWND,
                    327, /* = CB_GETCURSEL */
                    0, 
                    0,
                    OUTPUT SelIndex).
 
  RUN SendMessageA (combo-1:HWND,
                    336, /* = CB_GETITEMDATA */
                    SelIndex, 
                    0,
                    OUTPUT ItemData).
 
  RUN Whatever(ItemData).
END.

Notes

Normally I would prefer to use the Progress 9 feature of ITEM-DATA-PAIRS instead of this API solution. But ITEM-DATA-PAIRS are designed to work only if the screen-values are unique!

cut, copy and paste

A typical Windows application has an Edit menu with options for Undo, Cut, Copy and Paste. There are 4GL methods for making such a menu. This site usually does not cover 4GL methods, but I would like to make an exception this time because these 4GL methods are not documented. This was posted by email to PEG by Matt Gilarde:

Starting in 8.2A, Progress supports several new attributes and
methods which make implementing the Edit menu very simple.
Unfortunately, these features were added in the late stage of
8.2 development and were not adequately documented.  Briefly,
the new attributes and methods are:
 
Editor only:
EDIT-CAN-UNDO - TRUE if editor can undo last operation
EDIT-UNDO() - undo last operation
 
Fill-in and Editor:
EDIT-CAN-PASTE - TRUE if the clipboard contains pastable text
EDIT-PASTE() - paste clipboard text into editor or fill-in
EDIT-CLEAR() - delete contents of selection in editor or fill-in
EDIT-CUT() - cut selected contents of editor or fill-in to clipboard
EDIT-COPY() - copy selected contents of editor or fill-in to clipboard
 
The following methods and attributes will work for fill-ins in
Skywalker (they currently work only for editors):
 
CLEAR-SELECTION()
SELECTION-END
SELECTION-START
SELECTION-TEXT
SET-SELECTION()
TEXT-SELECTED
READ-ONLY
 
 
Matt Gilarde - PSC Development

Force Combo-box drop down

by Stuart Morris

Suppose you have a combo-box widget (named combo-box-1) and you want to drop down its built-in selection-list on some event. The following source will do just that.

{windows.i}
&GLOBAL-DEFINE CB_SHOWDROPDOWN 335
 
DEFINE VARIABLE retval AS INTEGER NO-UNDO.
 
  RUN SendMessage{&A} IN hpApi (INPUT  COMBO-BOX-1:HWND,
                                       {&CB_SHOWDROPDOWN},
                                       1,   /* True */
                                       0,
                                OUTPUT retval
                                )
                                NO-ERROR /* Stop C Stack Errors */.

Round widgets

changing the shape of a widget

based on an example by Sturla Johnsen

The animated gif shows an impression of Rounddemo.w.
Rounddemo, written by Sturla Johnsen, creates a normal Progress dialog box with some widgets on it (a frame, two fill-ins and two buttons) and demonstrates how the default rectangular region of any widget can be replaced by a different shaped region. In this case by elliptic regions.
Rounddemo.w calls procedure Roundwidget.p from within the CHOOSE trigger of the button. Both procedures are attched (see table near end of this topic) and can be downloaded from here to see for yourself.

ON CHOOSE OF BUTTON-1 IN FRAME Dialog-Frame /* Press me (several times) */
DO:
  IF SELF:PRIVATE-DATA = ? THEN 
     ASSIGN SELF:PRIVATE-DATA = "1".
  DEFINE VARIABLE HANDLE AS HANDLE.
  CASE INT(SELF:PRIVATE-DATA):
    WHEN 1 THEN ASSIGN HANDLE = FRAME {&FRAME-NAME}:HANDLE.
    WHEN 2 THEN ASSIGN HANDLE = FILL-IN-1:HANDLE.
    WHEN 3 THEN ASSIGN HANDLE = FILL-IN-2:HANDLE.
    WHEN 4 THEN ASSIGN HANDLE = FRAME FRAME-A:HANDLE.
    WHEN 5 THEN ASSIGN HANDLE = SELF.
    WHEN 6 THEN ASSIGN HANDLE = Btn_Close:HANDLE
                       SELF:SENSITIVE = NO.
    OTHERWISE RETURN NO-APPLY.
  END CASE.
  RUN roundwidget.p (HANDLE).
  ASSIGN SELF:PRIVATE-DATA = STRING(INT(SELF:PRIVATE-DATA) + 1).
END.

/*******************************************
*   roundwidget.p                          *
*   Sturla Johnsen                         *
*******************************************/   
DEFINE INPUT PARAMETER hWidget AS HANDLE.
 
DEFINE VARIABLE hrgn        AS INTEGER NO-UNDO.
DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
IF NOT VALID-HANDLE(hWidget) THEN RETURN ERROR.
 
RUN CreateEllipticRgn (1, /* Start Xpos */
                       1, /* Start Ypos */
                       hWidget:WIDTH-PIXELS,
                       hWidget:HEIGHT-PIXELS, 
                       OUTPUT hrgn).
 
RUN SetWindowRgn(hWidget:HWND, 
                 hrgn, 
                 1, /* 1 = Redraw */
                 OUTPUT ReturnValue).
 
PROCEDURE SetWindowRgn EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER HWND        AS LONG.
  DEFINE INPUT  PARAMETER hRgn        AS LONG.
  DEFINE INPUT  PARAMETER bRedraw     AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.
 
PROCEDURE CreateEllipticRgn EXTERNAL "gdi32.dll" :
  DEFINE INPUT  PARAMETER StartX AS LONG.
  DEFINE INPUT  PARAMETER StartY AS LONG.
  DEFINE INPUT  PARAMETER HEIGHT AS LONG.
  DEFINE INPUT  PARAMETER WIDTH  AS LONG.
  DEFINE RETURN PARAMETER hrgn   AS LONG.
END PROCEDURE.  

notes

CreateEllipticRgn creates a region which is a GDI object. A program should delete all the GDI objects it creates (using procedure DeleteObject). But not this time, because it is passed to SetWindowRgn. From now on this region is owned by the operating system and will eventually be deleted automatically.
There are many more API functions for creating regions with different shapes, like CreatePolygonRgn, CreateRectRgn, CreateRoundRectRgn. You can also create several regions and combine them using CombineRgn to create every shape you can imagine.

Attachments

rounddemo.zip : Example code

Selection-list with item-data

Every widget can have private-data, but it is less commonly known that each list-item in a selection list can have its own private data.
The itemdata for a list-item is of type integer, or actually a DWORD.
Perhaps it is best to think of a selection list as a container of list-items, where each list-item is uniquely identified by a SelIndex. Each list-item contains two data members: the (visible) character string and the itemdata. The itemdata has no meaning to Windows so you can safely use it for storing application-specific information.
Normally I would prefer to use the Progress 9 feature of LIST-ITEM-PAIRS instead of this API solution. But LIST-ITEM-PAIRS are designed to work only if the LIST-ITEMs (e.g. screen-values) are unique!
The following example populates a selection-list widget with each customer.name. When the user chooses a selection-list item, the customer is fetched and its details are displayed. This would normally not be possible because:
* There is no index on customer.name so it would be slow to FIND CUSTOMER WHERE customer.name=screen-value
* There may be several customers with the same name, so the FIND statement may be ambiguous
The solution is to add an identifying value to each list-item. This example stores RECID(customer) in the itemdata. I know RECID is an obsolete function, but I have used it anyway in this example because RECIDs are unique and compatible with Integers.

{windows.i}
PROCEDURE Populate :
 
  DEFINE VARIABLE ReturnValue   AS INTEGER NO-UNDO.
  DEFINE VARIABLE lpString AS MEMPTR.
  DEFINE VARIABLE selindex AS INTEGER NO-UNDO.
 
  FOR EACH customer NO-LOCK :
 
      SET-SIZE(lpString)     = 0.
      SET-SIZE(lpString)     = LENGTH(TRIM(customer.NAME)) + 1.
      PUT-STRING(lpString,1) = TRIM(customer.NAME).
 
      RUN SendMessageA IN hpApi 
                       (select-1:HWND IN FRAME {&frame-name},
                        384, /* LB_ADSTRING */
                        0,
                        GET-POINTER-VALUE(lpString),
                        OUTPUT selIndex).
 
      RUN SendMessageA IN hpApi
                       (select-1:HWND IN FRAME {&frame-name}, 
                        410, /* LB_SETITEMDATA */
                        SelIndex, 
                        INTEGER(RECID(customer)),
                        OUTPUT ReturnValue).
 
  END.
 
  SET-SIZE(lpString)=0.
END PROCEDURE.

The first call to SendMessage adds a text to the selection list, so it does the same as select-1:ADD-LAST(TRIM(customer.name)). However it also returns a SelIndex, which is the unique and constant index number for the new list-item. This SelIndex is used in the second call to SendMessage.
The second call to SendMessage adds an integer data value to the list-item.

{windows.i}
ON VALUE-CHANGED OF SELECT-1 IN FRAME DEFAULT-FRAME
DO:
 
  DEFINE VARIABLE SelIndex    AS INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  RUN SendMessageA (select-1:HWND, 
                    392, /* LB_GETCURSEL */
                    0, 
                    0,
                    OUTPUT SelIndex).
 
  RUN SendMessageA (select-1:HWND, 
                    409, /* LB_GETITEMDATA */
                    SelIndex, 
                    0,
                    OUTPUT ReturnValue).
 
  FIND customer WHERE RECID(customer)=ReturnValue NO-LOCK NO-ERROR.
  IF AVAIL customer THEN DO:
     DISPLAY
             cust-num 
             NAME 
             city 
             country 
             WITH FRAME {&frame-name}.
  END.                    
 
END.

Instead of looking at the screen-value I call SendMessage to get the unique SelIndex, and call SendMessage again to get the value of the item-data connected to that SelIndex. Because this item-data value was actually a RECID, I can now identify the customer and display its details.

Notes

The SelIndex value for a list-item never changes even when list-items are deleted or inserted, whether or not the selection-list is sorted.
Instead of storing an Integer value in Itemdata, you can also store a POINTER-VALUE pointing to some string or structure. However when you do this you will have to implement some kind of destructor.

Statusbar and Progressbar common controls

Source by Todd Nist, Protech Systems Inc.
Modified by Simon Sweetman

The library COMCTL32.DLL contains common controls like the Status Bar control. This example, provided by Todd Nist, shows how to use the Status Bar control in a Progress window. Simon Sweetman added the progressbar. The example will produce a window that looks like this:

The Status Bar in this example is divided in three parts: the first part contains a progressbar which displays the value of the slider, the second part is shown with SBT_POPOUT style so it appears raised.
Button WriteStatusBar results in sending window-messages to the Status Bar control, in this case message SB_SETTEXT. The control also accepts other messages like SB_SETPARTS (to change the size or count of parts), SB_SETICON (to show an icon in a part) or SB_SETTIPTEXT (to set a tooltip for a part). However SB_SETICON and SB_SETTIPTEXT are only available in comctl32.dll version 4.71 or newer.

/*------------------------------------------------------------------------
  File: StatusExample.p
  Author: Todd Nist, Protech Systems Inc.
  Created: 5/19/98
  Modifications:
    28/11/00 Simon Sweetman - Added progress meter control
------------------------------------------------------------------------*/
&SCOP WINDOW-NAME C-Win
&SCOP FRAME-NAME DEFAULT-FRAME
 
CREATE WIDGET-POOL.
 
/* ***************************  Definitions  ************************** */
 
/* Local Variable Definitions ---                                       */
{windows.i}
 
&SCOPE WM_USER         1024
&SCOPE SB_SETPARTS     {&WM_USER} + 4
&SCOPE SB_SETTEXT      {&WM_USER} + 1
&SCOPE SB_GETRECT      {&WM_USER} + 10
&SCOPE PBM_SETRANGE    {&WM_USER} + 1
&SCOPE PBM_SETPOS      {&WM_USER} + 2
&SCOPE SBT_NORMAL      0
&SCOPE SBT_POPOUT      512
&SCOPE SBT_NOBORDERS   256
 
/* variables to hold handle control objects */
 
DEFINE VARIABLE hStatusBar AS  INTEGER NO-UNDO.
DEFINE VARIABLE progHWND   AS  INTEGER NO-UNDO.
 
PROCEDURE CreateStatusWindow EXTERNAL "comctl32.dll":
  DEFINE INPUT  PARAMETER lStyle      AS  LONG.
  DEFINE INPUT  PARAMETER lpctStr     AS  CHARACTER.
  DEFINE INPUT  PARAMETER hwndParent  AS  LONG.
  DEFINE INPUT  PARAMETER wId         AS  LONG.
  DEFINE RETURN PARAMETER hStatusArea AS  LONG.
END PROCEDURE.
 
PROCEDURE InitCommonControls EXTERNAL "comctl32.dll":
END PROCEDURE.
 
/* Standard preprocessor definitions */
&SCOPED-DEFINE PROCEDURE-TYPE WINDOW
&SCOPED-DEFINE ENABLED-OBJECTS BtnCreateStatus BtnWriteStatus SLIDER-1
 
/* ************************  Function Prototypes ********************** */
 
FUNCTION CreateProgressArea RETURNS INTEGER
  ( INPUT phStatusBar  AS INTEGER,
    INPUT piStatusArea AS INTEGER,
    INPUT piMaxValue AS INTEGER) FORWARD.
 
FUNCTION CreateStatusBar RETURNS INTEGER
  ( /* parameter-definitions */ )  FORWARD.
 
FUNCTION SetProgressArea RETURNS LOGICAL
  ( INPUT phProgressArea  AS INTEGER,
    INPUT piValue AS INTEGER ) FORWARD.
 
FUNCTION WriteStatusArea RETURNS LOGICAL
  ( INPUT phStatusBar  AS INTEGER,
    INPUT piStatusArea AS INTEGER,
    INPUT piSBTextMode AS INTEGER,
    INPUT pcText       AS CHARACTER )  FORWARD.
 
/* ***********************  Control Definitions  ********************** */
 
/* Define the widget handle for the window                              */
DEFINE VARIABLE C-Win AS WIDGET-HANDLE NO-UNDO.
 
/* Menu Definitions                                              */
DEFINE SUB-MENU m_File
       MENU-ITEM m_Exit         LABEL "E&xit"         .
 
DEFINE MENU MENU-BAR-C-Win MENUBAR
       SUB-MENU  m_File         LABEL "File"          .
 
 
/* Definitions of the field level widgets                               */
DEFINE BUTTON BtnCreateStatus
     LABEL "Create Status Bar"
     SIZE 25 BY 1.
 
DEFINE BUTTON BtnWriteStatus
     LABEL "WriteStatusBar"
     SIZE 25 BY 1.
 
DEFINE VARIABLE SLIDER-1 AS INTEGER INITIAL 0 
     VIEW-AS SLIDER MIN-VALUE 0 MAX-VALUE 100 HORIZONTAL 
     SIZE 45 BY 2 NO-UNDO. 
 
/* ************************  Frame Definitions  *********************** */
 
DEFINE FRAME {&FRAME-NAME}
     SLIDER-1 AT ROW 1 COL 7 NO-LABEL
     BtnCreateStatus AT ROW 6 COL 6
     BtnWriteStatus AT ROW 6 COL 50
    WITH 1 DOWN NO-BOX KEEP-TAB-ORDER OVERLAY
         SIDE-LABELS NO-UNDERLINE THREE-D
         AT COL 1 ROW 1
         SIZE 80 BY 8.
 
 
/* *************************  Create Window  ************************** */
 
IF SESSION:DISPLAY-TYPE = "GUI":U THEN
  CREATE WINDOW C-Win ASSIGN
         HIDDEN             = YES
         TITLE              = "StatusBar Example"
         HEIGHT             = 8
         WIDTH              = 80
         MAX-HEIGHT         = 8
         MAX-WIDTH          = 80
         VIRTUAL-HEIGHT     = 8
         VIRTUAL-WIDTH      = 80
         RESIZE             = YES
         SCROLL-BARS        = NO
         STATUS-AREA        = NO
         BGCOLOR            = ?
         FGCOLOR            = ?
         KEEP-FRAME-Z-ORDER = YES
         THREE-D            = YES
         MESSAGE-AREA       = NO
         SENSITIVE          = YES.
ELSE {&WINDOW-NAME} = CURRENT-WINDOW.
 
ASSIGN {&WINDOW-NAME}:MENUBAR    = MENU MENU-BAR-C-Win:HANDLE.
 
/* ***************  Runtime Attributes and UIB Settings  ************** */
 
IF SESSION:DISPLAY-TYPE = "GUI":U AND VALID-HANDLE(C-Win)
THEN C-Win:HIDDEN = NO.
 
/* ************************  Control Triggers  ************************ */
 
ON END-ERROR OF C-Win /*  */
OR ENDKEY OF {&WINDOW-NAME} ANYWHERE DO:
  /* This case occurs when the user presses the "Esc" key.
     In a persistently run window, just ignore this.  If we did not, the
     application would exit. */
  IF THIS-PROCEDURE:PERSISTENT THEN RETURN NO-APPLY.
END.
 
ON WINDOW-CLOSE OF C-Win /*  */
DO:
  /* This event will close the window and terminate the procedure.  */
  APPLY "CLOSE":U TO THIS-PROCEDURE.
  RETURN NO-APPLY.
END.
 
ON VALUE-CHANGED OF SLIDER-1 IN FRAME {&FRAME-NAME} /* Create Status Bar */
DO:
  IF ProgHWND NE 0
  THEN SetProgressArea(progHWND, INT(SELF:SCREEN-VALUE) * 10).
END.
 
ON CHOOSE OF BtnCreateStatus IN FRAME {&FRAME-NAME} /* Create Status Bar */
DO:
  hStatusBar = CreateStatusBar().
END.
 
ON CHOOSE OF BtnWriteStatus IN FRAME {&FRAME-NAME} /* WriteStatusBar */
DO:
  DEFINE VARIABLE i AS i NO-UNDO.
 
  DO i = 1 TO 2.
    WriteStatusArea(hStatusBar,
                    i,
                    IF i = 1 THEN {&SBT_POPOUT} ELSE {&SBT_NORMAL},
                    SUBSTITUTE('Message &1 here...', STRING(i,'9'))).
  END.
  progHWND = CreateProgressArea(hStatusBar, 0, 1000).
 
END.
 
ON CHOOSE OF MENU-ITEM m_Exit /* Exit */
DO:
  APPLY 'WINDOW-CLOSE':U TO {&WINDOW-NAME}.
END.
 
/* ***************************  Main Block  *************************** */
 
ASSIGN CURRENT-WINDOW                = {&WINDOW-NAME}
       THIS-PROCEDURE:CURRENT-WINDOW = {&WINDOW-NAME}.
 
ON CLOSE OF THIS-PROCEDURE
   RUN disable_UI.
 
PAUSE 0 BEFORE-HIDE.
 
MAIN-BLOCK:
DO ON ERROR   UNDO MAIN-BLOCK, LEAVE MAIN-BLOCK
   ON END-KEY UNDO MAIN-BLOCK, LEAVE MAIN-BLOCK:
  {win32/struct/rect.i} /* Used by CreateProgressArea function */
  RUN enable_UI.
  IF NOT THIS-PROCEDURE:PERSISTENT THEN
    WAIT-FOR CLOSE OF THIS-PROCEDURE.
END.
 
/* **********************  Internal Procedures  *********************** */
 
PROCEDURE disable_UI :
/*-----------------------------------------------------------------------------
  Purpose:     DISABLE the User Interface
  Parameters:  
  Notes:       Here we clean-up the user-interface by deleting
               dynamic widgets we have created and/or hide
               frames.  This procedure is usually called when
               we are ready to "clean-up" after running.
------------------------------------------------------------------------------*/
  /* Delete the WINDOW we created */
  IF SESSION:DISPLAY-TYPE = "GUI":U AND VALID-HANDLE(C-Win)
  THEN DELETE WIDGET C-Win.
  IF THIS-PROCEDURE:PERSISTENT THEN DELETE PROCEDURE THIS-PROCEDURE.
END PROCEDURE.
 
PROCEDURE enable_UI :
/*------------------------------------------------------------------------------
  Purpose:     ENABLE the User Interface
  Parameters:  none
  Notes:       Here we display/view/enable the widgets in the
               user-interface.  In addition, OPEN all queries
               associated with each FRAME and BROWSE.
               These statements here are based on the "Other
               Settings" section of the widget Property Sheets.
------------------------------------------------------------------------------*/
  ENABLE BtnCreateStatus BtnWriteStatus SLIDER-1
      WITH FRAME {&FRAME-NAME} IN WINDOW C-Win.
  {&OPEN-BROWSERS-IN-QUERY-{&FRAME-NAME}}
  VIEW C-Win.
END PROCEDURE.
 
FUNCTION CreateProgressArea RETURNS INTEGER
  (INPUT phStatusBar  AS INTEGER,
   INPUT piStatusArea AS INTEGER,
   INPUT piMaxValue   AS INTEGER):
/*------------------------------------------------------------------------------
  Purpose: Create status bar progress meter control
    Notes: Return value is window handle of control
------------------------------------------------------------------------------*/
 
  DEFINE VARIABLE hwndParent    AS  INTEGER NO-UNDO.
  DEFINE VARIABLE hInstance     AS  INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnValue   AS  INTEGER NO-UNDO.
  DEFINE VARIABLE ReturnHwnd    AS  INTEGER NO-UNDO.
 
  SET-SIZE(lpRect) = 16. /* allocate space for rect object */
 
  /* Get screen postion of required status bar area */
  RUN SendMessageA IN hpApi(INPUT  phStatusBar,
                            INPUT  {&SB_GETRECT},
                            INPUT  piStatusArea,
                            INPUT  GET-POINTER-VALUE(lpRect),
                            OUTPUT ReturnValue).
  RUN mem2buf_lpRect.
 
  SET-SIZE(lpRect) = 0. /* release allocated space */
 
  RUN GetParent IN hpApi({&WINDOW-NAME}:HWND,
                         OUTPUT hwndParent).
 
  RUN GetWindowLongA IN hpApi(hwndParent,
                              -6,  /* GWL_HINSTANCE */
                              OUTPUT hInstance).
 
  /* Create the progress meter window control and parent it to status window */
  RUN CreateWindowExA IN hpApi(
    8,                              /* extended style */
    "msctls_progress32":U,          /* progress meter class name */
    "",                              /* window name */
    1073741824   /* = WS_CHILD   */
    + 1          /* = PBS_SMOOTH */
    + 268435456, /* = WS_VISIBLE */   /* window styles */
    lpRect.LEFT,
    lpRect.TOP,
    lpRect.RIGHT - lpRect.LEFT, 
    lpRect.BOTTOM - lpRect.TOP,     /* window position & size */
    phStatusBar,                    /* parent window */
    0,                              /* menu pointer */
    hInstance,                      /* instance */
    0,                              /* parameters */
    OUTPUT ReturnHwnd).
 
  /* set maximum value of progress meter control */
  RUN SendMessageA IN hpApi(INPUT  ReturnHwnd,
                            INPUT  {&PBM_SETRANGE},
                            INPUT  0,
                            INPUT  piMaxValue * 65536,
                            OUTPUT ReturnValue).
  RETURN ReturnHwnd.
 
END FUNCTION.
 
FUNCTION CreateStatusBar RETURNS INTEGER
  ( /* parameter-definitions */ ) :
/*------------------------------------------------------------------------------
  Purpose:
    Notes:
------------------------------------------------------------------------------*/
  DEFINE VARIABLE hwndMenu      AS  INTEGER NO-UNDO.
  DEFINE VARIABLE hwndParent    AS  INTEGER NO-UNDO.
  DEFINE VARIABLE hInstance     AS  INTEGER NO-UNDO.
  DEFINE VARIABLE hWindowMenu   AS  INTEGER NO-UNDO.
  DEFINE VARIABLE hStatusArea   AS  INTEGER NO-UNDO.
  DEFINE VARIABLE lpParam       AS  MEMPTR  NO-UNDO.
  DEFINE VARIABLE ReturnValue   AS  INTEGER NO-UNDO.
 
  /*---------------------------------------------------------------------
    Allocate memory and define the array to support the segments of the
    status area.
  -----------------------------------------------------------------------*/
  ASSIGN
    SET-SIZE(lpParam)    = 256
    PUT-LONG(lpParam,1)  = 120
    PUT-BYTE(lpParam,5)  = 240
    PUT-LONG(lpParam,9)  = -1.  /* extend to the right edge of the window */
 
  /* find handle to the Parent handle of the Window */
  RUN GetParent IN hpApi({&WINDOW-NAME}:HWND,
                         OUTPUT hwndParent).
 
  RUN GetWindowLongA IN hpApi(hwndParent,
                              -6,  /* GWL_HINSTANCE */
                              OUTPUT hInstance).
 
 
  /* Call InitCommonControls to ensure that the comctl32.dll is loaded */
  RUN InitCommonControls.
 /* hwndParent */
 
  /* Create the status window control and parent it to the window */
  RUN CreateStatusWindow
    (   1073741824 /* = WS_CHILD         */
      + 268435456  /* = WS_VISIBLE       */  /* window styles */
      + 8388608,   /* = WS_BORDER        */
     '',                                         /* default text */
     hwndParent,                                 /* parent window */
     101,                                        /* ID_STATUS */
     OUTPUT hStatusArea).
 
  IF hStatusArea = 0 THEN
    MESSAGE 'Unable to create the status bar...' VIEW-AS ALERT-BOX.
  ELSE
    /* create the multiple segments based on the data in lpParam */
    RUN SendMessageA IN hpApi( INPUT  hStatusArea,
                               INPUT  {&SB_SETPARTS},
                               INPUT  3,         /* number of parts */
                               INPUT GET-POINTER-VALUE(lpParam),
                               OUTPUT ReturnValue).
 
  /* deallocate the memory */
  ASSIGN
    SET-SIZE(lpParam)  = 0.
 
  RETURN hStatusArea.   /* Function return value. */
 
END FUNCTION.
 
FUNCTION SetProgressArea RETURNS LOGICAL
  ( INPUT phProgressArea  AS INTEGER,
    INPUT piValue AS INTEGER ) :
/*------------------------------------------------------------------------------
  Purpose:  Update progress indicator value and redisplay
    Notes:
------------------------------------------------------------------------------*/
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  RUN SendMessageA IN hpApi(INPUT  phProgressArea,
                            INPUT  {&PBM_SETPOS},
                            INPUT  piValue,
                            INPUT  0,
                            OUTPUT ReturnValue).
  RETURN TRUE.
 
END FUNCTION.
 
FUNCTION WriteStatusArea RETURNS LOGICAL
  ( INPUT phStatusBar  AS INTEGER,
    INPUT piStatusArea AS INTEGER,
    INPUT piSBTextMode AS INTEGER,
    INPUT pcText       AS CHARACTER ) :
/*------------------------------------------------------------------------------
  Purpose:  Write the text in the appropriat format to the appropriate area
    Notes:
------------------------------------------------------------------------------*/
  DEFINE VARIABLE lpParam     AS MEMPTR  NO-UNDO.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  ASSIGN
    SET-SIZE(lpParam)     = 256
    PUT-STRING(lpParam,1) = pcText.
 
  RUN SendMessageA IN hpApi(INPUT  phStatusBar,
                            INPUT  {&SB_SETTEXT},
                            INPUT  piStatusArea + piSBTextMode,
                            INPUT  GET-POINTER-VALUE(lpParam),
                            OUTPUT ReturnValue).
 
  /* deallocate the memory */
  ASSIGN
    SET-SIZE(lpParam)  = 0.
 
  RETURN TRUE.
 
END FUNCTION.

Explanations

message SB_SETTEXT has the following parameters:
* wParam = iPart + uType
* lParam = text. The text for each part is limited to 127 characters.
* iPart is the index of the part to set. If iPart=255 you will get a 'simple' status bar with only one part.

uType can be:
* {&SBT_NORMAL} : border, appears lower
* {&SBT_NOBORDERS} : no border, no 3D effect
* {&SBT_POPOUT} : border, appears higher

Note

The Status Bar has a sizing grip because it is parented to the resizable window. It will not have a sizing grip when you parent it to the frame :

/* Create the status window control and parent it to the frame */
  RUN CreateStatusWindow
    (   1073741824   /* = WS_CHILD           */
      +  268435456   /* = WS_VISIBLE         */  /* window styles */
      +    8388608,  /* = WS_BORDER          */
     '',                                         /* default text */
     FRAME {&frame-name}:HWND,                   /* parent       */
     101,                                        /* ID_STATUS    */
     OUTPUT hStatusArea).

This also solves the repaint problem: if the status bar is parented to the window, it will appear to be invisible after the window is repainted.

Note

There's another way to solve the repaint problem, and to keep the StatusBar parented to the window (and therefore keep the "sizing grip").
Simply run:

   RUN SendMessageA IN hpApi(INPUT  phStatusBar,
                             INPUT  5, /* WM_SIZE */
                             INPUT  0,
                             INPUT  0,
                             OUTPUT ReturnValue).

For instance, at the end of a WINDOW-RESIZED event (or after a "ShowScrollBar")

System colors

The functions GetSysColor and SetSysColors can be used to access the system colors.
This is for example useful for displaying text in disabled native fill-in widgets.
Text in a disabled native fill-in is rendered in the system-color COLOR_GRAYTEXT, which is gray. The background color of a disabled fill-in is also gray (but not COLOR_GRAYTEXT) so it is difficult to read the text.
To make the text more readable you may want to change the RGB-value of the COLOR_GRAYTEXT system color.
There are several ways to change COLOR_GRAYTEXT:
You can set or modify the registry key

    "HKEY_CURRENT_USER\Control Panel\Colors\GrayText"

but that will only take effect after you reboot the system.
You can also consider using the SetSysColors function to modify the RGB-value of COLOR_GRAYTEXT. The advantage is that it will take effect immediately, no need to reboot the system.
The disadvantage is that it won't be written to registry so the original value is reset after reboot. Well, actually I think this is another advantage.
What I would try to do is:
on startup of the Progress session: read the current value of COLOR_GRAYTEXT
if COLOR_GRAYTEXT is not acceptable set it to something you prefer.
on close of the Progress session: restore the original value to respect other applications.
After you call SetSysColors, Windows sends a notification message to all open windows so they can repaint themselves. This takes a little time.
Read COLOR_GRAYTEXT

{windows.i}
  DEFINE VARIABLE rgbGrayText AS INTEGER NO-UNDO.
  RUN GetSysColor IN hpApi (17, /* = COLOR_GRAYTEXT */
                            OUTPUT rgbGrayText).

set COLOR_GRAYTEXT

{windows.i}
 
  DEFINE VARIABLE lpElements  AS MEMPTR.
  DEFINE VARIABLE lpRgb       AS MEMPTR.
  DEFINE VARIABLE ReturnValue AS INTEGER NO-UNDO.
 
  SET-SIZE(lpElements)   = 4.   /* = sizeof(long)   */
  SET-SIZE(lpRgb)        = 4.
  PUT-LONG(lpElements,1) = 17.  /* = COLOR_GRAYTEXT */
  PUT-LONG(lpRgb,1)      = RGB-VALUE(192,192,192).
 
  RUN SetSysColors IN hpApi (1,          /* = number of elements */
                             GET-POINTER-VALUE(lpElements),
                             GET-POINTER-VALUE(lpRgb),
                             OUTPUT ReturnValue).
 
  SET-SIZE(lpElements) = 0.
  SET-SIZE(lpRgb)      = 0.

Notes

Credits to Julian Lyndon Smith who discovered the value 192,192,192. Although it is the RGB-value for a shade of gray, it will render the text in disabled native fill-in widgets black but still does little harm to other screen-elements that are coloured in COLOR_GRAYTEXT.

Notes

(May 1999).
It now appears that setting GrayText to RGB(192,192,192) makes disabled SELECTION-LIST widgets really hard to read. Don't know why it was not noticed before... perhaps it depends on Windows 98, video card or other display settings? Anyway, GrayText=RGB(192,192,192) does not seem to be a good idea anymore.

Notes

KeithGernert 19 Jan 2004: We've found that an RGB setting of 80,80,80 looks pretty good and is less destructive to other Windows controls.

Toggle-box with labels on the left

A standard toggle-box widget has its label on the right. This example applies the BS_LEFTTEXT style to bring the label to the left.

As you can see in the picture, the checkboxes are not vertically aligned anymore. Tex Texin wrote a
procedure to fix this: see http:www.xencraft.com/resources/rightside-checkbox.html

   
RUN ToggleLeftText (toggle-1:HWND).
RUN ToggleLeftText (toggle-2:HWND).

    
PROCEDURE ToggleLeftText :
/* -------------------------------------------------------------
   purpose: place the label on the left side.
   do not run this procedure more than once for each toggle-box 
   ------------------------------------------------------------- */
 
  DEFINE INPUT PARAMETER HWND AS INTEGER.
 
  DEFINE VARIABLE styles      AS INTEGER NO-UNDO.
  DEFINE VARIABLE returnvalue AS INTEGER NO-UNDO.
 
  RUN GetWindowLongA(HWND, {&GWL_STYLE}, OUTPUT styles).
  styles = styles + {&BS_LEFTTEXT}.
  RUN SetWindowLongA(HWND, {&GWL_STYLE}, styles, OUTPUT styles).
 
  /* force a repaint */
  RUN InvalidateRect(HWND,0,1,OUTPUT returnvalue).
 
END PROCEDURE.

Definitions used in this example:

&GLOBAL-DEFINE GWL_STYLE -16
&GLOBAL-DEFINE BS_LEFTTEXT 32
 
 
PROCEDURE GetWindowLongA EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER phwnd       AS LONG.
  DEFINE INPUT  PARAMETER cindex      AS LONG.
  DEFINE RETURN PARAMETER currentlong AS LONG.
END PROCEDURE.
 
PROCEDURE SetWindowLongA EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER phwnd   AS LONG.
  DEFINE INPUT  PARAMETER cindex  AS LONG.
  DEFINE INPUT  PARAMETER newlong AS LONG.
  DEFINE RETURN PARAMETER oldlong AS LONG.
END PROCEDURE.
 
PROCEDURE InvalidateRect EXTERNAL "user32.dll" :
  DEFINE INPUT  PARAMETER HWND        AS LONG.
  DEFINE INPUT  PARAMETER lpRect      AS LONG.
  DEFINE INPUT  PARAMETER bErase      AS LONG.
  DEFINE RETURN PARAMETER ReturnValue AS LONG.
END PROCEDURE.