In-Memory Dialogs

ejc.cryptography · Post by **ejc.cryptography** » Jun 05, 2008 21:51

Can the example in the first post showing menu usage with keyboard accelerators be done using a modal window instead of a modeless one? I tried changing it in the sampe code but, although it worked, a compiler warning was given:

Suspicious pointer assignment

for the line...

hDlg = CreateModalDialog( 0, @DialogProc, 0, lpdt )

where I have switched Modal for Modeless. What do I need to change to get rid of this warning?

The altered code: (all that is different is the Modal vs Modeless part)

Code: Select all

'====================================================================
'' Menu demo, fully programmed (no menu resource) with keyboard
'' accelerators, modeless dialog as main.
''
'' Keyboard accelerators are easier to implement in a modeless
'' dialog because you have direct access to the message loop.
'====================================================================

#include "dialogs.bas"

'' For 0.15b through 0.17b July 30, 2006, uncomment the following
'' option escape and remove the "!" prefix on the AppendMenu string
'' arguments.

'option escape

'====================================================================

Dim Shared As HACCEL g_hAccel

'====================================================================

'' The ACCEL structure, as defined in the 0.16b winuser.bi, is
'' padded to a length of 8 bytes, instead of the 6 bytes that
'' the API expects. This definition corrects the problem, so
'' in an array elements beyond the first will work correctly.
''
Type _ACCEL Field = 2
    fVirt As Byte
    Key As WORD
    cmd As WORD
End Type

'====================================================================

Function InitMenu() As HMENU

  Dim As HMENU hMenu, hFileMenu
  Dim As _ACCEL accl( 0 To 2)

  hMenu = CreateMenu
  hFileMenu = CreateMenu

  AppendMenu( hMenu, MF_POPUP, cast(UINT_PTR,hFileMenu), "&File" )
  AppendMenu( hFileMenu, MF_STRING, 1000, !"&New\tCtrl+N" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, 1001, !"&Open\tCtrl+O" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, 1002, !"&Save\tCtrl+S" )
  AppendMenu( hFileMenu, MF_STRING, 1003, !"Save &As" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, 1004, !"E&xit\tAlt+F4" )

  accl(0).fVirt = FCONTROL Or FVIRTKEY
  accl(0).key = Asc("N")
  accl(0).cmd = 1000
  accl(1).fVirt = FCONTROL Or FVIRTKEY
  accl(1).key = Asc("O")
  accl(1).cmd = 1001
  accl(2).fVirt = FCONTROL Or FVIRTKEY
  accl(2).key = Asc("S")
  accl(2).cmd = 1002

  g_hAccel = CreateAcceleratorTable( cast(LPACCEL,@accl(0)), 3 )

  Return hMenu

End Function

'====================================================================

Function DialogProc( Byval hDlg As  HWND, _
                     Byval uMsg As UINT, _
                     Byval wParam As WPARAM, _
                     Byval lParam As LPARAM ) As Integer

  Select Case uMsg

    Case WM_INITDIALOG

      SetMenu( hDlg, InitMenu() )

      Return true

    Case WM_COMMAND

      Select Case loword(wParam)
        Case 1000
          MessageBox( hDlg, "New", "", 0 )
        Case 1001
          MessageBox( hDlg, "Open", "", 0 )
        Case 1002
          MessageBox( hDlg, "Save", "", 0 )
        Case 1003
          MessageBox( hDlg, "Save As", "", 0 )
        Case 1004
          DestroyWindow( hDlg )
      End Select

    Case WM_CLOSE

      DestroyWindow( hDlg )

    Case WM_DESTROY

      DestroyAcceleratorTable( g_hAccel )
      PostQuitMessage( null )

  End Select

  Return 0

End Function

'====================================================================

Dim As LPDLGTEMPLATE lpdt
Dim As HWND hDlg
Dim As MSG wMsg

Dialog( 1, 0, 0, 150, 100, "Menu Demo", lpdt, _
        WS_OVERLAPPEDWINDOW Or DS_CENTER Or WS_VISIBLE )

'' The dialog must have at least one control or the menu
'' will not activate correctly with Alt + access key.
''
LText( 100, 0, 0, 0, 0, "" )

hDlg = CreateModalDialog( 0, @DialogProc, 0, lpdt )

Do While GetMessage( @wMsg, null, 0, 0 ) <> 0
  If TranslateAccelerator( hDlg, g_hAccel, @wMsg ) = 0 Then
    If IsDialogMessage( hDlg,  @wMsg ) = 0 Then
      TranslateMessage( @wMsg )
      DispatchMessage( @wMsg )
    End If
  End If
Loop

'====================================================================

MichaelW · Post by **MichaelW** » Jun 06, 2008 0:49

For a modal dialog the system provides the message loop, and the function that creates the dialog will not return until the dialog is destroyed. So for a modal dialog you cannot use TranslateAccelerator or otherwise process the accelerators directly in the message loop. I would guess that processing the accelerators from the dialog window procedure would be difficult or impossible. One method that I think should work for a modal dialog would be to install a WH_MSGFILTER hook and process the accelerators from the MessageProc callback. In the callback you would basically call GetAsyncKeyState(VK_CONTROL) to determine if the control key was down, and check the virtual key code in msg.wParam. If you determined that one of your accelerator keys had been pressed, you could then pass an appropriate message to the dialog window procedure. I have no time to code an example ATM, but I might in the next 6 hours or so.

As it turns out I already had an example that I just needed to clean up a bit.

Code: Select all

'====================================================================
'' Menu demo, fully programmed (no menu resource) with keyboard
'' accelerators, modal dialog as main.
''
'' To avoid the problems with using keyboard accelerators in a
'' modal dialog, where you do not have access to the message
'' loop, this code installs a WH_MSGFILTER hook and handles the
'' accelerators from the callback.
'====================================================================

#include "dialogs.bas"

'====================================================================

dim shared as HHOOK g_hHook
dim shared as HWND g_hDlg

'====================================================================

function InitMenu() as HMENU

  dim as HMENU hMenu, hFileMenu

  hMenu = CreateMenu
  hFileMenu = CreateMenu

  AppendMenu( hMenu, MF_POPUP, cast(UINT_PTR,hFileMenu), "&File" )
  AppendMenu( hFileMenu, MF_STRING, 1000, !"&New\tCtrl+N" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, 1001, !"&Open\tCtrl+O" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, 1002, !"&Save\tCtrl+S" )
  AppendMenu( hFileMenu, MF_STRING, 1003, !"Save &As" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, 1004, !"E&xit\tAlt+F4" )

  return hMenu

end function

'====================================================================

function MessageProc( byval code as integer, _
                      byval wParam as WPARAM, _
                      byval lParam as LPARAM ) as integer

  if code = MSGF_DIALOGBOX then
    if cast(PMSG,lParam)->message = WM_KEYDOWN then
      if GetAsyncKeyState( VK_CONTROL ) and &h8000 then
        select case cast(PMSG,lParam)->wParam
          case asc("N")
            SendMessage( g_hDlg, WM_COMMAND, 1000, 0 )
          case asc("O")
            SendMessage( g_hDlg, WM_COMMAND, 1001, 0 )
          case asc("S")
            SendMessage( g_hDlg, WM_COMMAND, 1002, 0 )
        end select
     end if
    end if
  end if

  return CallNextHookEx( g_hHook, code, wParam, lParam )

end function

'====================================================================

function DialogProc( byval hDlg as  HWND, _
                     byval uMsg as UINT, _
                     byval wParam as WPARAM, _
                     byval lParam as LPARAM ) as integer

  select case uMsg

    case WM_INITDIALOG

      SetMenu( hDlg, InitMenu )

      g_hHook = SetWindowsHookEx( WH_MSGFILTER, @MessageProc, _
                                  0, GetCurrentThreadId() )
      g_hDlg = hDlg

    case WM_COMMAND

      select case loword(wParam)
        case 1000
          MessageBox( hDlg, "New", "", 0 )
        case 1001
          MessageBox( hDlg, "Open", "", 0 )
        case 1002
          MessageBox( hDlg, "Save", "", 0 )
        case 1003
          MessageBox( hDlg, "Save As", "", 0 )
        case 1004
          UnhookWindowsHookEx( g_hHook )
          EndDialog( hDlg, null )
      end select

    case WM_CLOSE

      UnhookWindowsHookEx( g_hHook )
      EndDialog( hDlg, null )

  end select

  return 0

