DDT Modeless as progress bar

[Semen Matusovski]

written under impression of borje hagsten's code http://www.powerbasic.com/support/pb...ad.php?t=22952

to change colors, use setwindowlong.

   
   #compile exe
   #register none
   #dim all
   #include "win32api.inc"
   
   '******************************
   '*      pbprogressbar         *
   '******************************
   
   %pbprogressbar_done      =  0
   %pbprogressbar_bkgl_rgb1 =  4
   %pbprogressbar_bkgl_rgb2 =  8
   %pbprogressbar_bkgl_rgb3 = 12
   %pbprogressbar_bkgl_rgb4 = 16
   %pbprogressbar_bkgr_rgb  = 20
   %pbprogressbar_frgl_rgb  = 24
   %pbprogressbar_frgr_rgb  = 28

   function register_pbprogressbar as long

     local wc          as wndclass
     local szclassname as asciiz * 14

     szclassname      = "pbprogressbar"
     wc.lpfnwndproc   = codeptr(pbprogressbarproc)
     wc.hinstance     = getmodulehandle(byval %null)
     wc.hbrbackground = getstockobject(%null_brush)
     wc.lpszclassname = varptr(szclassname)
     wc.cbwndextra    = 32

     function = registerclass(wc)

  end function


   function pbprogressbarrgbcoloref (crgb as long) as long
      redim b(0 : 3) as byte at varptr(crgb)
      function = rgb(b(2), b(1), b(0))
   end function

   function pbprogressbarproc (byval hwnd as long, byval wmsg as long, _
                               byval wparam as long, byval lparam as long) as long
       
      select case wmsg
         case %wm_create
            ' defaults
            setwindowlong hwnd, %pbprogressbar_done, 0
            setwindowlong hwnd, %pbprogressbar_bkgl_rgb1, rgb(  0,   0, 255)
            setwindowlong hwnd, %pbprogressbar_bkgl_rgb2, rgb(  0,   0,  64)
            setwindowlong hwnd, %pbprogressbar_bkgl_rgb3, %ltgray
            setwindowlong hwnd, %pbprogressbar_bkgl_rgb4, %gray
          
            setwindowlong hwnd, %pbprogressbar_bkgr_rgb,  %black
            setwindowlong hwnd, %pbprogressbar_frgl_rgb,  %white
            setwindowlong hwnd, %pbprogressbar_frgr_rgb,  %white

         case %wm_user + 2 ' = %pbm_setpos
            setwindowlong hwnd, %pbprogressbar_done, wparam
            invalidaterect hwnd, byval 0&, 0: updatewindow hwnd

         case %wm_paint
            dim i as long, j as long, jj as long, k as long, kk as long
            dim bmi as bitmapinfo, bm as bitmap, ps as paintstruct, rc as rect
            dim hmemdc(1 to 2) as long, hmembmp(1 to 2) as long, pbits as long ptr
            dim done as long, coef as double
            dim red1 as long, green1 as long, blue1 as long, red2 as long, green2 as long, blue2 as long
            dim clrb1 as long, clrb2 as long, clr1 as long, clr2 as long
            
            done = min(getwindowlong (hwnd, %pbprogressbar_done), 100): done = max(0, done)

            i = getwindowlong (hwnd, %pbprogressbar_bkgl_rgb1)
            blue1 = (i and &h00ff0000): shift right blue1, 16
            green1 = (i and &h0000ff00): shift right green1, 8
            red1  = (i and &hff)

            i = getwindowlong (hwnd, %pbprogressbar_bkgl_rgb2)
            blue2 = (i and &h00ff0000): shift right blue2, 16
            green2 = (i and &h0000ff00): shift right green2, 8
            red2  = (i and &hff)
            
            clrb1 = pbprogressbarrgbcoloref(getwindowlong (hwnd, %pbprogressbar_bkgl_rgb3))
            clrb2 = pbprogressbarrgbcoloref(getwindowlong (hwnd, %pbprogressbar_bkgl_rgb4))
          
            clr2 =  pbprogressbarrgbcoloref(getwindowlong (hwnd, %pbprogressbar_bkgr_rgb))
            
            getclientrect hwnd, rc
            beginpaint hwnd, ps
            for i = 1 to 2
               hmemdc(i)  = createcompatibledc(ps.hdc)
               bmi.bmiheader.bisize = sizeof(bmi.bmiheader)
               bmi.bmiheader.biwidth = rc.nright
               bmi.bmiheader.biheight = rc.nbottom
               bmi.bmiheader.biplanes = 1
               bmi.bmiheader.bibitcount = 32
               bmi.bmiheader.bicompression = %bi_rgb
               hmembmp(i) = createdibsection(hmemdc(i), bmi, %dib_rgb_colors, 0, 0, 0)
               globallock hmembmp(i): selectobject hmemdc(i), hmembmp(i)
               
               getobject hmembmp(i), sizeof(bm), bm
               pbits = bm.bmbits
               
               kk = rc.nright * done / 100
               for j = rc.nbottom - 1 to 0 step - 1
                  coef = j / rc.nbottom
                  clr1 = rgb(blue1 - (blue1 - blue2) * coef, green1 - (green1 - green2) * coef, red1 - (red1 - red2) * coef)
                  for k = 0 to rc.nright - 1
                     if i = 2 then @pbits = clr2 else _
                     if k < kk then @pbits = clr1  else _
                     if k = kk then @pbits = clrb1 else _
                     if k = (kk + 1) then @pbits = clrb2
                     pbits = pbits + 4
                  next
               next
               setbkmode hmemdc(i), %transparent
               if i = 1 then settextcolor hmemdc(i), getwindowlong (hwnd, %pbprogressbar_frgl_rgb) else _
                             settextcolor hmemdc(i), getwindowlong (hwnd, %pbprogressbar_frgr_rgb)
               drawtext hmemdc(i), format$(done)+"%", -1, rc, %dt_singleline or %dt_center or %dt_vcenter
            next

            bitblt hmemdc(2), 0, 0, min(kk + 2, rc.nright), rc.nbottom, hmemdc(1), 0, 0, %srccopy
            bitblt ps.hdc, 0, 0, rc.nright, rc.nbottom, hmemdc(2), 0, 0, %srccopy
            endpaint hwnd, ps
            
            for i = 1 to 2: deletedc hmemdc(i): deleteobject hmembmp(i): next
            function = 0: exit function

      end select

      function = defwindowproc(hwnd, wmsg, wparam, lparam)
   end function
   
   '**************************************************************


   %pbm_setpos  = %wm_user + 2

   callback function dlgproc
      static done1 as long, done2 as long
      select case cbmsg
         case %wm_initdialog
            control add "pbprogressbar", cbhndl, 101, ", 10, 10, 176, 14, %ws_child, %ws_ex_clientedge
            control add "pbprogressbar", cbhndl, 102, ", 10, 30, 176, 14, %ws_child, %ws_ex_clientedge
            
            setwindowlong getdlgitem(cbhndl, 102), %pbprogressbar_bkgl_rgb1, %red
            setwindowlong getdlgitem(cbhndl, 102), %pbprogressbar_bkgl_rgb2, rgb(64, 0,  0)
