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

Вниз

Цветной JPEG -> Серый Bitmap   Найти похожие ветки 

← →
servs   (2003-06-24 15:31) [0]

Как сделать сабж?

У меня есть цветное изображение в TJPEGImage, мне необходимо отобразить его в градациях серого в TImage.

← →
MBo   (2003-06-24 16:21) [1]

преобразовать в битмап, затем пробежать по пикселам (через Scanline).

← →
AlexT1000   (2003-06-24 16:30) [2]

TJPEGImage.Grayscale := true

← →
Mihey   (2003-06-24 16:53) [3]

> TJPEGImage.Grayscale := true

А потом преобразовать в битмап.

← →
AlexT1000   (2003-06-24 17:06) [4]

>> Mihey
А потом преобразовать в битмап.

не уверен.
я конечно так никогда не делал , но думаю просто

TJPEGImage.LoadFromFile
TJPEGImage.Grayscale := true
Image.Picture.Assign(TJPEGImage);

← →
servs   (2003-06-25 17:35) [5]

>AlexT1000 ©
Просто не получаеться. Вот этот код у меня уже был:
FJPEGImage.LoadFromStream(FStream);
FJPEGImage.Grayscale := FGray;
FDisplayImage.Picture.Assign(FJPEGImage);

Картинка отображаеться, но цветная ;(

>Mihey ©
Я с графикой не работал раньше. Что нужно дописать?

← →
icWasya   (2003-06-25 17:48) [6]

я делаю так
сначала вспомогательный юнит

unit UGrayPal;

interface
uses Windows;

function GrayPal:HPalette;
function IsGrayPal(Palette:HPalette):Boolean;
function BWPal:HPalette;OverLoad;
function BWPal(Black,White:LongWord):HPalette;OverLoad;

implementation
var MaxLogPal:TMaxLogPalette;LogPal:TLogPalette Absolute MaxLogPal;
MinLogPal:packed record
palVersion: Word;
palNumEntries: Word;
palPalEntry: array [0..1] of TPaletteEntry;
end;
_2LogPal:TLogPalette Absolute MinLogPal;


function GrayPal:HPalette;
begin
Result := CreatePalette(LogPal);
end;

function BWPal:HPalette;
begin
Result := CreatePalette(_2LogPal);
end;

function BWPal(Black,White:LongWord):HPalette;
var
MinLogPal:packed record
palVersion: Word;
palNumEntries: Word;
palPalEntry: array [0..1] of TPaletteEntry;
end;
_2LogPal:TLogPalette Absolute MinLogPal;

begin

MinLogPal.palNumEntries :=2;
MinLogPal.palVersion :=$300;
with MinLogPal.palPalEntry[1] do begin
peRed :=GetRValue(Black);
peGreen :=GetGValue(Black);
peBlue :=GetBValue(Black);
peFlags :=0;
end;
with MinLogPal.palPalEntry[0] do begin
peRed :=GetRValue(White);
peGreen :=GetGValue(White);
peBlue :=GetBValue(White);
peFlags :=0;
end;

Result := CreatePalette(_2LogPal);
end;

function IsGrayPal(Palette:HPalette):Boolean;
var
TestLogPal: TMaxLogPalette;
LogPal: TLogPalette Absolute TestLogPal;
var I: Integer;

begin
FillChar(TestLogPal,SizeOf(TestLogPal),0);
Result:=False;
GetPaletteEntries(Palette, 0, 256 ,LogPal);
for I:=0 to 255 do with TestLogPal.palPalEntry[I] do begin
if peRed <>I then Exit;
if peGreen <>I then Exit;
if peBlue <>I then Exit;
//if peFlags <>0 then Exit;
end;
Result:=True;
end;

procedure InitPal;
var I:Integer;
begin
MaxLogPal.palNumEntries :=256;
MaxLogPal.palVersion :=$300;

for I:=0 to 255 do with MaxLogPal.palPalEntry[I] do begin
peRed :=I; peGreen :=I; peBlue :=I; peFlags :=0;
end;

MinLogPal.palNumEntries :=2;
MinLogPal.palVersion :=$300;
with MinLogPal.palPalEntry[1] do begin
peRed :=0; peGreen :=0; peBlue :=0; peFlags :=0;
end;
with MinLogPal.palPalEntry[0] do begin
peRed :=255; peGreen :=255; peBlue :=255; peFlags :=0;
end;
end;

initialization
InitPal;

end.


затем


var B:TBitmap;
...
FJPEGImage.LoadFromStream(FStream);

B:=TBitmap.Create;
try
B.PixelFormat:=pf8bit;
B.Witdh:=FJPEGImage.Width;
B.Height:=FJPEGImage.Height;
B.Palette:=UGrayPal.GrayPal;

B.Canvas.Draw(0,0,FJPEGImage);

( B) я делаю так
сначала вспомогательный юнит

unit UGrayPal;

interface
uses Windows;

function GrayPal:HPalette;
function IsGrayPal(Palette:HPalette):Boolean;
function BWPal:HPalette;OverLoad;
function BWPal(Black,White:LongWord):HPalette;OverLoad;

implementation
var MaxLogPal:TMaxLogPalette;LogPal:TLogPalette Absolute MaxLogPal;
MinLogPal:packed record
palVersion: Word;
palNumEntries: Word;
palPalEntry: array [0..1] of TPaletteEntry;
end;
_2LogPal:TLogPalette Absolute MinLogPal;


function GrayPal:HPalette;
begin
Result := CreatePalette(LogPal);
end;

function BWPal:HPalette;
begin
Result := CreatePalette(_2LogPal);
end;

function BWPal(Black,White:LongWord):HPalette;
var
MinLogPal:packed record
palVersion: Word;
palNumEntries: Word;
palPalEntry: array [0..1] of TPaletteEntry;
end;
_2LogPal:TLogPalette Absolute MinLogPal;

begin

MinLogPal.palNumEntries :=2;
MinLogPal.palVersion :=$300;
with MinLogPal.palPalEntry[1] do begin
peRed :=GetRValue(Black);
peGreen :=GetGValue(Black);
peBlue :=GetBValue(Black);
peFlags :=0;
end;
with MinLogPal.palPalEntry[0] do begin
peRed :=GetRValue(White);
peGreen :=GetGValue(White);
peBlue :=GetBValue(White);
peFlags :=0;
end;

Result := CreatePalette(_2LogPal);
end;

function IsGrayPal(Palette:HPalette):Boolean;
var
TestLogPal: TMaxLogPalette;
LogPal: TLogPalette Absolute TestLogPal;
var I: Integer;

begin
FillChar(TestLogPal,SizeOf(TestLogPal),0);
Result:=False;
GetPaletteEntries(Palette, 0, 256 ,LogPal);
for I:=0 to 255 do with TestLogPal.palPalEntry[I] do begin
if peRed <>I then Exit;
if peGreen <>I then Exit;
if peBlue <>I then Exit;
//if peFlags <>0 then Exit;
end;
Result:=True;
end;

procedure InitPal;
var I:Integer;
begin
MaxLogPal.palNumEntries :=256;
MaxLogPal.palVersion :=$300;

for I:=0 to 255 do with MaxLogPal.palPalEntry[I] do begin
peRed :=I; peGreen :=I; peBlue :=I; peFlags :=0;
end;

MinLogPal.palNumEntries :=2;
MinLogPal.palVersion :=$300;
with MinLogPal.palPalEntry[1] do begin
peRed :=0; peGreen :=0; peBlue :=0; peFlags :=0;
end;
with MinLogPal.palPalEntry[0] do begin
peRed :=255; peGreen :=255; peBlue :=255; peFlags :=0;
end;
end;

initialization
InitPal;

end.


затем


var B:TBitmap;
...
FJPEGImage.LoadFromStream(FStream);

B:=TBitmap.Create;
try
B.PixelFormat:=pf8bit;
B.Witdh:=FJPEGImage.Width;
B.Height:=FJPEGImage.Height;
B.Palette:=UGrayPal.GrayPal;

B.Canvas.Draw(0,0,FJPEGImage);

FDisplayImage.Picture.Assign(B);
finally
B.Free;
end;



← →
servs   (2003-06-27 18:50) [7]

Спасибо, попробую.

← →
Fenik   (2003-06-27 21:04) [8]

Переводишь сначала в Bitmap, а потом пропускаешь через процедуру:

procedure GrayBmp(Bitmap: TBitmap);
var n: Byte;
x, y: Integer;
Dest: pRGBTriple;
begin
Bitmap.PixelFormat := pf24Bit;
for y := 0 to Bitmap.Height - 1 do begin
Dest := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do begin
with Dest^ do begin
n := Trunc((rgbtBlue + rgbtGreen + rgbtRed)/3);
rgbtBlue := n;
rgbtGreen := n;
rgbtRed := n;
end;
( Dest) Переводишь сначала в Bitmap, а потом пропускаешь через процедуру:

procedure GrayBmp(Bitmap: TBitmap);
var n: Byte;
x, y: Integer;
Dest: pRGBTriple;
begin
Bitmap.PixelFormat := pf24Bit;
for y := 0 to Bitmap.Height - 1 do begin
Dest := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do begin
with Dest^ do begin
n := Trunc((rgbtBlue + rgbtGreen + rgbtRed)/3);
rgbtBlue := n;
rgbtGreen := n;
rgbtRed := n;
end;
Inc(Dest);
end;
end;
end;


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

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

Наверх




Память: 0.47 MB
Время: 0.012 c
7-89588
aj_ua
2003-08-14 17:07
2003.10.27
kak s konsoli vygruzit ICQ ???

3-89151
Bless
2003-10-07 09:11
2003.10.27
Что означает такая ошибка?

1-89241
Kiril
2003-10-14 23:28
2003.10.27
function FileGetDate(Handle: Integer): Integer;

14-89484
Knight
2003-10-06 13:54
2003.10.27
Снова об интуиции...

14-89544
Mystic
2003-10-08 12:42
2003.10.27
Забавный глюк :)




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
Английский Французский Немецкий Итальянский Португальский Русский Испанский