end function

'====================================================================

dim as LPDLGTEMPLATE lpdt

Dialog( 1, 0, 0, 120, 90, "Menu In Modal Dialog Demo", lpdt, _
        WS_OVERLAPPEDWINDOW or DS_CENTER )

'' The dialog must have at least one control or the menu
'' will not activate correctly with Alt + access key.

LText( 100, 0, 0, 0, 0, "" )

CreateModalDialog( 0, @DialogProc, 0, lpdt )

'====================================================================

livewire · Post by **livewire** » Oct 07, 2008 23:41

Can you give an example of a custom control which does not subclass a windows control?

MichaelW · Post by **MichaelW** » Oct 11, 2008 19:29

Code: Select all

'=====================================================================
'' Screem "melt" demo, modeless dialog as main.
''
'' Use the Escape key to restore the screen and exit the program.
'' If this should fail for some reason, then do a Ctrl-Alt-Delete
'' and use Task Manager to end the program process.
'=====================================================================

#include "dialogs.bas"
#include once "win/mmsystem.bi"

'=====================================================================

function DialogProc( byval hDlg as  HWND, _
                     byval uMsg as UINT, _
                     byval wParam as WPARAM, _
                     byval lParam as LPARAM ) as integer
  select case uMsg

    case WM_CLOSE

      DestroyWindow( hDlg )

    case WM_DESTROY

      PostQuitMessage( null )

  end select

  return 0

end function

'=====================================================================

dim as LPDLGTEMPLATE lpdt
dim as HWND hDlg
dim as MSG wMsg
dim as HDC hDC
dim as integer screen_w, screen_h
dim as integer w, h, x, y, y1

hDC = GetDC( 0 )
screen_w = GetSystemMetrics( SM_CXSCREEN )
screen_h = GetSystemMetrics( SM_CYSCREEN )

Dialog( 0, 0, 0, 0, 0, "", lpdt, WS_POPUP or WS_VISIBLE )

hDlg = CreateModelessDialog( 0, @DialogProc, 0, lpdt )

for y as integer = 0 to 2
  for x as integer = 0 to screen_w
    SetPixel( hDC, x, y, 0 )
  next
  sleep 100
next

do

  if PeekMessage( @wMsg, 0, 0, 0, PM_REMOVE ) then

    TranslateMessage( @wMsg )
    DispatchMessage( @wMsg )

  else

    if GetAsyncKeyState(VK_ESCAPE) then
      DestroyWindow( hDlg )
      InvalidateRect( 0, 0, FALSE )
      exit do
    end if

    '--------------------------------------------------------
    '' This code essentially selects random gtoups of pixels
    '' and shifts them down by one pixel pitch.
    '--------------------------------------------------------

    w = (rnd * (screen_w - 3) / 3) + 1
    h = (rnd * (screen_h - 3)) - 100
    x = (rnd * (screen_w - w - 1)) + 1
    y = (rnd * (screen_h - h)) + 2

    BitBlt( hDC,x,y,w,h,hDC,x,y-1,SRCCOPY )

    '----------------------------------------------------------------
    '' Without a sleep 1 statement the Escape key cannot be detected
    '' reliably, and without setting the minimum timer resolution to
    '' 1 ms, instead of the default 10 ms, the message loop will run
    '' too slow.
    '----------------------------------------------------------------

    timeBeginPeriod( 1 ) ' set minimum resolution to 1 ms
    sleep 1
    timeEndPeriod( 1 )   ' restore to default

  end if

loop

'=====================================================================

Edit: Corrected a problem that I introduced with a last-minute change. For the window to detect keystrokes it must include the WS_VISIBLE style.

Edit2: Corrected another problem. Now the melt speed should be essentially independent of the system performance.

livewire · Post by **livewire** » Oct 12, 2008 0:58

Nevermind my question about a custom control. I have received the information.

aleofjax · Post by **aleofjax** » Oct 23, 2008 9:16

I'm trying to get my main window (modeless dialog) to use a bitmap image for its background. I added the following to the message handler:

Code: Select all

Case WM_ERASEBKGND:
        dim As PAINTSTRUCT ps
        dim As HDC hdc = BeginPaint(hDlg, @ps)
        dim As HDC hmemdc = CreateCompatibleDC(hdc)
        dim As HBITMAP hbg = LoadBitmap(GetModuleHandle(NULL), "test.bmp")
        dim As HBITMAP holdbmp = Cast(HBITMAP, SelectObject(hmemdc, hbg))
        dim As BITMAP bmpinfo

        GetObject(hbg, sizeof(bmpinfo), @bmpinfo)
    
        BitBlt(hdc, 0, 0, bmpinfo.bmWidth, bmpinfo.bmHeight, hmemdc, 0, 0, SRCCOPY)
    
        SelectObject(hmemdc, holdbmp)
    
        DeleteObject(hbg)
    
        DeleteDC(hmemdc)
        EndPaint(hDlg, @ps)
        return 1

Any Idea what I'm doing wrong? The window refuses to draw at all, as if I had returned 1 without doing anything else!

BTW, excellent work on this project, I'm very impressed!

MichaelW · Post by **MichaelW** » Oct 23, 2008 11:13

I didn’t have enough time to find and correct the problem in your code. So I used a different, and easier, method and still didn’t have time to take care of all the details and comment it properly.

Code: Select all

'====================================================================
'' Bitmap background demo, modal dialog as main.
''
'' This source sizes the dialog client area to fit the bitmap.
'' Note that the Dialog Template Unit (DTU) to pixel conversions
'' are necessary so the size of the client area and the position
'' of the button will not vary with the font used (assuming the
'' dialog uses the system font).
'====================================================================

#include "dialogs.bas"

'====================================================================

'-----------------------------------------------
'' These functions convert from pixels to DTUs,
'' using the method specified in the API.
'-----------------------------------------------

function PixelToDtuX( byval pixelX as integer ) as integer
  return MulDiv( pixelX, 4, loword(GetDialogBaseUnits) )
end function

function PixelToDtuY( byval pixelY as integer ) as integer
  return MulDiv( pixelY, 8, hiword(GetDialogBaseUnits) )
end function

'====================================================================

function DialogProc( byval hDlg as  HWND, _
                     byval uMsg as UINT, _
                     byval wParam as WPARAM, _
                     byval lParam as LPARAM ) as integer

  static as HBITMAP hbmp
  static as HBRUSH hbrush

  select case uMsg

    case WM_INITDIALOG

      hbmp = LoadImage( null, "fblogo.bmp", IMAGE_BITMAP, _
                        0, 0, LR_LOADFROMFILE )

      hbrush = CreatePatternBrush( hbmp )

    case WM_CTLCOLORDLG

      return cast(integer,hbrush)

    case WM_COMMAND

      if hiword(wParam) = BN_CLICKED then
        DeleteObject( hbmp )
        DeleteObject( hbrush )
        EndDialog( hDlg, null )
      end if

    case WM_CLOSE

      DeleteObject( hbmp )
      DeleteObject( hbrush )
      EndDialog( hDlg, null )

  end select

  return 0

end function

'====================================================================

dim as LPDLGTEMPLATE lpdt

'----------------------------------------------------
'' The Pixel to DTU conversions will get the size of
'' the client area close to the size of the bitmap.
'----------------------------------------------------

Dialog( 1, 0, 0, PixelToDtuX(320), _
        PixelToDtuX(240 + GetSystemMetrics( SM_CYCAPTION ) + 5), _
        "Test", lpdt, WS_OVERLAPPED or WS_SYSMENU or DS_CENTER )

PushButton( 101, -1, PixelToDtuY(145), 30, 10, "OK", WS_TABSTOP )

CreateModalDialog( 0, @DialogProc, 0, lpdt )

'====================================================================

aleofjax · Post by **aleofjax** » Oct 23, 2008 17:22