'           setwindowlong getdlgitem(cbhndl, 102), %pbprogressbar_bkgl_rgb3, rgb(192, 192, 192)
'           setwindowlong getdlgitem(cbhndl, 102), %pbprogressbar_bkgl_rgb4, rgb(128, 128, 128)

            setwindowlong getdlgitem(cbhndl, 102), %pbprogressbar_bkgr_rgb, rgb(64, 64, 0)
            setwindowlong getdlgitem(cbhndl, 102), %pbprogressbar_frgl_rgb, %yellow
            setwindowlong getdlgitem(cbhndl, 102), %pbprogressbar_frgr_rgb, rgb(255, 255, 255)

            control add button, cbhndl, %idok,     "&show", 10, 80, 50, 14, %bs_default
            control add button, cbhndl, %idcancel, "&hide", 70, 80, 50, 14
            
            control set focus cbhndl, %idok
            
         case %wm_command
            if cbctl = %idok then
               done1 = 0: done2 = 0
               settimer cbhndl, 1, 100, byval %null
               settimer cbhndl, 2, 500, byval %null
               showwindow getdlgitem(cbhndl, 101), 1
               showwindow getdlgitem(cbhndl, 102), 1

               control send cbhndl, 101, %pbm_setpos, done1, 0
               control send cbhndl, 102, %pbm_setpos, done2, 0

            elseif cbctl = %idcancel then
               killtimer cbhndl, 1: killtimer cbhndl, 2
               showwindow getdlgitem(cbhndl, 101), 0
               showwindow getdlgitem(cbhndl, 102), 0
            end if

         case %wm_timer
            if cbctl = 1 then
               done1 = done1 + 2: if done1 > 100 then done1 = 0
               control send cbhndl, 101, %pbm_setpos, done1, 0
            else
               done2 = done2 + 2
               if done2 > 100 then
                  if done1 >= 100 then killtimer cbhndl, 1: killtimer cbhndl, 2
               else
                  control send cbhndl, 102, %pbm_setpos, done2, 0
               end if
            end if
      end select
   end function

   function pbmain
      register_pbprogressbar
      
      local hdlg as long, hdlg1 as long
      dialog new 0, "progress bar",,, 200, 120, %ws_sysmenu to hdlg
      dialog show modal hdlg call dlgproc
   end function

