Announcement

**Mike Jenkins** · 19 Jan 2001, 04:56 PM

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

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

**Borje Hagsten** · 19 Jan 2001, 05:03 PM

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)

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

**Semen Matusovski** · 20 Jan 2001, 01:42 PM

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]

**Semen Matusovski** · 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]

**Jules Marchildon** · 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

**Semen Matusovski** · 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]

Announcement

Text scroller

Text scroller

Comment

Comment

Comment

Comment

Comment

Comment