Well, that's pretty simple. Thanks! I didn't know about WM_CTLCOLORDLG

aleofjax · Post by **aleofjax** » Oct 25, 2008 10:55

Alright, I have another question. And yes, I have searched everywhere for the answer.

I'm trying to set up a tab control on a child dialog. I have a modeless dialog as main, and three children (also modeless), and they work fine, except that the titlebar stays dim even when active, but that's another problem...

Everything I've found on using a tab control requires a resource ID for each dialog that will act as a "page" on the tab control. Where do I get this ID? I thought perhaps it was the ctid member, but your comments say that this must equal the number of controls that you have in the dialog. I also considered the HWND for the dialog, but that seems like a wild desperate guess to me. Yes, I'm still very new to memory dialogs, but I'd still rather learn this method than use a resource editor.

If my questions here are a nuicance, then I will gladly accept a referral to a website that will show me all this stuff that I should probably already know! Thanks again!

MichaelW · Post by **MichaelW** » Oct 25, 2008 11:40

On simple method would be to create your tab dialogs in your WM_INITDIALOG handler for the main dialog, setting the WS_CHILD style for all and the WS_VISIBLE style for the first, and save the handles. Then in your TCN_SELCHANGING handler hide the current tab dialog, and in your TCN_SELCHANGE handler make the new tab dialog visible. If all of the dialogs are running in the same thread then they will need to share a single message loop. Antoni posted an example somewhere in this thread.

MichaelW · Post by **MichaelW** » Nov 10, 2008 8:10

This is a window capture demo converted from a MASM source that I created a while back. While I did thoroughly test the MASM version, this version has seen only a minimal amount of testing, and there is no significant amount of error checking.

crosshair0.bas:

Code: Select all

'======================================================================
'' Simple crosshair cursor mask definitions, 32x32 only, hot spot at
'' 15, 15.
''
'' The system will AND the screen pixel bits with the AND mask and
'' XOR the result with the XOR mask. In truth table form:
''
'' AND mask  XOR mask  resulting screen bit
'' --------  --------  --------------------
''    0         0              0
''    0         1              1
''    1         0           unchanged
''    1         1           inverted
''
'' These masks will leave the cursor background unchanged and invert
'' the foreground.
'======================================================================

dim shared as ubyte cursorAndMask(0 to 4*32-1) = { _
      &b11111111,&b11111111,&b11111111,&b11111111, _  '0
      &b11111111,&b11111111,&b11111111,&b11111111, _  '1
      &b11111111,&b11111111,&b11111111,&b11111111, _  '2
      &b11111111,&b11111111,&b11111111,&b11111111, _  '3
      &b11111111,&b11111111,&b11111111,&b11111111, _  '4
      &b11111111,&b11111111,&b11111111,&b11111111, _  '5
      &b11111111,&b11111111,&b11111111,&b11111111, _  '6
      &b11111111,&b11111111,&b11111111,&b11111111, _  '7
      &b11111111,&b11111111,&b11111111,&b11111111, _  '8
      &b11111111,&b11111111,&b11111111,&b11111111, _  '9
      &b11111111,&b11111111,&b11111111,&b11111111, _  '10
      &b11111111,&b11111111,&b11111111,&b11111111, _  '11
      &b11111111,&b11111111,&b11111111,&b11111111, _  '12
      &b11111111,&b11111111,&b11111111,&b11111111, _  '13
      &b11111111,&b11111111,&b11111111,&b11111111, _  '14
      &b11111111,&b11111111,&b11111111,&b11111111, _  '15
      &b11111111,&b11111111,&b11111111,&b11111111, _  '16
      &b11111111,&b11111111,&b11111111,&b11111111, _  '17
      &b11111111,&b11111111,&b11111111,&b11111111, _  '18
      &b11111111,&b11111111,&b11111111,&b11111111, _  '19
      &b11111111,&b11111111,&b11111111,&b11111111, _  '20
      &b11111111,&b11111111,&b11111111,&b11111111, _  '21
      &b11111111,&b11111111,&b11111111,&b11111111, _  '22
      &b11111111,&b11111111,&b11111111,&b11111111, _  '23
      &b11111111,&b11111111,&b11111111,&b11111111, _  '24
      &b11111111,&b11111111,&b11111111,&b11111111, _  '25
      &b11111111,&b11111111,&b11111111,&b11111111, _  '26
      &b11111111,&b11111111,&b11111111,&b11111111, _  '27
      &b11111111,&b11111111,&b11111111,&b11111111, _  '28
      &b11111111,&b11111111,&b11111111,&b11111111, _  '39
      &b11111111,&b11111111,&b11111111,&b11111111, _  '30
      &b11111111,&b11111111,&b11111111,&b11111111 }   '31

'======================================================================

dim shared as ubyte cursorXorMask(0 to 4*32-1) = { _
      &b00000000,&b00000001,&b00000000,&b00000000, _  '0
      &b00000000,&b00000001,&b00000000,&b00000000, _  '1
      &b00000000,&b00000001,&b00000000,&b00000000, _  '2
      &b00000000,&b00000001,&b00000000,&b00000000, _  '3
      &b00000000,&b00000001,&b00000000,&b00000000, _  '4
      &b00000000,&b00000001,&b00000000,&b00000000, _  '5
      &b00000000,&b00000001,&b00000000,&b00000000, _  '6
      &b00000000,&b00000001,&b00000000,&b00000000, _  '7
      &b00000000,&b00000001,&b00000000,&b00000000, _  '8
      &b00000000,&b00000001,&b00000000,&b00000000, _  '9
      &b00000000,&b00000001,&b00000000,&b00000000, _  '10
      &b00000000,&b00000001,&b00000000,&b00000000, _  '11
      &b00000000,&b00000001,&b00000000,&b00000000, _  '12
      &b00000000,&b00000000,&b00000000,&b00000000, _  '13
      &b00000000,&b00000000,&b00000000,&b00000000, _  '14
      &b11111111,&b11111000,&b00111111,&b11111110, _  '15
      &b00000000,&b00000000,&b00000000,&b00000000, _  '16
      &b00000000,&b00000000,&b00000000,&b00000000, _  '17
      &b00000000,&b00000001,&b00000000,&b00000000, _  '18
      &b00000000,&b00000001,&b00000000,&b00000000, _  '19
      &b00000000,&b00000001,&b00000000,&b00000000, _  '20
      &b00000000,&b00000001,&b00000000,&b00000000, _  '21
      &b00000000,&b00000001,&b00000000,&b00000000, _  '22
      &b00000000,&b00000001,&b00000000,&b00000000, _  '23
      &b00000000,&b00000001,&b00000000,&b00000000, _  '24
      &b00000000,&b00000001,&b00000000,&b00000000, _  '25
      &b00000000,&b00000001,&b00000000,&b00000000, _  '26
      &b00000000,&b00000001,&b00000000,&b00000000, _  '27
      &b00000000,&b00000001,&b00000000,&b00000000, _  '28
      &b00000000,&b00000001,&b00000000,&b00000000, _  '29
      &b00000000,&b00000001,&b00000000,&b00000000, _  '30
      &b00000000,&b00000000,&b00000000,&b00000000 }   '31

'======================================================================

crosshair1.bas:

Code: Select all

'======================================================================
'' High-visibility crosshair cursor mask definitions, 32x32 only, hot
'' spot at 15, 15.
''
'' The system will AND the screen pixel bits with the AND mask and
'' XOR the result with the XOR mask. In truth table form:
''
'' AND mask  XOR mask  resulting screen bit
'' --------  --------  --------------------
''    0         0              0
''    0         1              1
''    1         0           unchanged
''    1         1           inverted
''
'======================================================================

dim shared as ubyte cursorAndMask(0 to 4*32-1) = { _
      &b11111111,&b11111100,&b01111111,&b11111111, _  '0
      &b11111111,&b11111100,&b01111111,&b11111111, _  '1
      &b11111111,&b11111100,&b01111111,&b11111111, _  '2
      &b11111111,&b11111100,&b01111111,&b11111111, _  '3
      &b11111111,&b11111100,&b01111111,&b11111111, _  '4
      &b11111111,&b11111100,&b01111111,&b11111111, _  '5
      &b11111111,&b11111100,&b01111111,&b11111111, _  '6
      &b11111111,&b11111100,&b01111111,&b11111111, _  '7
      &b11111111,&b11111100,&b01111111,&b11111111, _  '8
      &b11111111,&b11111100,&b01111111,&b11111111, _  '9
      &b11111111,&b11111100,&b01111111,&b11111111, _  '10
      &b11111111,&b11111100,&b01111111,&b11111111, _  '11
      &b11111111,&b11111111,&b11111111,&b11111111, _  '12
      &b11111111,&b11111111,&b11111111,&b11111111, _  '13
      &b00000000,&b00001111,&b11100000,&b00000001, _  '14
      &b00000000,&b00001111,&b11100000,&b00000001, _  '15
      &b00000000,&b00001111,&b11100000,&b00000001, _  '16
      &b11111111,&b11111111,&b11111111,&b11111111, _  '17
      &b11111111,&b11111111,&b11111111,&b11111111, _  '18
      &b11111111,&b11111100,&b01111111,&b11111111, _  '19
      &b11111111,&b11111100,&b01111111,&b11111111, _  '20
      &b11111111,&b11111100,&b01111111,&b11111111, _  '21
      &b11111111,&b11111100,&b01111111,&b11111111, _  '22
      &b11111111,&b11111100,&b01111111,&b11111111, _  '23
      &b11111111,&b11111100,&b01111111,&b11111111, _  '24
      &b11111111,&b11111100,&b01111111,&b11111111, _  '25
      &b11111111,&b11111100,&b01111111,&b11111111, _  '26
      &b11111111,&b11111100,&b01111111,&b11111111, _  '27
      &b11111111,&b11111100,&b01111111,&b11111111, _  '28
      &b11111111,&b11111100,&b01111111,&b11111111, _  '39
      &b11111111,&b11111100,&b01111111,&b11111111, _  '30
      &b11111111,&b11111111,&b11111111,&b11111111 }   '31

'======================================================================

dim shared as ubyte cursorXorMask(0 to 4*32-1) = { _
      &b00000000,&b00001111,&b11100000,&b00000000, _  '0
      &b00000000,&b00001111,&b11100000,&b00000000, _  '1
      &b00000000,&b00001111,&b11100000,&b00000000, _  '2
      &b00000000,&b00001111,&b11100000,&b00000000, _  '3
      &b00000000,&b00001111,&b11100000,&b00000000, _  '4
      &b00000000,&b00001111,&b11100000,&b00000000, _  '5
      &b00000000,&b00001111,&b11100000,&b00000000, _  '6
      &b00000000,&b00001111,&b11100000,&b00000000, _  '7
      &b00000000,&b00001111,&b11100000,&b00000000, _  '8
      &b00000000,&b00001111,&b11100000,&b00000000, _  '9
      &b00000000,&b00001111,&b11100000,&b00000000, _  '10
      &b00000000,&b00001111,&b11100000,&b00000000, _  '11
      &b11111111,&b11110000,&b00011111,&b11111110, _  '12
      &b11111111,&b11110000,&b00011111,&b11111110, _  '13
      &b11111111,&b11110000,&b00011111,&b11111110, _  '14
      &b11111111,&b11110000,&b00011111,&b11111110, _  '15
      &b11111111,&b11110000,&b00011111,&b11111110, _  '16
      &b11111111,&b11110000,&b00011111,&b11111110, _  '17
      &b11111111,&b11110000,&b00011111,&b11111110, _  '18
      &b00000000,&b00001111,&b11100000,&b00000000, _  '19
      &b00000000,&b00001111,&b11100000,&b00000000, _  '20
      &b00000000,&b00001111,&b11100000,&b00000000, _  '21
      &b00000000,&b00001111,&b11100000,&b00000000, _  '22
      &b00000000,&b00001111,&b11100000,&b00000000, _  '23
      &b00000000,&b00001111,&b11100000,&b00000000, _  '24
      &b00000000,&b00001111,&b11100000,&b00000000, _  '25
      &b00000000,&b00001111,&b11100000,&b00000000, _  '26
      &b00000000,&b00001111,&b11100000,&b00000000, _  '27
      &b00000000,&b00001111,&b11100000,&b00000000, _  '28
      &b00000000,&b00001111,&b11100000,&b00000000, _  '29
      &b00000000,&b00001111,&b11100000,&b00000000, _  '30
      &b00000000,&b00000000,&b00000000,&b00000000 }   '31

'======================================================================

createbmpfile.bas:

Code: Select all

'=========================================================================
#include once "windows.bi"
'=========================================================================

'------------------------------------------------------------------
'' This function creates a DIB from a DDB and stores it in a file,
'' or fails if the bits per pixel (bpp) for the DDB is not 4, 8,
'' 16, 24, or 32, or if the bpp for the DIB, specified in bppDib,
'' is not 4, 8, or 24. There is no error checking.
'------------------------------------------------------------------

