четверг, 21 октября 2010 г.

Модуль титров Star Wars


Cвоего рода about, фишка для программы. Код достаточно прост, в качестве хэндла можете использовать хэндл даже панельки:
//------------------------------------------
// TITm
// Модуль титров StarWars
// Author: Бадло Сергей Григорьевич
// H-page: http://raxp.radioliga.com
// Cистемные требования: Win ALL
//------------------------------------------


unit titm;

interface

uses Windows,Classes,Graphics;

procedure scrolltxt;                      // прокрутка-
procedure tinit(h:thandle; tr: trect); // инициализация-

var txt     : tstringlist;
    dc,memDC: hdc;
    rect    : trect;
    bmp     : HBITMAP;
    oldObj  : HGDIOBJ;
    size    : TSize;
    m_Font,oldFont    : hfont;
    nPosX,nPosY,scrpos: integer;
    ten: boolean;

implementation

procedure scrolltxt;
const speed=1;
var nWidth,nHeight,y,nOffset,i:integer;
    nScale:double;
begin
 if ten then begin // триггер прокрутки

 memDC:= CreateCompatibleDC(dc);
 if memDC <> 0 then
  try
   bmp:= CreateCompatibleBitmap(dc,rect.Right,rect.Bottom);
   if bmp <> 0 then
    try
      oldObj:= SelectObject(memDC,bmp);
      if oldObj <> 0 then
       try
        SetTextColor(memDC,RGB(0,255,0));
        SetBkColor(memDC,RGB(0,0,0));
        SetBkMode(memDC,TRANSPARENT);
        oldFont:= SelectObject (memDC, m_font);
        //black
        BitBlt(DC,0,0,rect.Right,rect.Bottom,0,0,0, BLACKNESS);

     for i:=0 to txt.Count-1 do begin
         //set position
         GetTextExtentPoint32 (memDC, PChar(txt[i]), Length(txt[i]), size);
         nPosY:= scrpos + (i * size.cy);
         if (nPosY > 0) then begin
           nPosX:= (rect.Right div 2) - (size.cx div 2);
           //гашение цвета
           if rect.Bottom < 255 then nPosY:=(255-rect.Bottom)+nPosY;
           if (nPosY > 255) then SetTextColor(memDC,RGB(255, 255, 255))
            else //SetTextColor(memDC,RGB(0, nPosY,0));
            SetTextColor(memDC,RGB(nPosY, nPosY, nPosY));
           //print-
           if rect.Bottom < 255 then nPosY:=nPosY-255+rect.Bottom;
           TextOut(memDC,nPosX, nPosY, pchar(txt[i]),Length(txt[i]));
      end else begin
           if i=txt.Count-1 then
            scrpos:= rect.Bottom;
          end;
    end;

        nWidth := rect.Right;
        nHeight:= rect.Bottom;
        for y:=5 to nHeight do begin
         nScale := y/(nHeight-90); //наклон-
         nOffset:= trunc((nWidth - nWidth*nScale)/2);
         StretchBlt(dc,nOffset, y, trunc(nWidth*nScale), 1, memDC, 0, y, nWidth, 1, SRCPAINT);
        end;
        SelectObject (memDC, oldFont);
        scrpos:= scrpos - speed;
       finally selectObject(memDC, oldOBJ) end
    finally DeleteObject(bmp) end
  finally DeleteDC (memDC) end;
 end else scrpos:= rect.Bottom
end;

procedure tinit(h:thandle; tr: trect);
begin
 // загрузка list
 txt:=tstringlist.Create;
 txt.Add('Давным - давно');
 txt.Add('в далекой галактике...');
 txt.Add('');
 txt.Add('');
 txt.Add('ВЛАСТВОВАЛИ');
 txt.Add('ЭНТРОПИЯ и ХАОС');
 txt.Add('');
 txt.Add('прошли тысячелетия');
 txt.Add('и наступил ВЕК...');
 txt.Add('');
 txt.Add('- RAMedia RC -');
 txt.Add('Control for PC');
 txt.Add('VER 2.0');
 txt.Add('');
 txt.Add('Supported OS:');
 txt.Add('Win9x / 2k / XP');
 txt.Add('');
 txt.Add('---');
 txt.Add('Author');
 txt.Add('- Badlo Sergej -');
 txt.Add('RA © 2004 forever');
 txt.Add('');
 txt.Add('');
 txt.Add('Send your offers');
 txt.Add('and');
 txt.Add('remarks');
 txt.Add('http://raxp.radioliga.com');
 txt.Add('');
 txt.Add('...и да прибудет с Вами');
 txt.Add('СИЛА!');
 //установки-
 rect  := tr;
 scrpos:= rect.Bottom;
 dc:= getdc(h);
 //динамически-
 m_Font:=CreateFont(rect.Right*16 div 350,0,0,0,0,0,0,0,0,0,0,0,0,PChar('arial cyr'))
end;
//============================

end.

Комментариев нет:

Отправить комментарий

В комментариях уважайте собеседника, внимательно читайте посты и не додумывайте. Просьбы и предложения из разряда: «можно ваш Skype/Viber/телефон», «напишите мне в vk/FB», а также другие им подобные — игнорируются. Выход новых версий ПО, внешняя ссылка, переставшая работать с течением времени и т.п. не является основанием для претензий. Желающие спокойно подискутировать и высказаться — Welcome. Желающие спонсировать блог — Donate. Нарушение этих простых правил ведет к бану и удалению комментариев без предупреждения.