Delphi: string encryption method and base64 - delphi

Please suggest me a good string encryption method. Not XOR, it isn't strong enough.
Can I use Base64 to represent the encrypted string, but without "=" on the string's end? I can add it manually. Is it normal? That is a user will use Base64 without "=" in a program, and I will add it. I do not want to have a view with '=', it isn't nice :)
Thanks!!!

Here's one encryption library: http://www.cityinthesky.co.uk/opensource/dcpcrypt
Yes, you can show a base64 string without the '=' sign on the end. You just need to make sure that when you pass the value to a method the method is smart enough to add it back on before attempting the decrypt. This is a pretty common scenario.

heres a function (or a couple of functions) to encode and decode strings you can use, you can call it using Base64Encode('string to be encoded') and Base64Decode('string to be decoded') hope this helps.
const
B64: array[0..63] of byte= (65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
81,82,83,84,85,86,87,88,89,90,97,98,99,100,101,102,103,104,105,106,107,108,
109,110,111,112,113,114,115,116,117,118,119,120,121,122,48,49,50,51,52,53,
54,55,56,57,43,47);
function B64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
var
i, iptr, optr: integer;
Input, Output: PByteArray;
begin
Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
iptr:= 0; optr:= 0;
for i:= 1 to (Size div 3) do
begin
Output^[optr+0]:= B64[Input^[iptr] shr 2];
Output^[optr+1]:= B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr+1] shr 4)];
Output^[optr+2]:= B64[((Input^[iptr+1] and 15) shl 2) + (Input^[iptr+2] shr 6)];
Output^[optr+3]:= B64[Input^[iptr+2] and 63];
Inc(optr,4); Inc(iptr,3);
end;
case (Size mod 3) of
1: begin
Output^[optr+0]:= B64[Input^[iptr] shr 2];
Output^[optr+1]:= B64[(Input^[iptr] and 3) shl 4];
Output^[optr+2]:= byte('=');
Output^[optr+3]:= byte('=');
end;
2: begin
Output^[optr+0]:= B64[Input^[iptr] shr 2];
Output^[optr+1]:= B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr+1] shr 4)];
Output^[optr+2]:= B64[(Input^[iptr+1] and 15) shl 2];
Output^[optr+3]:= byte('=');
end;
end;
Result:= ((Size+2) div 3) * 4;
end;
function Base64Encode(const Value: AnsiString): AnsiString;
begin
SetLength(Result,((Length(Value)+2) div 3) * 4);
B64Encode(#Value[1],#Result[1],Length(Value));
end;
function B64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint;
var
i, j, iptr, optr: integer;
Temp: array[0..3] of byte;
Input, Output: PByteArray;
begin
Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
iptr:= 0; optr:= 0;
Result:= 0;
for i:= 1 to (Size div 4) do
begin
for j:= 0 to 3 do
begin
case Input^[iptr] of
65..90 : Temp[j]:= Input^[iptr] - Ord('A');
97..122: Temp[j]:= Input^[iptr] - Ord('a') + 26;
48..57 : Temp[j]:= Input^[iptr] - Ord('0') + 52;
43 : Temp[j]:= 62;
47 : Temp[j]:= 63;
61 : Temp[j]:= $FF;
end;
Inc(iptr);
end;
Output^[optr]:= (Temp[0] shl 2) or (Temp[1] shr 4);
Result:= optr+1;
if (Temp[2]<> $FF) and (Temp[3]= $FF) then
begin
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
Result:= optr+2;
Inc(optr)
end
else if (Temp[2]<> $FF) then
begin
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
Output^[optr+2]:= (Temp[2] shl 6) or Temp[3];
Result:= optr+3;
Inc(optr,2);
end;
Inc(optr);
end;
end;
function Base64Decode(const Value: AnsiString): AnsiString;
begin
SetLength(Result,(Length(Value) div 4) * 3);
SetLength(Result,B64Decode(#Value[1],#Result[1],Length(Value)));
end;

Related

Is there a function in delphi to base64 encode a string without CRLF? [duplicate]

This question already has answers here:
Convert BitMap to string without line breaks?
(2 answers)
Closed 5 years ago.
Is there a function in delphi to base64 encode a string without CRLF? I try TnetEncoding.Base64.Encode(MyStr) but the result string contain CRLF (linebreak)
Yes, there is: TBase64Encoding constructed with specific parameters. There are three different constructor overloads. Default TNetEncoding.Base64 instance is constructed with default one. With other two constructors you can specify how many characters will be per line as well as line separator.
constructor Create; overload; virtual;
constructor Create(CharsPerLine: Integer); overload; virtual;
constructor Create(CharsPerLine: Integer; LineSeparator: string); overload; virtual;
If you specify empty string as new line delimiter, result will not have new line characters.
var
s, Encoded: string;
Base64: TBase64Encoding;
s := 'Some larger text that needs to be encoded in Base64 encoding';
Base64 := TBase64Encoding.Create(10, '');
Encoded := Base64.Encode(s);
Output:
U29tZSBsYXJnZXIgdGV4dCB0aGF0IG5lZWRzIHRvIGJlIGVuY29kZWQgaW4gQmFzZTY0IGVuY29kaW5n
There is a better solution for no breaks at all provided in David's answer
Using second constructor and passing 0 as parameter omits line breaks.
Base64 := TBase64Encoding.Create(0);
You can write your own function for this. It's really simple:
function EncodeBase64(const Input: TBytes): string;
const
Base64: array[0..63] of Char =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
function Encode3Bytes(const Byte1, Byte2, Byte3: Byte): string;
begin
Result := Base64[Byte1 shr 2]
+ Base64[((Byte1 shl 4) or (Byte2 shr 4)) and $3F]
+ Base64[((Byte2 shl 2) or (Byte3 shr 6)) and $3F]
+ Base64[Byte3 and $3F];
end;
function EncodeLast2Bytes(const Byte1, Byte2: Byte): string;
begin
Result := Base64[Byte1 shr 2]
+ Base64[((Byte1 shl 4) or (Byte2 shr 4)) and $3F]
+ Base64[(Byte2 shl 2) and $3F] + '=';
end;
function EncodeLast1Byte(const Byte1: Byte): string;
begin
Result := Base64[Byte1 shr 2]
+ Base64[(Byte1 shl 4) and $3F] + '==';
end;
var
i, iLength: Integer;
begin
Result := '';
iLength := Length(Input);
i := 0;
while i < iLength do
begin
case iLength - i of
3..MaxInt:
Result := Result + Encode3Bytes(Input[i], Input[i+1], Input[i+2]);
2:
Result := Result + EncodeLast2Bytes(Input[i], Input[i+1]);
1:
Result := Result + EncodeLast1Byte(Input[i]);
end;
Inc(i, 3);
end;
end;
Using with a string:
EncodeBase64(BytesOf(MyStr));

Why embedded CRC and current CRC differs?

I have found this Delphi examle. It is supposed to embed CRC and check current CRC. Both should match, but I get different results. How to fix it? And how to speed it up?
CRC32Calc.pas
unit CRC32Calc;
interface
uses Classes, SysUtils, windows, messages;
type
Long = record
LoWord: Word;
HiWord: Word;
end;
const
CRCPOLY = $EDB88320;
procedure BuildCRCTable;
function RecountCRC(b: byte; CrcOld: LongWord): LongWord;
function GetCRC32(FileName: string; Full: boolean): string;
function SetEmbeddedCRC(FileName: string): string;
function GetEmbeddedCRC(FileName: string): string;
function BytesToHexStr(pB: PByte; BufSize: LongWord): String;
function HexStrToBytes(Str: String): String;
implementation
var
CRCTable: array [0 .. 512] Of LongWord;
// A helper routine that creates and initializes
// the lookup table that is used when calculating a CRC polynomial
procedure BuildCRCTable;
var
i, j: Word;
r: LongWord;
begin
FillChar(CRCTable, SizeOf(CRCTable), 0);
for i := 0 to 255 do
begin
r := i shl 1;
for j := 8 downto 0 do
if (r and 1) <> 0 then
r := (r Shr 1) xor CRCPOLY
else
r := r shr 1;
CRCTable[i] := r;
end;
end;
// A helper routine that recalculates polynomial relative to the specified byte
function RecountCRC(b: byte; CrcOld: LongWord): LongWord;
begin
RecountCRC := CRCTable[byte(CrcOld xor LongWord(b))
] xor ((CrcOld shr 8) and $00FFFFFF)
end;
// A helper routine that converts Word into String
function HextW(w: Word): string;
const
h: array [0 .. 15] Of char = '0123456789ABCDEF';
begin
HextW := '';
HextW := h[Hi(w) shr 4] + h[Hi(w) and $F] + h[Lo(w) shr 4] + h[Lo(w) and $F];
end;
// A helper routine that converts LongWord into String
function HextL(l: LongWord): string;
begin
with Long(l) do
HextL := HextW(HiWord) + HextW(LoWord);
end;
// Calculate CRC32 checksum for the specified file
function GetCRC32(FileName: string; Full: boolean): string;
var
f: TFileStream;
i, CRC: LongWord;
aBt: byte;
begin
// Build a CRC table
BuildCRCTable;
CRC := $FFFFFFFF;
// Open the file
f := TFileStream.Create(FileName, (fmOpenRead or fmShareDenyNone));
// To calculate CRC for the whole file use this loop boundaries
if Full then
for i := 0 to f.Size - 1 do
begin
f.Read(aBt, 1);
CRC := RecountCRC(aBt, CRC);
end
else
// To calculate CRC for the file excluding the last 4 bytes
// use these loop boundaries
for i := 0 to f.Size - 5 do
begin
f.Read(aBt, 1);
CRC := RecountCRC(aBt, CRC);
end;
f.Destroy;
CRC := Not CRC;
Result := HextL(CRC);
end;
// Calculate CRC and writes it to the end of file
function SetEmbeddedCRC(FileName: string): string;
var
f: TFileStream;
CRCOffset: LongWord;
CRC: string;
begin
f := TFileStream.Create(FileName, (fmOpenReadWrite or fmShareDenyNone));
CRCOffset := f.Size;
// Append a placeholder for actual CRC to the file
f.Seek(CRCOffset, TSeekOrigin.soBeginning);
f.Write(PByte(HexStrToBytes('FFFFFFFF'))^, 4);
// Obtain CRC
CRC := GetCRC32(FileName, True);
// Write CRC to the end of file
f.Seek(CRCOffset, TSeekOrigin.soBeginning);
f.Write(PByte(HexStrToBytes(CRC))^, 4);
f.Destroy;
Result := CRC;
end;
// Extract the CRC that was stored at last 4 bytes of a file
function GetEmbeddedCRC(FileName: string): string;
var
f: TFileStream;
CRCOffset: LongWord;
pB: PByte;
begin
GetMem(pB, 4);
// Open file
f := TFileStream.Create(FileName, (fmOpenRead or fmShareDenyNone));
// Proceed upto the end of file
CRCOffset := f.Size - 4;
f.Seek(CRCOffset, TSeekOrigin.soBeginning);
// Read the last four bytes where the CRC is stored
f.Read(pB^, 4);
f.Destroy;
Result := BytesToHexStr(pB, 4);
end;
// A helper routine that converts byte value to string with hexadecimal integer
function BytesToHexStr(pB: PByte; BufSize: LongWord): String;
var
i, j, b: LongWord;
begin
SetLength(Result, 2 * BufSize);
for i := 1 to BufSize do
begin
for j := 0 to 1 do
begin
if j = 1 then
b := pB^ div 16
else
b := pB^ - (pB^ div 16) * 16;
case b of
0:
Result[2 * i - j] := '0';
1:
Result[2 * i - j] := '1';
2:
Result[2 * i - j] := '2';
3:
Result[2 * i - j] := '3';
4:
Result[2 * i - j] := '4';
5:
Result[2 * i - j] := '5';
6:
Result[2 * i - j] := '6';
7:
Result[2 * i - j] := '7';
8:
Result[2 * i - j] := '8';
9:
Result[2 * i - j] := '9';
10:
Result[2 * i - j] := 'A';
11:
Result[2 * i - j] := 'B';
12:
Result[2 * i - j] := 'C';
13:
Result[2 * i - j] := 'D';
14:
Result[2 * i - j] := 'E';
15:
Result[2 * i - j] := 'F';
end;
end;
Inc(pB);
end;
end;
// A helper routine that converts string with hexadecimal integer to byte value
function HexStrToBytes(Str: String): String;
var
b, b2: byte;
lw, lw2, lw3: LongWord;
begin
lw := Length(Str) div 2;
SetLength(Result, lw);
for lw2 := 1 to lw do
begin
b := 0;
for lw3 := 0 to 1 do
begin
case Str[2 * lw2 - lw3] of
'0':
b2 := 0;
'1':
b2 := 1;
'2':
b2 := 2;
'3':
b2 := 3;
'4':
b2 := 4;
'5':
b2 := 5;
'6':
b2 := 6;
'7':
b2 := 7;
'8':
b2 := 8;
'9':
b2 := 9;
'a':
b2 := 10;
'b':
b2 := 11;
'c':
b2 := 12;
'd':
b2 := 13;
'e':
b2 := 14;
'f':
b2 := 15;
'A':
b2 := 10;
'B':
b2 := 11;
'C':
b2 := 12;
'D':
b2 := 13;
'E':
b2 := 14;
'F':
b2 := 15;
else
b2 := 0;
end;
if lw3 = 0 then
b := b2
else
b := b + 16 * b2;
end;
Result[lw2] := char(b);
end;
end;
end.
AppendCRC
program AppendCRC;
{$APPTYPE CONSOLE}
uses
SysUtils, Classes,
CRC32Calc in '..\CRC32Checker\CRC32Calc.pas';
var
FileName: string;
begin
{ TODO -oUser -cConsole Main : Insert code here }
if ParamCount = 1 then
begin
FileName := ParamStr(1);
// Verify whether a file exists
if not FileExists(FileName) then
begin
WriteLn('The specified file does not exist.');
Exit;
end;
WriteLn('Full checksum (before): ' + GetCRC32(FileName, True));
SetEmbeddedCRC(FileName);
WriteLn('Half checksum: ' + GetCRC32(FileName, False));
WriteLn('Full checksum (after): ' + GetCRC32(FileName, True));
WriteLn('GetEmbeddedCRC: :' + GetEmbeddedCRC(FileName));
WriteLn('The checksum was successfully embedded.')
end
else
begin;
WriteLn('Wrong parameters.');
WriteLn('Parameter1 - Full path to file.');;
end;
end.
My results are:
AppendCRC.exe Hello_Delphi_World.exe
Full checksum (before): 1912DA64
Half checksum: 1912DA64
Full checksum (after): B3F0A43E
GetEmbeddedCRC: :4400A000
The checksum was successfully embedded.
I am using Delphi XE5.
You should understand how this code works.
Overall idea is to append the CRC as an extra 4 bytes, out of the EXE structure, to the end of file. (A better idea would be to put CRC into a special field inside EXE Header in the beginning).
However that raises the hen and the egg problem: after we calculate CRC and embed it - the CRC file is changed (the value of CRC is appended) and the CRC of changed files changes too.
So you basically has to implement two modes/function of CRC calculation: for the whole file and for the file without last 4 bytes. You should use the latter mode to calculate CRC after appending (you call it embedding), and the former one to calculate CRC before it on vanilla just compiled program.
Your GetCRC32 function always cuts last 4 bytes from the file, thus before embedding it calculates CRC only of some part of file, not of the whole file. But there ahve to be two different modes.
PS: you can also "embed" CRC into NTFS Alternate Stream, like having MyApp.exe program and CRC stored as MyApp.exe:CRC.
PPS. i think using unbuffered read byte by byte in the GetCRC32 should be very slow. If possible, better use TBytesStream to read the file into memory as whole and then scan in usual loop over array. Or read it by chunks of 4096 bytes rather than by byte variables.
For the last non-complete buffer you would clean the rest of buffer with zeroes for example.

Delphi encrypted file is much smaller than the original?

I am loading a binary file into a memorystream, then encoding the data, and returning the result as a string, then writing the result into another memorystream, and saving it to a file, but when it saved the file is much smaller than the original 25kb from 400kb...lol, im pretty sure it's because I've hit the limit of what a string is capable of handling.
it's definately encoding what data it does save in the new file correctly, I decrypted it and compared it to the begining of the original file.
I know this is a very long winded method and probibly has some unnecesary steps, so loading it into bStream would be a very effective resolution. My question is how could I have the data returned to bStream rather than having it returned to a string then writing the string to bStream at that point as I do believe, that it would solve my problem, any other suggestions would also be appreciated. Im using Delphi 6.
Heres My Code:
function B64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
var
i, iptr, optr: integer;
Input, Output: PByteArray;
begin
Input := PByteArray(pInput);
Output := PByteArray(pOutput);
iptr := 0;
optr := 0;
for i := 1 to (Size div 3) do
begin
Output^[optr + 0] := B64[Input^[iptr] shr 2];
Output^[optr + 1] := B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr + 1] shr 4)];
Output^[optr + 2] := B64[((Input^[iptr + 1] and 15) shl 2) + (Input^[iptr + 2] shr 6)];
Output^[optr + 3] := B64[Input^[iptr + 2] and 63];
Inc(optr, 4);
Inc(iptr, 3);
end;
case (Size mod 3) of
1:
begin
Output^[optr + 0] := B64[Input^[iptr] shr 2];
Output^[optr + 1] := B64[(Input^[iptr] and 3) shl 4];
Output^[optr + 2] := byte('=');
Output^[optr + 3] := byte('=');
end;
2:
begin
Output^[optr + 0] := B64[Input^[iptr] shr 2];
Output^[optr + 1] := B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr + 1] shr 4)];
Output^[optr + 2] := B64[(Input^[iptr + 1] and 15) shl 2];
Output^[optr + 3] := byte('=');
end;
end;
Result := ((Size + 2) div 3) * 4;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
aStream, bStream: TMemoryStream;
strastream: string;
szaStream: integer;
begin
bStream := TMemoryStream.Create;
aStream := TMemoryStream.Create;
aStream.LoadFromFile('C:\file1.exe');
szaStream := (astream.size + 2) div (3 * 4);
SetLength(strastream, szaStream);
B64Encode(astream.Memory, #strastream[1], Length(strastream));
bstream.WriteBuffer(strastream[1], szaStream);
AttachToFile('C:\file2.exe', bStream);
bstream.Free;
aStream.Free;
end;
Thanks.
Your length calculations are all wrong as has been pointed out in comments.
szaStream := (astream.size + 2) div (3 * 4);
This means that your encoded stream is 1/12th the size of the input stream. But it needs to be larger. You meant:
szaStream := ((astream.size * 4) div 3) + 2;
I also do not see the point of using a string here. You can write directly to the stream.
And, it's worth repeating that with base 64 you are encoding and not encrypting.
In my opinion, there is little point writing all this yourself when Delphi ships with a base 64 implementation. The unit is called EncdDecd, or Soap.EncdDecd if you are using namespaces. And the only function you need is
procedure EncodeStream(Input, Output: TStream);
Create two file streams, one for reading, one for writing, and pass them to that function. For example:
procedure EncodeFileBase64(const InFileName, OutFileName:string);
var
Input, Output: TStream;
begin
Input := TFileStream.Create(InFileName, fmOpenRead);
try
Output := TFileStream.Create(InFileName, fmCreate);
try
EncodeStream(Input, Output);
finally
Output.Free;
end;
finally
Input.Free;
end;
end;
Should you need to reverse the process, do so with, you guessed it, DecodeStream.
If performance matters then you may need to use a buffered stream rather than TFileStream. For example: Buffered files (for faster disk access)

Hex to Binary convert

I have converted my jpeg file as HEX code through hex converter.
Now how to convert that hex to binary and save as Jpeg file on disk.
Like:
var declared as Hex code and then convert that var hex code to binary and save on disk ?
Edit:
Var
myfileHex := 'FAA4F4AAA444444'; // long as HEX code of my JPEG
function HexToBin(myfileHex): string;
begin
// Convert Hex to bin and save file as...
end;
Delphi already has HexToBin (Classes) procedure, since at least D5.
Try this code:
procedure HexStringToBin;
var
BinaryStream: TMemoryStream;
HexStr: AnsiString;
begin
HexStr := 'FAA4F4AAA44444';
BinaryStream := TMemoryStream.Create;
try
BinaryStream.Size := Length(HexStr) div 2;
if BinaryStream.Size > 0 then
begin
HexToBin(PAnsiChar(HexStr), BinaryStream.Memory, BinaryStream.Size);
BinaryStream.SaveToFile('c:\myfile.bin')
end;
finally
BinaryStream.Free;
end;
end;
The same could be done with any binary TStream e.g. TFileStream.
Hex is very easy to decode manually:
procedure HexToBin(const Hex: string; Stream: TStream);
var
B: Byte;
C: Char;
Idx, Len: Integer;
begin
Len := Length(Hex);
If Len = 0 then Exit;
If (Len mod 2) <> 0 then raise Exception.Create('bad hex length');
Idx := 1;
repeat
C := Hex[Idx];
case C of
'0'..'9': B := Byte((Ord(C) - '0') shl 4);
'A'..'F': B := Byte(((Ord(C) - 'A') + 10) shl 4);
'a'..'f': B := Byte(((Ord(C) - 'a') + 10) shl 4);
else
raise Exception.Create('bad hex data');
end;
C := Hex[Idx+1];
case C of
'0'..'9': B := B or Byte(Ord(C) - '0');
'A'..'F': B := B or Byte((Ord(C) - 'A') + 10);
'a'..'f': B := B or Byte((Ord(C) - 'a') + 10);
else
raise Exception.Create('bad hex data');
end;
Stream.WriteBuffer(B, 1);
Inc(Idx, 2);
until Idx > Len;
end;
begin
FStream := TFileStream.Create('myfile.jpg', fmCreate);
HexToBin(myFileHex, FStream);
FStream.Free;
end;

converting a PNGImage to grayscale using delphi

hi there
here it is my code:
procedure TForm4.Button1Click(Sender: TObject);
var
png: TPNGImage;
data: PRGBQarray;
p: ^tagRGBQuad;
i, o: integer;
begin
png := TPNGImage.Create;
try
png.LoadFromFile('C:\Untitled.png');
for o := 1 to 100 do
begin
data:=png.Scanline[o];
for I := 1 to 400 do
begin
p := #data^[i];
p.rgbGreen := p.rgbBlue;
p.rgbRed := p.rgbGreen;
end;
end;
img.picture.Assign(png);
finally
png.Free;
end;
end;
it doesn't work and it makes the pic messy, I'm sure it's because of the rgbReserved.
what should i do?
This is how to greyify a bitmap. (And, yes, if you want to greyify a PNG, you first need to get the bitmap data out of it. I think the VCL will do this for you.)
type
PRGB32Array = ^TRGB32Array;
TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;
procedure MakeGrey(Bitmap: TBitmap);
var
w, h: integer;
y: Integer;
sl: PRGB32Array;
x: Integer;
grey: byte;
begin
Bitmap.PixelFormat := pf32bit;
w := Bitmap.Width;
h := Bitmap.Height;
for y := 0 to h - 1 do
begin
sl := Bitmap.ScanLine[y];
for x := 0 to w - 1 do
with sl[x] do
begin
grey := (rgbBlue + rgbGreen + rgbRed) div 3;
rgbBlue := grey;
rgbGreen := grey;
rgbRed := grey;
end;
end;
end;
Sample usage:
procedure TForm4.Button1Click(Sender: TObject);
var
bm: TBitmap;
begin
bm := TBitmap.Create;
try
bm.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\Porträtt, litet, kvadratiskt.bmp');
MakeGrey(bm);
Canvas.Draw(0, 0, bm);
finally
bm.Free;
end;
end;
Andreas's answer will give you a good, fast approximation, but you'll lose some quality, because red, green and blue don't mix with equal intensities in the human eye. If you want to "get it right", instead of
grey := (rgbBlue + rgbGreen + rgbRed) div 3;
try this:
grey := round(rgbRed * .3) + round(rgbGreen * .59) + round(rgbBlue * .11);
You'll get a bit of a performance hit over the simple average, though it probably won't be noticeable unless you're on a very large image.
I know the question has already been answered but here is my 2c worth...
The following code comes from the PNGComponents package (PngFunctions.pas) produced by Thany.
//
//The Following code comes from the PNGComponents package from Thany...
//
procedure MakeImageGrayscale(Image: TPNGObject; Amount: Byte = 255);
procedure GrayscaleRGB(var R, G, B: Byte);
var
X: Byte;
begin
X := Round(R * 0.30 + G * 0.59 + B * 0.11);
R := Round(R / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
G := Round(G / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
B := Round(B / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
end;
var
X, Y, PalCount: Integer;
Line: Pointer;
PaletteHandle: HPalette;
Palette: array[Byte] of TPaletteEntry;
begin
//Don't do anything if the image is already a grayscaled one
if not (Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_GRAYSCALEALPHA])
then begin
if Image.Header.ColorType = COLOR_PALETTE
then begin
//Grayscale every palette entry
PaletteHandle := Image.Palette;
PalCount := GetPaletteEntries(PaletteHandle, 0, 256, Palette);
for X := 0 to PalCount - 1
do GrayscaleRGB(Palette[X].peRed, Palette[X].peGreen, Palette[X].peBlue);
SetPaletteEntries(PaletteHandle, 0, PalCount, Palette);
Image.Palette := PaletteHandle;
end
else begin
//Grayscale every pixel
for Y := 0 to Image.Height - 1
do begin
Line := Image.Scanline[Y];
for X := 0 to Image.Width - 1
do GrayscaleRGB(PRGBLine(Line)^[X].rgbtRed, PRGBLine(Line)^[X].rgbtGreen, PRGBLine(Line)^[X].rgbtBlue);
end;
end;
end;
end;
There is a set of routines, that was originally published by the author of the PNGImage components, that can be found on Code Central that shows how to do other things like Alpha blending two images, rotation, overlay, etc. CodeCentral Link
This really should have been a comment to #Mason's routine to turn RGB into GreyScale, but since I don't know how to make a comment show code, I'm making it an answer instead.
This is how I do the conversion:
FUNCTION RGB2GRAY(R,G,B : BYTE) : BYTE; Register; ASSEMBLER;
ASM
IMUL EAX,19595
IMUL EDX,38470
IMUL ECX,7471
ADD EAX,EDX
ADD EAX,ECX
SHR EAX,16
END;
FUNCTION GreyScale(C : TColor) : TColor; Register; ASSEMBLER;
ASM
MOVZX EDX,AH
MOV ECX,EAX
SHR ECX,16
MOVZX EAX,AL
CALL RGB2GRAY
MOVZX EAX,AL
MOV AH,AL
SHL EAX,8
MOV AL,AH
END;
I don't know if it is NTSC formula or whatever, but they seem to work in my programs :-).

Resources