function CreateBMPFile( byval hbmp as HBITMAP, _
                        byval bppDib as integer, _
                        byref filename as string ) as integer

    dim as integer i, clrUsed
    dim as any ptr pbmp
    dim as HANDLE hFile, hHeap
    dim as HDC hdcScreen
    dim as BITMAPINFO ptr pbmi
    dim as BITMAPFILEHEADER hdr

    hHeap = GetProcessHeap
    hdcScreen = GetDC( null )

    '----------------------------------------------
    '' Allocate memory for a BITMAPINFO structure.
    '----------------------------------------------

    pbmi = HeapAlloc( hHeap, HEAP_ZERO_MEMORY, sizeof(BITMAPINFO) )

    '------------------------------------------------
    '' Set the biSize member of the BITMAPINFOHEADER
    '' structure to the size of the structure.
    '------------------------------------------------

    pbmi->bmiHeader.biSize = sizeof(BITMAPINFOHEADER)

    '---------------------------------------------------------
    '' Call the GetDIBits function with the lpvBits parameter
    '' set to NULL, so the function will pass the dimensions
    '' and format of the bitmap to the BITMAPINFO structure.
    '---------------------------------------------------------

    GetDIBits( hdcScreen, hbmp, 0, 0, null, pbmi, DIB_RGB_COLORS )

    '---------------------------------------------------
    '' Fail if the input bpp is not 4, 8, 16, 24 or 32.
    '---------------------------------------------------

    select case pbmi->bmiHeader.biBitCount
      case 4, 8, 16, 24, 32
      case else
        HeapFree( hHeap, 0, pbmi )
        return false
    end select

    '-------------------------------------------------------------
    '' Set the output bpp, or fail if the bpp is not 4, 8, or 24.
    '-------------------------------------------------------------

    select case bppDib
      case 4, 8, 24
        pbmi->bmiHeader.biBitCount = bppDib
      case else
        HeapFree( hHeap, 0, pbmi )
        return false
    end select

    '---------------------------------------------------------------
    '' For 4 or 8 bpp, reallocate the memory to allow space for the
    '' color table (RGBQUAD array).
    ''
    '' The HeapReAlloc function, when reallocating a memory block
    '' to a larger size, even with the HEAP_ZERO_MEMORY flag, will
    '' preserve the contents of the original block.
    '---------------------------------------------------------------

    select case bppDib
      case 4
        pbmi = HeapReAlloc( hHeap, HEAP_ZERO_MEMORY, pbmi, _
                            sizeof(BITMAPINFO) + 16 * sizeof(RGBQUAD) )
      case 8
        pbmi = HeapReAlloc( hHeap, HEAP_ZERO_MEMORY, pbmi, _
                            sizeof(BITMAPINFO) + 256 * sizeof(RGBQUAD) )
    end select

    '--------------------------------------------------------------------
    '' Assume the bitmap will not be compressed and set the BI_RGB flag.
    '--------------------------------------------------------------------

    pbmi->bmiHeader.biCompression = BI_RGB

    '--------------------------------------------------------------
    '' Calc the number of bytes for the bitmap image and store the
    '' result in the biSizeImage member. The scan lines must be
    '' DWORD aligned, so the width in bits must be adjusted to a
    '' multiple of 32 by adding 31 and then clearing the lower 5
    '' bits.
    '--------------------------------------------------------------

    i = pbmi->bmiHeader.biBitCount * pbmi->bmiHeader.biWidth
    i += 31
    i and= (not 31)
    i shr= 3
    pbmi->bmiHeader.biSizeImage = i * pbmi->bmiHeader.biHeight

    '----------------------------------------------------------------
    '' Calc the horizontal and vertical resolution for the screen in
    '' pixels per meter and store the results in the biXPelsPerMeter
    '' and biYPelsPerMeter members. For index values LOGPIXELSX and
    '' LOGPIXELSY the GetDeviceCaps function returns the resolution
    '' in pixels per logical inch.
    '----------------------------------------------------------------

    i = GetDeviceCaps( hdcScreen, LOGPIXELSX )
    pbmi->bmiHeader.biXPelsPerMeter = i * 39370 \ 1000
    i = GetDeviceCaps( hdcScreen, LOGPIXELSY )
    pbmi->bmiHeader.biYPelsPerMeter = i * 39370 \ 1000

    '-------------------------------------------------
    '' For 4 or 8 bpp set the biClrUsed member to the
    '' correct value, otherwise leave it set to 0.
    '-------------------------------------------------

    select case pbmi->bmiHeader.biBitCount
      case 4
        pbmi->bmiHeader.biClrUsed = 16
      case 8
        pbmi->bmiHeader.biClrUsed = 256
    end select

    '-------------------------------------------------
    '' Set the biClrImportant member to 0, indicating
    '' that all of the device colors are important.
    '-------------------------------------------------

    pbmi->bmiHeader.biClrImportant =  0

    '------------------------------------------------
    '' Allocate a buffer to receive the bitmap data.
    '------------------------------------------------

    pbmp = HeapAlloc( hHeap, HEAP_ZERO_MEMORY, _
                      pbmi->bmiHeader.biSizeImage )

    '---------------------------------------------------------------
    '' Call the GetDIBits function to retrieve the bitmap bits from
    '' the DDB and store them, and the synthesized color table, if
    '' present, in the buffer.
    ''
    '' The biClrUsed member of the BITMAPINFOHEADER structure must
    '' be preserved around the call to prevent the function from
    '' setting it to 0.
    '---------------------------------------------------------------

    clrUsed = pbmi->bmiHeader.biClrUsed
    GetDIBits( hdcScreen, hbmp, 0, pbmi->bmiHeader.biHeight, _
               pbmp, pbmi, DIB_RGB_COLORS )
    pbmi->bmiHeader.biClrUsed = clrUsed

    '-------------------
    '' Create the file.
    '-------------------

    hFile = CreateFile( filename, GENERIC_READ or GENERIC_WRITE, _
                        0, null, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, _
                        null )

    '-----------------------------------------------------
    '' Calculate the size of the file and initialize the
    '' members of the BITMAPFILEHEADER.
    ''
    '' The bfType member must be 'BM' as stored in memory.
    '-----------------------------------------------------

    i = pbmi->bmiHeader.biClrUsed * sizeof(RGBQUAD)
    i += sizeof(BITMAPFILEHEADER)
    i += pbmi->bmiHeader.biSize
    hdr.bfOffBits = i
    i += pbmi->bmiHeader.biSizeImage
    hdr.bfType = &h4d42
    hdr.bfSize = i

    '-----------------------------------------------------
    '' Copy the BITMAPFILEHEADER structure into the file.
    '-----------------------------------------------------

    WriteFile( hFile, @hdr, sizeof(BITMAPFILEHEADER), @i, null )

    '-------------------------------------------------------------
    '' Copy the BITMAPINFOHEADER structure and the RGBQUAD array,
    '' if present, into the file.
    '-------------------------------------------------------------

    i = pbmi->bmiHeader.biClrUsed * sizeof(RGBQUAD)
    i += sizeof(BITMAPINFOHEADER)
    WriteFile( hFile, pbmi, i, @i, null )

    '--------------------------------------
    '' Copy the bitmap bits into the file.
    '--------------------------------------

    WriteFile( hFile, pbmp, pbmi->bmiHeader.biSizeImage, @i, null )

    '------------
    '' Clean up.
    '------------

    ReleaseDC( null, hdcScreen )
    HeapFree( hHeap, 0, pbmi )
    HeapFree( hHeap, 0, pbmp )
    CloseHandle( hFile )

    return true

end function

capture.bas:

Code: Select all

'=========================================================================
'' Minimal window capture demo, modal dialog as main.
''
'' With the mouse cursor in the client area, press and hold the left
'' mouse button, drag the cursor to the target window, then release
'' the button.
'=========================================================================

#include "dialogs.bas"
#include "createbmpfile.bas"
#include "crosshair1.bas"

'=========================================================================

function DialogProc( byval hDlg as  HWND, _
                     byval uMsg as UINT, _
                     byval wParam as WPARAM, _
                     byval lParam as LPARAM ) as integer

  dim as HDC hdcScreen, hdcWnd, hdcBM
  dim as HWND hwndTarget
  dim as integer wd, ht
  dim as HBITMAP hbmp
  dim as RECT rc
  dim as POINT pt
  static as HCURSOR hCursor

  select case uMsg

    case WM_INITDIALOG

      '------------------------------------------------------
      '' If the system cursor size is 32x32 (likely), create
      '' our crosshair custom cursor and save the handle.
      '------------------------------------------------------

      if GetSystemMetrics( SM_CXCURSOR ) = 32 and _
         GetSystemMetrics( SM_CYCURSOR ) = 32 then
         hCursor = CreateCursor( GetModuleHandle( null ), _
                                 15, 15, 32, 32, _
                                 @cursorAndMask(0), _
                                 @cursorXorMask(0) )
      end if

    case WM_LBUTTONDOWN

      '----------------------------------------------------------
      '' If we have a custom cursor, make it the current cursor.
      '----------------------------------------------------------

      if hCursor then
        SetCursor( hCursor )
      end if

      '---------------------
      '' Capture the mouse.
      '---------------------

      SetCapture( hDlg )

    case WM_LBUTTONUP

      '------------------------------------------------------------
      '' Get the client coordinates of the cursor and save them in
      '' our POINT structure. The 16-bit coordinate values must be
      '' sign extended to 32 bits because client coordinates to the
      '' left of and/or above the client area are negative.
      '------------------------------------------------------------

      asm
        mov eax, [lParam]
        movsx eax, ax
        mov [pt], eax
        mov eax, [lParam]
        shr eax, 16
        movsx eax, ax
        mov [pt+4], eax
      end asm

      '--------------------------------------------------------
      '' Convert the client coordinates to screen coordinates.
      '--------------------------------------------------------

      ClientToScreen( hDlg, @pt )

      '---------------------------------------------------
      '' Get the handle of the window beneath the cursor.
      '---------------------------------------------------

      hwndTarget = WindowFromPoint( pt )

      '--------------------------------------------
      '' Remove our custom cursor from the screen.
      '--------------------------------------------

      SetCursor( null )

      '-----------------------------
      '' Release the mouse capture.
      '-----------------------------

      ReleaseCapture()

      '-----------------------------------------------------
      '' Bring the target window to the top of the Z-order.
      '-----------------------------------------------------

      SetForegroundWindow( hwndTarget )

      '---------------------------------------
      '' Get a DC for the screen and create a
      '' compatible memory DC for the bitmap.
      '---------------------------------------

      hdcScreen = GetDC( null )
      hdcBM = CreateCompatibleDC( hdcScreen )

      '----------------------------------------------
      '' Get the dimensions of the target window and
      '' calculate the bitmap width and height.
      '----------------------------------------------

      GetWindowRect( hwndTarget, @rc )
      wd = rc.right - rc.left
      ht = rc.bottom - rc.top

      '--------------------------------------------------
      '' Create a compatible bitmap to store the window
      '' and select it into the memory DC.
      '--------------------------------------------------

      hbmp = CreateCompatibleBitmap( hdcScreen, wd, ht )
      SelectObject( hdcBM, hbmp )

      '----------------------------------
      '' Get a DC for the target window.
      '----------------------------------

      hdcWnd = GetWindowDC( hwndTarget )

      '---------------------------------
      '' Copy the window to the bitmap.
      '---------------------------------

      BitBlt( hdcBM, 0, 0, wd, ht, hdcWnd, 0, 0, SRCCOPY )

      '-----------------------------
      '' Copy the bitmap to a file.
      '-----------------------------

      CreateBmpFile( hbmp, 24, "cap.bmp" )

      '------------
      '' Clean up.
      '------------

      DeleteObject( hbmp )
      DeleteDC( hdcBM )
      ReleaseDC( null, hdcScreen )
      ReleaseDC( null, hdcWnd )

    case WM_COMMAND

      if loword(wParam) = IDCANCEL then

        DestroyCursor( hCursor )
        EndDialog( hDlg, null )

      end if

    case WM_CLOSE

        DestroyCursor( hCursor )
        EndDialog( hDlg, null )

  end select

  return 0

