Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Media";
Текущий архив: 2004.04.11;
Скачать: [xml.tar.bz2];

Вниз

Непрямоугольная форма на основе TImage   Найти похожие ветки 

 
$tranger ©   (2004-02-06 14:55) [0]

Доброго времени суток, господа программисты. Вопрос на тему "Непрямоугольная форма на основе TImage" старый как Мир, и я находил пару решений в сети, но они у меня не получились. Может подскажите чего-нибудь оригинального (или не очень)?... Спасибо.
P.S.: я пробовал использование shape"ов на пустых местах в TImage - ноль эффекта... Может кто знает почему...


 
$tranger ©   (2004-02-06 14:55) [0]

Доброго времени суток, господа программисты. Вопрос на тему "Непрямоугольная форма на основе TImage" старый как Мир, и я находил пару решений в сети, но они у меня не получились. Может подскажите чего-нибудь оригинального (или не очень)?... Спасибо.
P.S.: я пробовал использование shape"ов на пустых местах в TImage - ноль эффекта... Может кто знает почему...


 
MBo ©   (2004-02-06 16:27) [1]

Для создания непрямоугольной формы нужно сделать SetWindowRgn.
Сам регион же придется создать одной из соответствующих функций.


 
MBo ©   (2004-02-06 16:27) [1]

Для создания непрямоугольной формы нужно сделать SetWindowRgn.
Сам регион же придется создать одной из соответствующих функций.


 
$tranger ©   (2004-02-06 20:30) [2]

Регионами прорисовывать большую и заковыристую картинку очень и очень долго. Я нашел в НЕТЕ код:
type
TForm1 = class(Tform)
Label1: TLabel;
protected
procedure WndProc(var Msg: TMessage); override;
end;
var Form1: TForm1;
implementation
procedure HandleMyMessage(var Msg: TMessage);
begin
if Msg.Msg = wm_MouseMove then
 Form1.Caption := IntToStr(TWMMouse(Msg).XPos)
...
end;
procedure TForm1.WndProc(var Msg: TMessage);
begin
HandleMyMessage(Msg);
inherited WndProc(Msg);
end;
Но он у меня не работает (окно всеравно прямоугольное)... Может кто знает почему


 
$tranger ©   (2004-02-06 20:30) [2]

Регионами прорисовывать большую и заковыристую картинку очень и очень долго. Я нашел в НЕТЕ код:
type
TForm1 = class(Tform)
Label1: TLabel;
protected
procedure WndProc(var Msg: TMessage); override;
end;
var Form1: TForm1;
implementation
procedure HandleMyMessage(var Msg: TMessage);
begin
if Msg.Msg = wm_MouseMove then
 Form1.Caption := IntToStr(TWMMouse(Msg).XPos)
...
end;
procedure TForm1.WndProc(var Msg: TMessage);
begin
HandleMyMessage(Msg);
inherited WndProc(Msg);
end;
Но он у меня не работает (окно всеравно прямоугольное)... Может кто знает почему


 
dmk ©   (2004-02-06 22:05) [3]

Так этот код демонстрирует возможность обработки сообщения, да и только =)


 
dmk ©   (2004-02-06 22:05) [3]

Так этот код демонстрирует возможность обработки сообщения, да и только =)


 
DNS   (2004-02-07 19:23) [4]

Попробуй эту функцию для преобразования BMP в HRGN :

function BitmapToRgn(Image: TBitmap): HRGN;
var
 TmpRgn: HRGN;
 x, y: integer;
 ConsecutivePixels: integer;
 CurrentPixel: TColor;
{$IFDEF DEBUGLOADING}  CreatedRgns: integer;  {$ENDIF}
 CurrentColor: TColor;
 TransparentColor:TColor;
