Бегущая строка на VB. Условности VB и загрузка процессора.

[Nikonik]

Понадобилось мне сделать "полоску".. фигню такую как в The Bat - ленточка новостей.. много искал по инету и форуму о бегущих строках.. нашел два решения: DrawText и Label.Left -= sdvig

Но в обоих возникли траблы:
как оказалось VB не может задвинуть элемент дальше чем на 4000(hex) твипов. А у меня строка зачасутю значительно длиней.
Строка просто зависает и не движется несмотря на операцию.

DrawText же грузит процессор как слон.. скачанный мною sample грузил на 90%, я немного оптимизировал - и теперь грузит на 20-30%, но все равно это очень много.

У ког оесть, какие идеи?

[keks-n]

http://www.vbstreets.ru/ActiveX/GUI/66197.aspx

[uhm]

Как вариант (не знаю, может, плохой) - Сделать Label, и по таймеру присваивать Label.Caption значение Mid$(строка_текста, старт, длина). Старт опять же по таймеру увеличивается на 1. Чтобы корректно вычислить длину, можно использовать шрифт с фиксированной шириной

[keks-n]

Чтобы корректно вычислить длину, можно использовать шрифт с фиксированной шириной

Не обязательно. Есть такая фича у формы и у пикчербокса, как TextWidth. Выдаёт ширину символа для сопоставленного шрифта в сопоставленных единицах измерения

[Nikonik]

http://www.vbstreets.ru/ActiveX/GUI/66197.aspx

это OCX.. без сорсов.. по виду похоже что используются все тоже Draw API.. в любом случае - я не могу таскать за проектом OCX.
Кроме того - стоило мне увеличить в компоненте размер шрифта как буквы начали наезжать друг на друга.

Как вариант (не знаю, может, плохой) - Сделать Label, и по таймеру присваивать Label.Caption значение Mid$(строка_текста, старт, длина). Старт опять же по таймеру увеличивается на 1. Чтобы корректно вычислить длину, можно использовать шрифт с фиксированной шириной

Ну я рассматривал этот вариант, но тогда нет плавности...при нормальном шрифте вообще невозможно толком посчитать, а моноширные шрифты конечно слишком некрасивы.

[NashRus]

покажи как это грузит процессор.

[Nikonik]

Вот

[NashRus]

прикол код покажи, который грузит.

[Роман-вб]

Nikonik
юморист, однако

[IIIypuk]

Вот и начинается флуд

Я строку делал просто вставляя символы как картинки в picturebox(align = bottom) и отрисовывал по таймеру, причем сдвигал часть изображения (напр, с left = 20 width = 100 на left = 0), а в конце подрисовывал часть символа или весь символ. Происходило это все по таймеру, поэтому после отладки можно было нармально найти подходящий интервал. Загруженность не превышала 5% (2.8 (2.1) GHz), что зависело от инетрвала конечно =)

К сожалению, не нашел тот проект, в котором применял.

[keks-n]

5% (2.8 (2.1) GHz)

Это жрёт 100 MHz... На ОДНУ бегущую строку. То есть 4 таких сожрут ВСЕ ресурсы Intel Celeron 433MHz. И это по твоему нормально!? Интервейс не должен использовать столько ресурсов для фоновой работы. Он может жрать ресурсы, когда таскают форму, её элементы, что-то там нажимают, показывается новое окно, т. е. идёт активная перерисовка. А за такой вот "хороший код", мало кто скает спасибо...

[alibek]

Это жрёт 100 MHz... На ОДНУ бегущую строку. То есть 4 таких сожрут ВСЕ ресурсы Intel Celeron 433MHz.

Забавная арифметика.
Т.е. две запущенны 16-разрядные программы полностью используют 32-разрядную операционную систему?

[keks-n]

alibek
Я тебя не совсем понял. 5% от 2.1 GHz Это приблизительно 100MHz.Четыре раза-400MHz. Т. е. столько требуется для норомальной работы 4 таких бегущих строчек. Т. е. 433Mhz проц будет грузиться из-за них почти на 100%.

А вот и код(хоть и кривоватый), который проц не грузитъ:

Код: Выделить всё


Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateFontA Lib "gdi32" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Const RunningText As String = "Бегущая строка"
Dim MemDC As Long

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Sub Form_Load()
Dim MemBMP As Long, rc As RECT, hFont As Long
MemDC = CreateCompatibleDC(0)
MemBMP = CreateCompatibleBitmap(Me.hdc, Me.TextWidth(RunningText) + 40, _
Me.TextHeight(RunningText))
SelectObject MemDC, MemBMP
rc.Right = Me.TextWidth(RunningText) + 40
rc.Bottom = Me.TextHeight(RunningText)
FillRect MemDC, rc, CreateSolidBrush(Me.BackColor)
With Me.Font
hFont = CreateFontA(.Size, 0, 0, 0, .Weight, .Italic, .Underline, .Strikethrough, .Charset, 0, 0, 2, 0, .Name)
End With
DeleteObject SelectObject(MemDC, hFont)

SetBkMode MemDC, 1
TextOut MemDC, 0, 0, RunningText, Len(RunningText)
End Sub

Private Sub Timer1_Timer()
Static CurPos As Long
CurPos = CurPos - 5
If CurPos < -Me.TextWidth(RunningText) Then CurPos = Me.ScaleWidth + Me.TextWidth(RunningText)

BitBlt Me.hdc, CurPos, 0, Me.TextWidth(RunningText) + 40, _
Me.TextHeight(RunningText), _
MemDC, 0, 0, vbSrcCopy
End Sub


ScaleMode у формы=3

[alibek]

А мне вот кажется, что с четырех бегущих 433MHz процессор будет грузится процентов на 30, не больше.

[Nikonik]

keks-n
Спасибо, мне кажется из этого можно сделать работающую строку.
(сейчас у меня черный прямоугольничек перемещается)

насчет ваших спорос о суммарности загрузки:
можно реализовать многопоточность.. и тогда точно будет не сумма..
по отдельности - чисто из наблюдений:
одна полосочка: 20%
три полосочки: 30%
шесть полосочек: 40%

[Kovu]

Одна полосочка 20%....а у меня плеер работающий жрёт 2-8%...

[keks-n]

Nikonik
Мдя... Фишка в том, что BackColor у тебя-не RGB. Поставь не из системных цветов, а из палитры.

[keks-n]

Всё гениальное просто:

Код: Выделить всё

Option Explicit
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Const RunningText = "Бегущая строка"

Private Sub Form_Load()
Dim hRgn As Long
Const sText = "Click Here!"
Picture1.Top=0
Picture1.FontName = "Arial"
Picture1.FontSize = 16
Picture1.BackColor = vbRed
Picture1.Width = Picture1.TextWidth(RunningText)
Picture1.Height = Picture1.TextHeight(RunningText)
BeginPath Picture1.hdc
TextOut Picture1.hdc, 0, 0, RunningText, Len(RunningText)
EndPath Picture1.hdc
hRgn = PathToRegion(Picture1.hdc)
SetWindowRgn Picture1.hWnd, hRgn, True
DeleteObject hRgn
Timer1_Timer
End Sub


Private Sub Timer1_Timer()
Static CurPos As Long
CurPos = CurPos - 50
If CurPos < -Picture1.Width Then CurPos = Me.ScaleWidth + Picture1.Width

Picture1.Left = CurPos
End Sub

На форму таймер и пикчербокс.

[IIIypuk]

Насчет примера выше. Пикчерьок при перемещении может мерцать на слабых компах. Поставил интервал 1, начинает сильно мерцать.

5% (2.8 (2.1) GHz)

Это жрёт 100 MHz... На ОДНУ бегущую строку. То есть 4 таких сожрут ВСЕ ресурсы Intel Celeron 433MHz. И это по твоему нормально!? Интервейс не должен использовать столько ресурсов для фоновой работы. Он может жрать ресурсы, когда таскают форму, её элементы, что-то там нажимают, показывается новое окно, т. е. идёт активная перерисовка. А за такой вот "хороший код", мало кто скает спасибо...

1. Я не уверен, что не было включено что то еще. Я помню что смотрел, но сколько потребляет именно полоса, меня тогда не интересовало. Я проверял, чтоб не жрало слишком много на настройках выше средних.
2. Шрифт у меня был графический, что придает красоту, А не обычные стандартные. Потому можно было поиграть еще с тенями и т.п., что не отражалось на изменении скорости работы.

[keks-n]

Кто мешает, вместо TextOut, сделать BitBlt? Тогда можно и графический шрифт сделать.(Это я про предыдущий, а в этом, просто отрендерить всю строку на пикчебокс, без изменения формы оного, и двигать.)

[IIIypuk]

keks-n, я это и имел ввиду.