end function

'====================================================================

dim as LPDLGTEMPLATE lpdt

Dialog( 0, 0, 0, 90, 30, "Window Capture Demo", lpdt, _
        WS_OVERLAPPED or WS_SYSMENU or DS_CENTER )

CreateModalDialog( 0, @DialogProc, 0, lpdt )

'====================================================================

And another related example:

Code: Select all

'====================================================================
'' Minimal desktop window capture demo, modal dialog as main.
'====================================================================

#include "dialogs.bas"
#include "createbmpfile.bas"

'====================================================================

function DialogProc( byval hDlg as  HWND, _
                     byval uMsg as UINT, _
                     byval wParam as WPARAM, _
                     byval lParam as LPARAM ) as integer

  dim as HWND hwndDesktop
  dim as HDC hdcScreen, hdcDesktopWindow, hdcBM
  dim as HBITMAP hbmp
  dim as RECT rc
  dim as integer wd, ht

  select case uMsg

    case WM_INITDIALOG

      ''----------------------------------------
      '' Get the handle for the desktop window.
      ''----------------------------------------

      hwndDesktop = GetDesktopWindow()

      '---------------------------------------
      '' Get a DC for the screen and create a
      '' compatible memory DC for the bitmap.
      '---------------------------------------

      hdcScreen = GetDC( null )
      hdcBM = CreateCompatibleDC( hdcScreen )

      '-----------------------------------------------
      '' Get the dimensions of the desktop window and
      '' calculate the bitmap width and height.
      '-----------------------------------------------

      GetWindowRect( hwndDesktop, @rc )
      wd = rc.right - rc.left
      ht = rc.bottom - rc.top

      '--------------------------------------------------
      '' Create a compatible bitmap to store the desktop
      '' window and select it into the memory DC. We have
      '' no need to save the handle to the object being
      '' replaced (returned by SelectObject) because we
      '' will be destroying the memory DC when we have
      '' finished using it.
      '--------------------------------------------------

      hbmp = CreateCompatibleBitmap( hdcScreen, wd, ht )
      SelectObject( hdcBM, hbmp )

      '-----------------------------------
      '' Get a DC for the desktop window.
      '-----------------------------------

      hdcDesktopWindow = GetWindowDC( hwndDesktop )

      '---------------------------------
      '' Copy the window to the bitmap.
      '---------------------------------

      BitBlt( hdcBM, 0, 0, wd, ht, hdcDesktopWindow, 0, 0, SRCCOPY )

      '-----------------------------
      '' Copy the bitmap to a file.
      '-----------------------------

      CreateBmpFile( hbmp, 24, "cap.bmp" )

      '------------
      '' Clean up.
      '------------

      DeleteObject( hbmp )
      DeleteDC( hdcBM )
      ReleaseDC( null, hdcScreen )
      ReleaseDC( null, hdcDesktopWindow )

      '---------------------------------------------------------
      '' Destroy our dialog. Since the WM_INITDIALOG message is
      '' sent before the dialog is displayed, the dialog is
      '' destroyed before it is displayed.
      '---------------------------------------------------------

      EndDialog( hDlg, null )

  end select

  return 0

end function

'====================================================================

dim as LPDLGTEMPLATE lpdt

Dialog( 0, 0, 0, 90, 30, "Window Capture Demo", lpdt, _
        WS_OVERLAPPED or WS_SYSMENU or DS_CENTER )

CreateModalDialog( 0, @DialogProc, 0, lpdt )

'====================================================================

MichaelW · Post by **MichaelW** » Nov 12, 2008 6:54

This uses the CreateBmpFile procedure and simple crosshair cursor mask definitions from the previous post. Again, very little testing and no error checking.

Code: Select all

'=========================================================================
'' Mouse draw demo, modal dialog as main.
'=========================================================================

#include "dialogs.bas"
#include "createbmpfile.bas"
#include "crosshair0.bas"

'=========================================================================

function DialogProc( byval hDlg as  HWND, _
                     byval uMsg as UINT, _
                     byval wParam as WPARAM, _
                     byval lParam as LPARAM ) as integer

  dim as HDC hdcClient
  dim as HBITMAP hbmpTemp
  dim as HGDIOBJ oldObject
  dim as PAINTSTRUCT ps
  dim as POINT pt0, pt1
  dim as RECT rc

  static as integer fCursor
  static as HDC hdcBM
  static as HPEN hpen
  static as HBITMAP hbmp
  static as HCURSOR hCursor
  static as TRACKMOUSEEVENT tme

  select case uMsg

    case WM_INITDIALOG

      '------------------------------------------------------
      '' If the system cursor size is 32x32 (likely), create
      '' our crosshair custom cursor and save the handle.
      '------------------------------------------------------

      if GetSystemMetrics( SM_CXCURSOR ) = 32 and _
         GetSystemMetrics( SM_CYCURSOR ) = 32 then
         hCursor = CreateCursor( GetModuleHandle( null ), _
                                 15, 15, 32, 32, _
                                 @cursorAndMask(0), _
                                 @cursorXorMask(0) )
      end if

      '-----------------------------------------------------
      '' Get a DC for the client area of the dialog window,
      '' create a compatible memory DC and a compatible
      '' bitmap, sized to the client area of the window,
      '' to use as a drawing surface.
      '-----------------------------------------------------

      hdcClient = GetDC( hDlg )
      hdcBM = CreateCompatibleDC( hdcClient )
      GetClientRect( hDlg, @rc )
      hbmp = CreateCompatibleBitmap( hdcClient, rc.right, rc.bottom )

      '---------------------------------------------------------
      '' Select the bitmap into the memory DC. We have no need
      '' here to save the previously selected  object, returned
      '' by the SelectObject function, because we will delete
      '' the DC when we are finished with it.
      '---------------------------------------------------------

      SelectObject( hdcBM, hbmp )

      '---------------------------------------------------
      '' Create a solid black pen with a width of 4, save
      '' the handle, and select it into the bitmap DC.
      '---------------------------------------------------

      hpen = CreatePen( PS_SOLID, 4, 0 )
      SelectObject( hdcBM, hpen )

      '------------------------------------------------------
      '' Fill the bitmap with white. Note that the right and
      '' bottom coordinates have been extended by one pixel
      '' each so the bottom row and rightmost column will
      '' contain white instead of random garbage. See the
      '' Microsoft documentation for the FillRect function
      '' for more information.
      '------------------------------------------------------

      rc.right += 1
      rc.bottom += 1
      FillRect( hdcBM, @rc, GetStockObject( WHITE_BRUSH ) )

      '--------------------------------------
      '' Release the DC for the clent area.
      '-------------------------------------

      ReleaseDC( null, hdcClient )

    case WM_CTLCOLORDLG

      '-------------------------------------------
      '' Set the client area background to white.
      '-------------------------------------------

      return cast(integer,GetStockObject( WHITE_BRUSH ) )

    case WM_PAINT

      '---------------------------------------------------------------
      '' This code displays our bitmap by copying it to the paint DC.
      '---------------------------------------------------------------

      BeginPaint( hDlg, @ps )

      GetClientRect( hDlg, @rc )
      hbmpTemp = CreateCompatibleBitmap( ps.hdc, rc.right, rc.bottom )
      oldObject = SelectObject( ps.hdc, hbmpTemp )

      BitBlt( ps.hdc, 0, 0, rc.right, rc.bottom, hdcBM, 0, 0, SRCCOPY )

      SelectObject( ps.hdc, oldObject )
      DeleteObject( hbmpTemp )

      EndPaint( hDlg, @ps )

    case WM_SETCURSOR

      '-------------------------------------------------------------
      '' If we have a custom cursor and it is the current cursor,
      '' to prevent the system from replacing it with the class
      '' cursor each time the cursor is moved, we must process
      '' this message and return TRUE.
      '-------------------------------------------------------------

        if cast(integer,hCursor) and fCursor then
          return true
        end if

    case WM_LBUTTONDOWN

      '-----------------------------------------
      '' Confine the cursor to the client area.
      '-----------------------------------------

      GetClientRect( hDlg, @rc )

      pt0.x = 0
      pt0.y = 0
      pt1.x = rc.right
      pt1.y = rc.bottom
      ClientToScreen( hDlg, @pt0 )
      ClientToScreen( hDlg, @pt1 )
      SetRect( @rc, pt0.x, pt0.y, pt1.x, pt1.y )
      ClipCursor( @rc )

      '-------------------------------------------
      '' Start a new line by updating the current
      '' position to the cursor coordinates.
      '-------------------------------------------

      MoveToEx( hdcBM, loword(lParam), hiword(lParam), null )

    case WM_LBUTTONUP

      '----------------------
      '' Release the cursor.
      '----------------------

      ClipCursor( null )

    case WM_MOUSELEAVE

      '--------------------------------------------------
      '' Clear the cursor flag so on the next mouse move
      '' the system will revert to the class cursor.
      '--------------------------------------------------

      fCursor = 0

    case WM_MOUSEMOVE

      if fCursor = 0 then

        fCursor = 1

        '----------------------------------------------------------
        '' If we have a custom cursor, make it the current cursor.
        '----------------------------------------------------------

        if hCursor then SetCursor( hCursor )

        '-------------------------------------------
        '' Start a new line by updating the current
        '' position to the cursor coordinates.
        '-------------------------------------------

        MoveToEx( hdcBM, loword(lParam), hiword(lParam), null )

        '------------------------------------------------------
        '' Set up to receive a WM_MOUSELEAVE notification when
        '' the mouse pointer leaves the client area. Note that
        '' only one notification will be generated for each
        '' call to TrackMouseEvent.
        '------------------------------------------------------

        tme.cbSize = sizeof(TRACKMOUSEEVENT)
        tme.dwFlags = TME_LEAVE
        tme.hwndTrack = hDlg
        TrackMouseEvent( @tme )

      elseif wParam and MK_LBUTTON then

        '-----------------------------
        '' Continue the current line.
        '-----------------------------

        LineTo( hdcBM, loword(lParam), hiword(lParam) )

        '----------------------------------------------------
        '' Force a repaint of the client area so the display
        '' will be updated to match the bitmap.
        '----------------------------------------------------

        InvalidateRect( hDlg, null, false )

      end if

    case WM_COMMAND

      select case loword(wParam)

        case IDCANCEL

          '---------------------
          '' Clean up and exit.
          '---------------------

          if hCursor then DestroyCursor( hCursor )

          DeleteObject( hpen )
          DeleteObject( hbmp )
          DeleteDC( hdcBM )

          EndDialog( hDlg, null )

      end select

    case WM_CLOSE

      '---------------------
      '' Clean up and exit.
      '---------------------

      if hCursor then DestroyCursor( hCursor )

      CreateBmpFile( hbmp, 4, "junk.bmp" )

      DeleteObject( hpen )
      DeleteObject( hbmp )
      DeleteDC( hdcBM )

      EndDialog( hDlg, null )

   end select

   return 0

end function

'=========================================================================

dim as LPDLGTEMPLATE lpdt

Dialog( 0, 0, 0, 160, 120, "Mouse Draw Demo", lpdt, _
        WS_OVERLAPPED or WS_SYSMENU or DS_CENTER )

CreateModalDialog( 0, @DialogProc, 0, lpdt )

'=========================================================================

harmonv · Post by **harmonv** » Nov 24, 2008 14:45

I’m hoping that this is not too big to post.

The original concept for this was from the MASM32 in-memory dialogs, implemented as a set of MASM macros.

The DIALOGS.BAS module provides a simple method of creating a dialog box template in allocated memory, and creating a modal or modeless dialog from the template.

Michael,
This looks like great stuff. Really looking forward to trying it.
Is there a zip file with your code, demos and docs?
It would take a while to copy & paste it all from the forum.

MichaelW · Post by **MichaelW** » Nov 26, 2008 8:13

Is there a zip file with your code, demos and docs?

Sorry, I currently have no way to do that. I have done so much experimenting and have so many incomplete projects that the only reasonable way I could be sure of getting the correct examples would be to copy them from the forum. The essential components and information are in the first post, and depending on what you are doing you may need only a single example or small number of examples.

MichaelW · Post by **MichaelW** » Nov 26, 2008 8:26

Code: Select all

'=========================================================================
'' Simple editor demo, fully-programmed menu and keyboard accelerators
'' (no MENU or ACCELERATORS resource), modeless dialog as main.
''
'' Keyboard accelerators are easier to implement in a modeless dialog
'' because you have direct access to the message loop.
'=========================================================================

#include "dialogs.bas"

'---------------------------------------------------------------
'' Dialogs.bas includes windows.bi, but to support the Open and
'' Save As dialogs from the Common Dialog Box Library, we need
'' to also include commdlg.bi.
'---------------------------------------------------------------

#include once "win\commdlg.bi"

'=========================================================================

#define IDC_EDIT    100

#define IDM_NEW     1000
#define IDM_OPEN    1001
#define IDM_SAVE    1002
#define IDM_SAVEAS  1003
#define IDM_EXIT    1004

#define TABWIDTH 4

dim shared as HACCEL g_hAccel
dim shared as HWND g_hwndEdit
dim shared as zstring * MAX_PATH g_szFile = "Untitled"

'=========================================================================

''------------------------------------------------------------------
'' Note that for the following two functions the string pointed to
'' by pszFile must be large enough to receive the drive designator,
'' path, file name, and extension of the specified file, and that
'' the size must be specified in nMaxFile. The size is typically
'' specified as the MAX_PATH constant.
''------------------------------------------------------------------

'--------------------------------------------------------------------
'' This function sets up and opens the Open dialog box and returns
'' whatever the GetOpenFileName function returned. The return value
'' will be zero if the user canceled the dialog or an error occurred,
'' or non-zero if the user specified a file and clicked OK, in which
'' case the string pointed to by pszFile will contain the full path
'' and filename of the file specified by the user.
'--------------------------------------------------------------------

function GetOFN( byval hwndOwner as HWND, _
                 byval pszFile as zstring ptr, _
                 byval nMaxFile as integer) as integer

    dim as OPENFILENAME ofn

    ofn.lStructSize = sizeof(OPENFILENAME)
    ofn.hWndOwner = hwndOwner
    ofn.lpstrFilter = strptr(!"All Files (*.*)\0*.*\0\0")
    ofn.lpstrFile = pszFile
    ofn.nMaxFile = nMaxFile
    ofn.Flags = OFN_FILEMUSTEXIST or OFN_LONGNAMES

    return GetOpenFileName( @ofn )

end function

'---------------------------------------------------------------------
'' This function sets up and opens the Save As dialog box and returns
'' whatever the GetSaveFileName function returned. The return value
'' will be zero if the user canceled the dialog or an error occurred,
'' or non-zero if the user specified a file name and clicked OK, in
'' which case the string pointed to by pszFile will contain the full
'' path and filename specified by the user.
'---------------------------------------------------------------------

function GetSFN( byval hwndOwner as HWND, _
                 byval pszFile as zstring ptr, _
                 byval nMaxFile as integer) as integer

    dim as OPENFILENAME ofn

    ofn.lStructSize = sizeof(OPENFILENAME)
    ofn.hWndOwner = hwndOwner
    ofn.lpstrFile = pszFile
    ofn.nMaxFile = nMaxFile
    ofn.Flags = OFN_LONGNAMES

    return GetSaveFileName( @ofn )

end function

'=========================================================================

function LoadTextFromFile( byval pszFile as zstring ptr ) as integer

  dim as ubyte ptr p
  dim as integer i, res

  open *pszFile for binary as 1

  i = lof(1)

  '-----------------------------------------------------------
  '' The edit control expects a null-terminated string, so we
  '' need to allocate a zero-filled buffer and allow room
  '' for the terminating null.
  '-----------------------------------------------------------

  p = callocate(i+1)

  get #1,,*p,i

  '----------------------------------------------------------
  '' The WM_SETTEXT message returns true if the text is set.
  '----------------------------------------------------------

  if SendMessage( g_hwndEdit, WM_SETTEXT, 0, cast(LPARAM,p) ) then
    res = i
  end if

  deallocate p

  close

  return res

end function

function SaveTextToFile( byval pszFile as zstring ptr ) as integer

  dim as ubyte ptr p
  dim as integer i

  i = SendMessage( g_hwndEdit, WM_GETTEXTLENGTH , 0, 0 )

  '--------------------------------------------------------------
  '' Double the size of the buffer to prevent Windows NT/2000/XP
  '' from potentially reducing the length of the string in the
  '' conversion from ANSI to Unicode.
  '--------------------------------------------------------------

  p = allocate(i*2)

  SendMessage( g_hwndEdit, WM_GETTEXT , i*2, cast(LPARAM,p) )

  kill *pszFile
  open *pszFile for binary as 1
  put #1,,*p,i
  close

  return i

end function

'=========================================================================

function InitMenu() as HMENU

  dim as HMENU hMenu, hFileMenu
  dim as ACCEL accl( 0 to 2)

  hMenu = CreateMenu
  hFileMenu = CreateMenu

  AppendMenu( hMenu, MF_POPUP, cast(UINT_PTR,hFileMenu), "&File" )
  AppendMenu( hFileMenu, MF_STRING, IDM_NEW, !"&New\tCtrl+N" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, IDM_OPEN, !"&Open\tCtrl+O" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, IDM_SAVE, !"&Save\tCtrl+S" )
  AppendMenu( hFileMenu, MF_STRING, IDM_SAVEAS, !"Save &As" )
  AppendMenu( hFileMenu, MF_SEPARATOR, 0, 0 )
  AppendMenu( hFileMenu, MF_STRING, IDM_EXIT, !"E&xit\tAlt+F4" )

  accl(0).fVirt = FCONTROL or FVIRTKEY
  accl(0).key = asc("N")
  accl(0).cmd = IDM_NEW
  accl(1).fVirt = FCONTROL or FVIRTKEY
  accl(1).key = asc("O")
  accl(1).cmd = IDM_OPEN
  accl(2).fVirt = FCONTROL or FVIRTKEY
  accl(2).key = asc("S")
  accl(2).cmd = IDM_SAVE

  g_hAccel = CreateAcceleratorTable( cast(LPACCEL,@accl(0)), 3 )

  return hMenu

end function

'=========================================================================

function DialogProc( byval hDlg as  HWND, _
                     byval uMsg as UINT, _
                     byval wParam as WPARAM, _
                     byval lParam as LPARAM ) as integer

  dim as RECT rcDlg

  select case uMsg

    case WM_INITDIALOG

      SetMenu( hDlg, InitMenu() )

      g_hwndEdit = GetDlgItem( hDlg, IDC_EDIT )

      '------------------------------------------------------------
      '' The edit control expects the tab width to be expressed in
      '' Dialog Template Units. Since a DTU is 1/4 of the average
      '' width of the font used, the tab width in DTUs is the tab
      '' width in characters * 4.
      '------------------------------------------------------------

      dim as integer tw = TABWIDTH * 4
      SendMessage( g_hwndEdit, EM_SETTABSTOPS, 1, cast(LPARAM,@tw) )

      SetWindowText( hDlg, @g_szFile )

      return true

    case WM_COMMAND

      select case loword(wParam)

        case IDM_NEW

          SendMessage( g_hwndEdit, WM_SETTEXT, 0, 0)
          g_szFile = "Untitled"
          SetWindowText( hDlg, @g_szFile )

        case IDM_OPEN

          if GetOFN( hDlg, @g_szFile, MAX_PATH ) then
            LoadTextFromFile( g_szFile )
            SetWindowText( hDlg, @g_szFile )
          end if

        case IDM_SAVE

          if g_szFile = "Untitled" then
            if GetSFN( hDlg, @g_szFile, MAX_PATH ) then
              SaveTextToFile( g_szFile )
              SetWindowText( hDlg, @g_szFile )
            end if
          else
            SaveTextToFile( g_szFile )
          end if

        case IDM_SAVEAS

          if GetSFN( hDlg, @g_szFile, MAX_PATH ) then
              SaveTextToFile( g_szFile )
              SetWindowText( hDlg, @g_szFile )
          end if

        case IDM_EXIT

          DestroyWindow( hDlg )

      end select

    case WM_SIZE

      GetClientRect( hDlg, @rcDlg )

      MoveWindow( g_hwndEdit, 0, 0, rcDlg.right, rcDlg.bottom, true )

    case WM_CLOSE

      DestroyWindow( hDlg )

    case WM_DESTROY

      DestroyAcceleratorTable( g_hAccel )
      PostQuitMessage( null )

  end select

  return 0

end function

'=========================================================================

dim as LPDLGTEMPLATE lpdt
dim as HWND hDlg
dim as MSG wMsg
dim as integer sel

'----------------------------------------------------------------
'' The WS_VISIBLE style is necessary for a modeless dialog to be
'' visible. The WS_CLIPCHILDREN style is an attempt to improve
'' the appearance of the edit control when the dialog is resized.
'' Under Windows 2000 it has no apparent effect, but it may have
'' an effect under later versions of Windows. Under Windows 2000
'' the text in the edit control flashes whenever the dialog is
'' resized, but no worse than it does in notepad.
'----------------------------------------------------------------

Dialog( 1, 0, 0, 300, 225, "", lpdt, _
        WS_OVERLAPPEDWINDOW or DS_CENTER or WS_VISIBLE or _
        WS_CLIPCHILDREN or DS_SETFONT, 11, "fixedsys" )

'--------------------------------------------------------
'' Zeros can be used for the position and size of the
'' edit control because both will be set in the WM_SIZE
'' hander.
'--------------------------------------------------------

EditText( IDC_EDIT, 0, 0, 0, 0, "", WS_BORDER or _
                                    WS_VSCROLL or _
                                    WS_HSCROLL or _
                                    ES_MULTILINE or _
                                    ES_AUTOVSCROLL or _
                                    ES_AUTOHSCROLL or _
                                    ES_WANTRETURN )

hDlg = CreateModelessDialog( 0, @DialogProc, 0, lpdt )

do while GetMessage( @wMsg, null, 0, 0 ) <> 0

  '---------------------------------------------------------------
  '' A multi-line edit control responds to the tab key by doing a
  '' select all, instead of doing what most people would expect.
  '' To modify this behavior, without having to subclass the edit
  '' control, we intercept the tab key in the message loop, get
  '' the current insertion point, kill any existing selection (by
  '' selecting a zero-length range at the insertion point), and
  '' insert a tab character. We then bypass further processing of
  '' the message, effectively discarding it.
  '---------------------------------------------------------------

  if wMsg.message = WM_KEYDOWN and wMsg.wParam = VK_TAB then

    SendMessage( g_hwndEdit, EM_GETSEL, cast(wParam,@sel), 0 )
    SendMessage( g_hwndEdit, EM_SETSEL, sel, sel )
    SendMessage( g_hwndEdit, EM_REPLACESEL, 0, cast(lParam,strptr(!"\t")) )

  else

    if TranslateAccelerator( hDlg, g_hAccel, @wMsg ) = 0 then
      if IsDialogMessage( hDlg,  @wMsg ) = 0 then
        TranslateMessage( @wMsg )
        DispatchMessage( @wMsg )
      end if
    end if

  end if

loop

'=========================================================================