[this message has been edited by semen matusovski (edited march 31, 2001).]

[Scott Turchin]

Here's another one, not the white/blue, just the standard MS broken one (er, broken image, not Progress bar)...Jim H. Helped me out on this and I actually use it in my encryption routine for doing files..
What it does is open a new thread and process it in a new thread in case it takes a heavy toll on the system as the encryption can do...

Timing is everything, this is not perfect, butit does work and gives the sample on how to do the standard ms progress bar...not as pretty as the one above though

$Compile Exe
$Resource "PROG.PBR"
$Include "WIN32API.INC"
$Include "COMMCTRL.INC"

Global hIcon        As Long
Global hDlg         As Long
Global tDlg         As Long
Global hProgressDlg As Long
Global hProgressBar As Long
Global hDialogText  As Long
Global hInstance    As Long
Global g_hThread    As Long
Global g_FileSpec   As String

Global Cancel       As Long
Global g_lngInitThreadHandle As Long

Declare Sub UpdateProgress(Text As Asciiz)
Declare Function ProcessFile(FileSpec As String) As Long

Declare CallBack Function ThreadItemsProc() As Long
Declare CallBack Function DialogProc() As Long

%PROGRAM = 1024
%PROGRESS = %WM_USER + 902

'===============================
'Resource file requirements:
'#define PROGRAM 1024
'PROGRAM ICON "PROGRAM.ICO"
'===============================

'----------------------------------------------------------------------------------------------------------------

Function WinMain (ByVal hInstance     As Long, _
                  ByVal hPrevInstance As Long, _
                  lpCmdLine           As Asciiz Ptr, _
                  ByVal iCmdShow      As Long) As Long


ProcessFile "DEBUG.TXT"
End Function

'----------------------------------------------------------------------------------------------------------------

Function ProcessFile(FileSpec As String) As Long
Local id As Long
Local l_Result As Long


g_FileSpec = "DEBUG.TXT"  'For testing purposes, use your own global filespec name


hIcon = LoadIcon( hInstance, ByVal %PROGRAM)
Dialog New 0, "Progressbar  - " + g_FileSpec ,,, 200,50 ,  %SW_SHOWNORMAL To hDlg
Control Add Image, hDlg, -3,"#1024",-1,-1,14,14 'Icon
Dialog Send hDlg, %WM_SETICON, %ICON_SMALL, hIcon
Control Add Label, hDlg, -3, "Encrypting " + g_FileSpec, 25,1,160,10
Control Add "msctls_progress32",hDlg,%PROGRESS,"",1,20,150,10, %WS_CHILD Or %WS_VISIBLE Or %WS_CLIPSIBLINGS Or %CCS_BOTTOM
Control Add Button, hDlg, %IDCANCEL, "&Cancel", 155, 16,40, 14, %WS_TABSTOP

' Create a thread to handle dialog messages of modeless dialog boxes
If IsFalse g_lngInitThreadHandle Then
   Thread Create InitThread(id) To g_hThread
   ' Let the thread end when it stops
   Thread Close g_hThread To l_Result
   'Add WaitForObject here
Else
   Exit Function
End If

'Create modeless dialog for thread:
Dialog New 0,"" ,,,180,60,  %WS_CHILD Or %DS_CONTROL, 0 To tDlg
Dialog Show Modeless tDlg Call ThreadItemsProc
Dialog Show Modal hDlg Call DialogProc


End Function


'----------------------------------------------------------------------------------------------------------------

Function InitThread(ByVal id As Long) Export As Long
Local FilePos   As Long
Local FileSize  As Long
Local MaxBuff   As Long
Local x         As Long

g_lngInitThreadHandle = %TRUE


FileSize = 500000 'Or import your filesize
BytesToRead& = FileSize
FilePos& = 1
MaxBuff& = 4096

Control Send hDlg, %PROGRESS, %PBM_SETRANGE, 0 ,MakLng(0,FileSize& \ MaxBuff&)
Control Send hDlg, %PROGRESS, %PBM_SETSTEP, 1 , 0


For x = 1 To FileSize \ MaxBuff&
    'Time this one in your loops of processing files etc...
    Control Send hDlg, %PROGRESS, %PBM_STEPIT , 0, 0
'    Sleep 50 'to simulate a heavy load on the computer
Next

'Set Global Flag to False here
g_lngInitThreadHandle = %FALSE
Dialog End hDlg, 1

End Function


'------------------------------------------------------------------------------
Function ThreadDialog(ByVal hDlg As Long) Export As Long
Local Rc As Long
Do
    Dialog DoEvents
    Dialog Get Size hDlg To Rc,Rc
Loop While Rc

Function = 1
End Function
'----------------------------------------------------------------------------------------------------------------
CallBack Function ThreadItemsProc() As Long
Local wMsg   As Long
Local wParam As Long
Local lParam As Long
Local x      As Long
wMsg = CbMsg
lParam = CbLparam
wparam = CbWparam
  Select Case wMsg
    Case %WM_ACTIVATE

    Case %WM_COMMAND

      Select Case LoWrd(wParam)
        Case %IDCANCEL
            Dialog End tDlg, 0
            Dialog End hDlg, 0

      End Select
  End Select
End Function

'----------------------------------------------------------------------------------------------------------------
CallBack Function DialogProc() As Long
Local wMsg   As Long
Local wParam As Long
Local lParam As Long
Local x      As Long
wMsg = CbMsg
lParam = CbLparam
wparam = CbWparam
  Select Case wMsg
    Case %WM_ACTIVATE

    Case %WM_COMMAND
      Select Case LoWrd(wParam)

        Case %IDCANCEL
            Dialog End tDlg, 0
            Dialog End hDlg, 0
      End Select

   Case %WM_DESTROY
        Dialog End tDlg, 0 'Destroy Modeless dialog

  End Select

End Function

------------------
Scott
mailto:[email protected][email protected]</A>

[Semen Matusovski]

I saw one question in "Programming" forum about colors for progress bar.
Because I prefer "own-drawn" progress bar, I decided to post simple sample.

   #Compile Exe
   #Register None
   #Dim All
   #Include "WIN32API.INC"

   CallBack Function PicProc
      Static hBrush() As Long, hDC() As Long, hBmp() As Long, Clr() As Long
      Static i As Long, Done As Long, LpPaint As PaintStruct, tRect As Rect
      Static zText As Asciiz * 255
      Select Case CbMsg
         Case %WM_INITDIALOG
            ReDim hDC(0 To 2): ReDim hBrush(1 To 2): ReDim hBmp(1 To 2): ReDim Clr(1 To 2)
            hBrush(1) = CreateSolidBrush(Rgb(  0,   0, 255)): Clr(1) = %White
            hBrush(2) = CreateSolidBrush(Rgb(255, 255, 255)): Clr(2) = %Black
         Case %WM_DESTROY
            For i = 1 To 2: DeleteObject hBrush(i): Next
            InvalidateRect GetParent(CbHndl), ByVal 0, %True
            UpdateWindow GetParent(CbHndl)
         Case %WM_ERASEBKGND: Function = 1: Exit Function
         Case %WM_USER + 1
            Done = CbWparam
            InValidateRect CbHndl, ByVal 0, %True: UpdateWindow CbHndl
         Case %WM_PAINT
            GetClientRect CbHndl, tRect
            hDC(0) = BeginPaint(CbHndl, LpPaint)
            For i = 1 To 2
               hDC(i)  = CreateCompatibleDC(hDC(0))
               hBmp(i) = CreateCompatibleBitMap (hDC(0), tRect.nRight, tRect.nBottom)
               SelectObject hDc(i), hBmp(i)
               FillRect hDC(i), tRect, hBrush(i)
               SetBkMode hDC(i), %TRANSPARENT
               SetTextColor hDC(i), Clr(i)
               Select Case Done
                  Case  6 To 12: zText = "A lot of time to sleep"
                  Case 86 To 92: zText = "Wake up, almost done"
                  Case Else: zText = Str$(Done)+"%"
               End Select
               DrawText hDC(i), zText, -1, tRect, _
                  %DT_SINGLELINE Or %DT_CENTER Or %DT_VCENTER
            Next
            BitBlt hDC(2), 0, 0, tRect.nRight * Done * 0.01, tRect.nBottom, hDC(1), 0, 0, %SRCCOPY
            BitBlt hDC(0), 0, 0, tRect.nRight, tRect.nBottom, hDC(2), 0, 0, %SRCCOPY
            EndPaint CbHndl, LpPaint
            For i = 1 To 2: DeleteDC hDC(i): DeleteObject hBmp(i): Next
            Function = 0: Exit Function
      End Select
   End Function

   CallBack Function DlgProc
      Static Done As Long, hDlg As Long
      Select Case CbMsg
         Case %WM_COMMAND
            If CbCtl = 101 Then
               Done = 0
               SetTimer CbHndl, 1, 500, ByVal %Null
               Dialog New CbHndl, "", 10, 10, 176, 12, %WS_CHILD Or %WS_VISIBLE Or %WS_BORDER To hDlg
               Dialog Show Modeless hDlg Call PicProc
               Dialog Send hDlg, %WM_USER + 1, Done, 0
            End If
         Case %WM_TIMER
            Done = Done + 2
            If Done > 100 Then Dialog End hDlg: KillTimer CbHndl, 1 Else _
            Dialog Send hDlg, %WM_USER + 1, Done, 0
      End Select
   End Function

   Function PbMain
      Local hDlg As Long, hDlg1 As Long
      Dialog New 0, "Progress Bar",,, 200, 80, %WS_SYSMENU To hDlg
      Control Add Button, Hdlg, 101, "Show", 50, 40,100, 14, %BS_DEFAULT
      Dialog Show Modal hDlg Call DlgProc
   End Function

Regions were excluded, because of problems under Win95.

[This message has been edited by Semen Matusovski (edited April 16, 2000).]