Text scroller

Semen Matusovski replied

22 Jan 2001, 09:13 AM
Jules --
> I tried your post above and does nothing???

Under which OS ? Did you correct pathes ?

(I wrote under Win2000)

------------------
E-MAIL: [email protected]
Leave a comment:

Jules Marchildon replied

22 Jan 2001, 08:57 AM

Hi Semen;

I tried your post above and does nothing??? I am trying to understand
what you want to do. Scroll existing control text/listbox whatever, or
scroll Bitmap vertically? (Bitmap perhaps snapshot of a RTF box).

This code scrolls a Banner horizontally. You can add necessary code
to change to vertically.

Code:

'-----------------------------------------------------------
'     A simple animated banner that is driven by a timer.
'       Another C to PB Conversion By Jules Marchildon
'                     Nov. 5, 1999
'-----------------------------------------------------------

$COMPILE EXE '**Compiled using PBDLL50
$INCLUDE "WIN32API.INC"

'---
GLOBAL szWinName    AS ASCIIZ*20
GLOBAL ghInst       AS LONG
GLOBAL ghWnd        AS LONG

'---
FUNCTION WINMAIN(BYVAL hInstance AS LONG, _
                 BYVAL hPrevInstance AS LONG, _
                 lpszCmdLine AS ASCIIZ PTR, _
                 BYVAL nCmdShow AS LONG) AS LONG


  LOCAL hwnd AS LONG
  LOCAL Msg AS tagMSG
  LOCAL wcl AS WNDCLASSEX

IF ISFALSE(hPrevInstance) THEN
'**Register Parent Window Class
  szWinName ="MyWin"
  wcl.cbSize = sizeof(wcl)
  wcl.hInstance = hInstance
  wcl.lpszClassName = varptr(szWinName)
  wcl.lpfnWndProc = codeptr(WindowFunc)
  wcl.style = 0
  wcl.hIcon = LoadIcon(hInstance, BYVAL %IDI_APPLICATION)
  wcl.hIconSm = %NULL
  wcl.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
  wcl.hbrBackground = GetStockObject(%WHITE_BRUSH)
  wcl.cbClsExtra = 0
  wcl.cbWndExtra = 0
  wcl.lpszMenuName = %NULL
RegisterClassEx wcl
ELSE
    EXIT FUNCTION
END IF
'---

ghInst = hInstance

'---
  hwnd = CreateWindow(szWinName, _
                      "     Todays Special", _
                      %WS_OVERLAPPEDWINDOW , _
                      200, 100, _
                      450, 100, _
                      %NULL, %NULL, ghInst, %NULL)


  ShowWindow hWnd, %SW_SHOW
  UpdateWindow hWnd


    WHILE GetMessage(Msg, %NULL, 0, 0)
        TranslateMessage Msg
        DispatchMessage Msg
    WEND

  FUNCTION = Msg.wParam
END FUNCTION

'------------------------------------------------------------
FUNCTION WindowFunc(BYVAL hWnd AS LONG, _
                    BYVAL Msg AS LONG,BYVAL wParam AS LONG, _
                    BYVAL lParam AS LONG) AS LONG

  LOCAL   hdc     AS LONG
  LOCAL   ps      AS PAINTSTRUCT
  STATIC  tm      AS TEXTMETRIC   'font information
  LOCAL   str     AS ASCIIZ*255
  STATIC  X       AS INTEGER      'current X output location
  STATIC  Y       AS INTEGER      'current Y output location
  LOCAL   hbrush  AS LONG         'handle to virtual window brush
  STATIC  maxX    AS INTEGER      'X screen dimension
  STATIC  maxY    AS INTEGER      'Y Screen dimension
  STATIC  memdc   AS LONG         'handle to virtual window context
  STATIC  hbit    AS LONG         'handle to virtual window bitmap
  STATIC  animdim AS RECT         'size of area to animate

