Announcement

Collapse
No announcement yet.

Text scroller

Collapse
X
 
  • 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()
    NoNews$=""

    END SUB

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

    LOCAL x AS LONG

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

    END SUB
    ' ----------------------------------------------------------

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

    LOCAL x AS LONG
    LOCAL CT AS LONG
    LOCAL Duplic AS LONG

    IF NW$="" THEN
    NoNews$="Y"
    EXIT SUB 'No new news to add to array
    END IF
    Duplic&=0
    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
    NW$=""
    EXIT SUB
    END IF

    FOR x = 1 TO 39
    NewsTicker$(x)=NewsTicker$(x+1)
    NEXT

    NewsTicker$(40)=NW$
    NW$=""

    END SUB

    ------------------

    Comment


    • #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)


      ------------------

      Comment


      • #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]

        Comment


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

          Comment


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

            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


            Best regards
            Jules
            www.rpmarchildon.com

            Comment


            • #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]

              Comment

              Working...
              X