begin
{$IFDEF DEBUGLOADING} CreatedRgns := 0;  {$ENDIF}     // Кол-во созданых регионов

 if (Image.Width = 0) or (Image.Height = 0) then begin Result:= INVALID_HANDLE_VALUE;  exit; end;  // Если че не так - свернемся

 Result := CreateRectRgn(0, 0, Image.Width, Image.Height);  // Создаем регион подходящего размера
{$IFDEF DEBUGLOADING} inc(CreatedRgns); {$ENDIF} // Созданные регионы +1

 TransparentColor:= Image.Canvas.Pixels[0,0]; // Устанавливаем прозрачный цвет

 for y := 0 to Image.Height - 1 do  // Ходим по всей высоте(линии)
   begin
   CurrentColor := Image.Canvas.Pixels[0,y]; // Ставим текущий цвет
   ConsecutivePixels := 1;      //  Пикселей в зоне
   for x := 0 to Image.Width - 1 do    // Ходим по всей длине линии
    begin
     CurrentPixel := Image.Canvas.Pixels[x,y]; // Ставим текущий цвет пикселя

     if CurrentColor = CurrentPixel // Равен ли цвет текущей зоны цвету пикселя
       then
        inc(ConsecutivePixels)  // Если да, то счетчик пикселей зоны увеличиваем
       else
          begin
            // Входим в новую зону
            if CurrentColor = TransparentColor then  // Если новый цвет равен прозрачному
              begin
              TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1); // Временный регион в размер зоны
              CombineRgn(Result, Result, TmpRgn, RGN_DIFF);  // Вырезаем временный
{$IFDEF DEBUGLOADING} inc(CreatedRgns); {$ENDIF} // Созданных регионов +1
              DeleteObject(TmpRgn); // Удаляем временный регион
              end;
            CurrentColor := CurrentPixel; // Меняем текущий цвет зоны
            ConsecutivePixels := 1;  // Пикселей в зоне
          end; // Прозрачность
    end; // Обход по X

    if (CurrentColor = TransparentColor) and (ConsecutivePixels > 0) then   // Текущий цвет прозрачный, и пикселей в зоне > 0
     begin
     TmpRgn := CreateRectRgn(Image.Width-ConsecutivePixels, y, Image.Width, y+1);   // Временный регион в размер зоны
     CombineRgn(Result, Result, TmpRgn, RGN_DIFF);    // Вырезаем временный
{$IFDEF DEBUGLOADING} inc(CreatedRgns); {$ENDIF} // Созданных регионов +1
     DeleteObject(TmpRgn);   // Удаляем временный регион
     end;

   end;
{$IFDEF DEBUGLOADING} MessageBox(0,PChar("Созданно регионов: "+IntToStr(CreatedRgns)),"DEBUGLOADING"#0,0); {$ENDIF}
end;


Я сейчас просто тоже компонент такой пишу - другу на курсовик...
Сам пример тут где - то на сайте... Но толька для черно-белой картинки, а этот чуточку изменен.


 
DNS   (2004-02-07 19:23) [4]

Попробуй эту функцию для преобразования BMP в HRGN :

function BitmapToRgn(Image: TBitmap): HRGN;
var
 TmpRgn: HRGN;
 x, y: integer;
 ConsecutivePixels: integer;
 CurrentPixel: TColor;
{$IFDEF DEBUGLOADING}  CreatedRgns: integer;  {$ENDIF}
 CurrentColor: TColor;
 TransparentColor:TColor;
begin
{$IFDEF DEBUGLOADING} CreatedRgns := 0;  {$ENDIF}     // Кол-во созданых регионов

 if (Image.Width = 0) or (Image.Height = 0) then begin Result:= INVALID_HANDLE_VALUE;  exit; end;  // Если че не так - свернемся

 Result := CreateRectRgn(0, 0, Image.Width, Image.Height);  // Создаем регион подходящего размера
{$IFDEF DEBUGLOADING} inc(CreatedRgns); {$ENDIF} // Созданные регионы +1

 TransparentColor:= Image.Canvas.Pixels[0,0]; // Устанавливаем прозрачный цвет

 for y := 0 to Image.Height - 1 do  // Ходим по всей высоте(линии)
   begin
   CurrentColor := Image.Canvas.Pixels[0,y]; // Ставим текущий цвет
   ConsecutivePixels := 1;      //  Пикселей в зоне
   for x := 0 to Image.Width - 1 do    // Ходим по всей длине линии
    begin
     CurrentPixel := Image.Canvas.Pixels[x,y]; // Ставим текущий цвет пикселя

     if CurrentColor = CurrentPixel // Равен ли цвет текущей зоны цвету пикселя
       then
        inc(ConsecutivePixels)  // Если да, то счетчик пикселей зоны увеличиваем
       else
          begin
            // Входим в новую зону
            if CurrentColor = TransparentColor then  // Если новый цвет равен прозрачному
              begin
              TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1); // Временный регион в размер зоны
              CombineRgn(Result, Result, TmpRgn, RGN_DIFF);  // Вырезаем временный
{$IFDEF DEBUGLOADING} inc(CreatedRgns); {$ENDIF} // Созданных регионов +1
              DeleteObject(TmpRgn); // Удаляем временный регион
              end;
            CurrentColor := CurrentPixel; // Меняем текущий цвет зоны
            ConsecutivePixels := 1;  // Пикселей в зоне
          end; // Прозрачность
    end; // Обход по X

    if (CurrentColor = TransparentColor) and (ConsecutivePixels > 0) then   // Текущий цвет прозрачный, и пикселей в зоне > 0
     begin
     TmpRgn := CreateRectRgn(Image.Width-ConsecutivePixels, y, Image.Width, y+1);   // Временный регион в размер зоны
     CombineRgn(Result, Result, TmpRgn, RGN_DIFF);    // Вырезаем временный
{$IFDEF DEBUGLOADING} inc(CreatedRgns); {$ENDIF} // Созданных регионов +1
     DeleteObject(TmpRgn);   // Удаляем временный регион
     end;

   end;
{$IFDEF DEBUGLOADING} MessageBox(0,PChar("Созданно регионов: "+IntToStr(CreatedRgns)),"DEBUGLOADING"#0,0); {$ENDIF}
end;


Я сейчас просто тоже компонент такой пишу - другу на курсовик...
Сам пример тут где - то на сайте... Но толька для черно-белой картинки, а этот чуточку изменен.


 
Intell ©   (2004-02-07 19:30) [5]

Всем кому интересно, могу выслать готовый пример (с исходником)- Ипользование Image как формы для приложения.

Пишите на мыло:
intell_com@mail.ru


 
Intell ©   (2004-02-07 19:30) [5]

Всем кому интересно, могу выслать готовый пример (с исходником)- Ипользование Image как формы для приложения.

Пишите на мыло:
intell_com@mail.ru


 
$tranger ©   (2004-02-07 20:19) [6]

DMK, упс... (я не знал)


 
$tranger ©   (2004-02-07 20:19) [6]

DMK, упс... (я не знал)


 
Mihey ©   (2004-02-07 22:44) [7]

> Регионами прорисовывать большую и заковыристую картинку очень и очень долго. Я нашел в НЕТЕ код:

Можно и по-быстрому. Я тоже сначала использовать один способ, он был достаточно медленный, а потом нашёл другой, вполне приемлимый.


 
Mihey ©   (2004-02-07 22:44) [7]

> Регионами прорисовывать большую и заковыристую картинку очень и очень долго. Я нашел в НЕТЕ код:

Можно и по-быстрому. Я тоже сначала использовать один способ, он был достаточно медленный, а потом нашёл другой, вполне приемлимый.



Страницы: 1 вся ветка

Форум: "Media";
Текущий архив: 2004.04.11;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.5 MB
Время: 0.033 c
4-1078654631
GrayFace
2004-03-07 13:17
2004.05.09
Как получать и изменять тексты кнопок OK , Cancel и т.д.


11-1068287974
SPeller
2003-11-08 13:39
2004.05.09
Глюки SyntaxEdit а


3-1081941938
SergeyB
2004-04-14 15:25
2004.05.09
Не генерируется событие TDatabase.OnAfterDisconnect


3-1081771449
Санёк
2004-04-12 16:04
2004.05.09
Как узнать имя домена в MS SQL Server ?


14-1082051532
pepers
2004-04-15 21:52
2004.05.09
Разработка приложения





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский