No announcement yet.

Text scroller

  • Filter
  • Time
  • Show
Clear All
new posts

  • Text scroller

    Guys --
    I want to display scrolling "what's new" text.
    How to do is more or less clear, but requires a lot of code.
    Maybe somebody already did long-text scroller ? Better, RTF-format on bitmap background.

    E-MAIL: [email protected]

  • #2
    This is kind of klunky, but it works, in a game program I'm
    writing. Each time a "newsworthy event" occurs, it is
    described in NW$. SUB RunNewsTicker is called frequently,
    and adds the NW$ item to an array, displayed as scrolling items
    in a listbox. You could simply read in NW$ items from an array or
    DATA statements. I also have a horizontal stock ticker running
    at the same time (code for that not shown here).


    GLOBAL NoNews$, NW$

    SUB RunNewsTicker
    CALL MoveNews()
    IF NoNews$="" THEN CALL UpdateNewsList()


    ' ----------------------------------------------------------
    SUB UpdateNewsList()


    ' Clear the list box list in the "News Box" ticker
    FOR x = 20 TO 35
    LISTBOX ADD ghDlg, %FORM1_NEWSLISTBOX, NewsTicker$(x)

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

    ' ----------------------------------------------------------
    SUB MoveNews() 'Add NW$ (new news item) to array of 40 news items, for display in Listbox control

    LOCAL Duplic AS LONG

    IF NW$="" THEN
    EXIT SUB 'No new news to add to array
    END IF
    FOR CT&=1 TO 39
    IF NW$=NewsTicker$(CT&) THEN Duplic&=1 'Found duplicate, so don't repeat item in array
    NEXT CT&
    IF Duplic=1 THEN
    END IF

    FOR x = 1 TO 39





    • #3
      Not exactly what you ask for, but still. The Virtual Listbox I
      posted to sorce code a while ago can be used for this purpose.
      Simply strip away the possibility to select lines and you'll have
      a smooth and quite fast text scroller for unlimited sized text
      (as long as you keep the text in a global array, that is)



      • #4
        Thanks. I didn't want, but went by hard way (combining memory DIB sections).
        Initial variant already done, but I want some add-ons.
        Probably, tomorrow I'll post.

        E-MAIL: [email protected]


        • #5
          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.
             #Compile Exe
             Option Explicit
             #Include ""
             ' --- 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)
                            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)
                      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
                            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]
                                     @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
                            BitBlt hDC, 0, 0, pWidth(1), pHeight(1), hMemDC(0), 0, 0, %SRCCOPY
                         End If
                      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)
                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]


          • #6
            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.

            '     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)
     = 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
                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
              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
                  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, _
                  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
                  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

            Best regards


            • #7
              Jules --
              > I tried your post above and does nothing???

              Under which OS ? Did you correct pathes ?

              (I wrote under Win2000)

              E-MAIL: [email protected]