'---
SELECT CASE Msg

    CASE %WM_CREATE

      'start a timer

      If  ISFALSE(SetTimer(hwnd, 1, 50, %NULL))  Then
        MessageBox hwnd, "Timer Error", "Error", %MB_OK
      End If

      'create virtual window
      maxX = GetSystemMetrics(%SM_CXSCREEN)
      maxY = GetSystemMetrics(%SM_CYSCREEN)
      hdc = GetDC(hwnd)
      memdc = CreateCompatibleDC(hdc)
      hbit = CreateCompatibleBitmap(hdc, maxX, maxY)
      SelectObject memdc, hbit
      hbrush = GetStockObject(%WHITE_BRUSH)
      SelectObject memdc, hbrush
      PatBlt memdc,0,0,maxX,maxY, %PATCOPY

      GetTextMetrics hdc, tm
      Y=20
      animdim.nleft   = X
      animdim.ntop    = Y
      animdim.nright  = maxX + X
      animdim.nbottom = tm.tmHeight + Y

      str = "** All Win32 API Computer Books On Sale Now $1.00 ea. **"
      TextOut memdc,X,Y,str,LEN(str)

      ReleaseDC hwnd, hdc
      InvalidateRect hwnd, BYVAL %NULL, 1


    CASE %WM_PAINT

      hdc = BeginPaint(hwnd, ps)

      'copy virtual window to screen
      BitBlt hdc,ps.rcPaint.nleft,ps.rcPaint.ntop, _
             ps.rcPaint.nright-ps.rcPaint.nleft, _ 'width
             ps.rcPaint.nbottom-ps.rcPaint.ntop, _ 'height
             memdc, _
             ps.rcPaint.nleft,ps.rcPaint.ntop, _
             %SRCCOPY

      EndPaint hwnd, ps


    CASE %WM_TIMER    'timer went off - update display

      'move left edge to the right end
      BitBlt memdc,maxX-1,Y,1,tm.tmHeight,memdc,0,Y,%SRCCOPY

      'move remaining image left
      BitBlt memdc,0,Y,maxX-1,tm.tmHeight,memdc,1,Y,%SRCCOPY

      'update
      InvalidateRect hwnd, animdim, 0

    CASE %WM_DESTROY

      DeleteDC memdc
      DeleteObject hbit
      PostQuitMessage 0

    CASE ELSE
         FUNCTION= DefWindowProc(hwnd, Msg, wParam, lParam)
         EXIT FUNCTION

END SELECT
    FUNCTION = 0

END FUNCTION

HTH
Regards,
Jules

Leave a comment:

Semen Matusovski replied

21 Jan 2001, 03:21 AM

This code shows, in which direction I'm moving (not more).
I plan to struggle with CPU time, to add a possibility of pseudo-RTF text (own tags - set color, font) and so on.
Maybe somebody have ideas to improve similar code.

Code:

   #Compile Exe
   Option Explicit
   #Include "win32Api.inc"

   ' --- Change this ----
   $FileBmp = "G:\WinNt\WinNt.Bmp" ' Win2000 Black on %White
   $FileTxt = "sc.bas"
   %Clr1 = %Blue  ' Text Color
   %Clr2 = %Red   ' Text Background (for transparent)
   '---------------------
   
   CallBack  Function DlgProc1
      Dim i As Long, j As Long, hDC As Long

      Select Case CbMsg
         Case %WM_ERASEBKGND
            Function = 1
         Case %WM_USER + 1
            Dim Txt As String
            Open $FileTxt For Binary As #1
            Get$ #1, Lof(1), Txt
            Close #1

            hDC = GetDC(CbHndl)

            Dim rc(2) As Static RECT, hMemBmp(2) As Static Long
            Dim pWidth(2) As Static Long, pHeight(2) As Static Long
            Dim bmi(2) As Static BITMAPINFO
            Dim hMemDC(2) As Static Long

            For i = 0 To 2
               hMemDC(i) = CreateCompatibleDC(hDC)
               If i <= 1 Then
                  GetClientRect CbHndl, rc(i)
               Else
                  DrawText hMemDC(2), ByVal StrPtr(Txt), -1, rc(2), %DT_CALCRECT
               End If
               pWidth(i)  = rc(i).nRight - rc(i).nLeft
               pHeight(i) = rc(i).nBottom - rc(i).nTop
               If i = 2 Then
                  pWidth(2) = pWidth(1)
                  pHeight(2) = Max(pHeight(1), pHeight(2))
               End If
               bmi(i).bmiHeader.biSize = SizeOf(bmi(i).bmiHeader)
               bmi(i).bmiHeader.biWidth = pWidth(i)
               bmi(i).bmiHeader.biHeight = pHeight(i)
               bmi(i).bmiHeader.biPlanes = 1
               bmi(i).bmiHeader.biBitCount = 32
               bmi(i).bmiHeader.biCompression = %BI_RGB
               hMemBmp(i) = CreateDIBSection(hMemDC(i), bmi(i), %DIB_RGB_COLORS, 0, 0, 0)
               GlobalLock hMemBmp(i)
            Next

            SelectObject hMemDC(0), hMemBmp(0)
            SelectObject hMemDC(1), hMemBmp(1)
            BitBlt hMemDC(1), 0, 0, pWidth(1), pHeight(1), hDC, 0, 0, %SRCCOPY

            SelectObject hMemDC(2), hMemBmp(2)
            Dim hBrush As Long
            hBrush = CreateSolidBrush(%Clr2)
            FillRect hMemDC(2), rc(2), hBrush
            DeleteObject hBrush
            SetTextColor hMemDC(2), %Clr1
            SetBkColor hMemDC(2), %Clr2
            DrawText hMemDC(2), ByVal StrPtr(Txt), -1, rc(2), 0
            ReleaseDC CbHndl, hDC
            SetTimer CbHndl, 1, 5, ByVal 0&

         Case %WM_TIMER
            Local pp1 As Single, pp2 As Single, tclr As Long, percent As Double
            Dim k As Long, p1 As Long, p2 As Long
            Dim Bm(2) As BITMAP
            Dim pBits0 As Byte Ptr, pBits1 As Byte Ptr, pBits2 As Byte Ptr

            hDC = GetDC(CbHndl)

            SelectObject hMemDC(2), hMemBmp(2)
            For k = 2 To 0 Step -1
               GetObject hMemBmp(k), SizeOf(bm(k)), bm(k)
               If k = 0 Then
                  pBits0 = bm(k).bmBits
               ElseIf k = 1 Then
                  pBits1 = bm(k).bmBits
               Else
                  pBits2 = bm(k).bmBits + bm(k).bmWidthBytes * (pHeight(2) - 1)
                  tclr = Rgb(@pBits2[2], @pBits2[1], @pBits2[0])
               End If

               Static dwCount As Long
               Dim jj As Long
               jj =  dwCount
               If k = 0 Then
                  For j = pHeight(1) - 1 To 0 Step - 1
                     pp1 = 0.6 * (j + 1) / pHeight(1)
                     pp2 = 1 - pp1
                  
                     Decr jj: If jj < 0 Then jj = pHeight(2) - 1
                     pBits2 = bm(2).bmBits + bm(2).bmWidthBytes * (pHeight(2) - jj - 1)

                     For i = 0 To pWidth(1) - 1
                        If Rgb(@pBits2[2], @pBits2[1], @pBits2[0]) = tclr Then
                           @pBits0[2] = @pBits1[2]
                           @pBits0[1] = @pBits1[1]
                           @pBits0[0] = @pBits1[0]
                        Else
                           @pBits0[2] = ((pp1 * @pBits1[2] + pp2 * @pBits2[2]))
                           @pBits0[1] = ((pp1 * @pBits1[1] + pp2 * @pBits2[1]))
                           @pBits0[0] = ((pp1 * @pBits1[0] + pp2 * @pBits2[0]))
                        End If
                        pBits0 = pBits0 + 4: pBits1 = pBits1 + 4: pBits2 = pBits2 + 4
                     Next
                  Next
                  BitBlt hDC, 0, 0, pWidth(1), pHeight(1), hMemDC(0), 0, 0, %SRCCOPY
               End If
            Next
            ReleaseDC CbHndl, hDC

            Incr dwCount: If dwCount > pHeight(2) Then dwCount = 0
          
         Case %WM_USER + 2, %WM_DESTROY
            For i = 0 To 2
               DeleteObject hMemDC(i)
               GlobalUnlock hMemBmp(i)
               DeleteObject hMemBmp(i)
           Next
      End Select
   End Function
   
   CallBack  Function DlgProc
      Select Case CbMsg
         Case %WM_INITDIALOG
            %ID_START = 101
            %ID_STOP = 102
            Control Add Button, CbHndl, %ID_START, "Start", 200, 10, 110, 14
            Control Add Button, CbHndl, %ID_STOP, "Stop", 200, 30, 110, 14
            
         Case %WM_ERASEBKGND
            Dim rc As RECT, hBmp As Long, hMemDC As Long
            GetClientRect CbHndl, rc
            hMemDC = CreateCompatibleDC(CbWparam)
            hBmp = LoadImage(ByVal %NULL, $FileBmp, %IMAGE_BITMAP, rc.nRight, rc.nBottom, %LR_LOADFROMFILE)
            SelectObject hMemDC, hBmp
            BitBlt CbWparam, 0, 0, rc.nRight, rc.nBottom, hMemDC, 0, 0, %SRCCOPY
            DeleteDC hMemDC
            DeleteObject hBmp
            Function = 1
              
         Case %WM_COMMAND
            Static hDlg1 As Long
            Select Case CbCtl
               Case %ID_START
                  If hDlg1 = 0 Then
                     Dialog New CbHndl, "", 10, 10, 180, 120, %WS_CHILD Or %WS_VISIBLE, %WS_EX_CLIENTEDGE To hDlg1
                     Dialog Show State hDlg1, %SW_HIDE
                     Dialog Show Modeless hDlg1 Call DlgProc1
                     PostMessage hDlg1, %WM_USER + 1, 0, 0
                  End If
               Case %ID_STOP
                  If hDlg1 Then Dialog End hDlg1: hDlg1 = 0
            End Select
            
        Case %WM_DESTROY
           DeleteObject hBmp
            
      End Select
   End Function

   Function PbMain()
     Local hDlg As Long
     Dialog New 0 ,"Hello", , , 320, 160, %WS_CAPTION Or %WS_SYSMENU To hDlg
     Dialog Show Modal hDlg Call DlgProc
  End Function                                                  _

------------------
E-MAIL: [email protected]

Announcement

Leave a comment:

Leave a comment:

Leave a comment:

Leave a comment:

Leave a comment: