unit DIB; interface uses Windows, SysUtils, Classes, Graphics, Controls; type TRGBQuads = array[0..255] of TRGBQuad; TPaletteEntries = array[0..255] of TPaletteEntry; PBGR = ^TBGR; TBGR = packed record B, G, R: Byte; end; PArrayBGR = ^TArrayBGR; TArrayBGR = array[0..10000] of TBGR; PArrayByte = ^TArrayByte; TArrayByte = array[0..10000] of Byte; PArrayWord = ^TArrayWord; TArrayWord = array[0..10000] of Word; PArrayDWord = ^TArrayDWord; TArrayDWord = array[0..10000] of DWord; { TDIB } TDIBPixelFormat = record RBitMask, GBitMask, BBitMask: DWORD; RBitCount, GBitCount, BBitCount: DWORD; RShift, GShift, BShift: DWORD; RBitCount2, GBitCount2, BBitCount2: DWORD; end; TDIBSharedImage = class(TSharedImage) private FBitCount: Integer; FBitmapInfo: PBitmapInfo; FBitmapInfoSize: Integer; FChangePalette: Boolean; FColorTable: TRGBQuads; FColorTablePos: Integer; FCompressed: Boolean; FDC: THandle; FHandle: THandle; FHeight: Integer; FMemoryImage: Boolean; FNextLine: Integer; FOldHandle: THandle; FPalette: HPalette; FPaletteCount: Integer; FPBits: Pointer; FPixelFormat: TDIBPixelFormat; FSize: Integer; FTopPBits: Pointer; FWidth: Integer; FWidthBytes: Integer; constructor Create; procedure NewImage(AWidth, AHeight, ABitCount: Integer; const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean); procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean); procedure Compress(Source: TDIBSharedImage); procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean); procedure ReadData(Stream: TStream; MemoryImage: Boolean); function GetPalette: THandle; procedure SetColorTable(const Value: TRGBQuads); protected procedure FreeHandle; override; public destructor Destroy; override; end; TDIB = class(TGraphic) private FCanvas: TCanvas; FImage: TDIBSharedImage; FProgressName: string; FProgressOldY: DWORD; FProgressOldTime: DWORD; FProgressOld: DWORD; FProgressY: DWORD; { For speed-up } FBitCount: Integer; FHeight: Integer; FNextLine: Integer; FNowPixelFormat: TDIBPixelFormat; FPBits: Pointer; FSize: Integer; FTopPBits: Pointer; FWidth: Integer; FWidthBytes: Integer; procedure AllocHandle; procedure CanvasChanging(Sender: TObject); procedure Changing(MemoryImage: Boolean); procedure ConvertBitCount(ABitCount: Integer); function GetBitmapInfo: PBitmapInfo; function GetBitmapInfoSize: Integer; function GetCanvas: TCanvas; function GetHandle: THandle; function GetPaletteCount: Integer; function GetPixel(X, Y: Integer): DWORD; function GetPBits: Pointer; function GetPBitsReadOnly: Pointer; function GetScanLine(Y: Integer): Pointer; function GetScanLineReadOnly(Y: Integer): Pointer; function GetTopPBits: Pointer; function GetTopPBitsReadOnly: Pointer; procedure SetBitCount(Value: Integer); procedure SetImage(Value: TDIBSharedImage); procedure SetNowPixelFormat(const Value: TDIBPixelFormat); procedure SetPixel(X, Y: Integer; Value: DWORD); procedure StartProgress(const Name: string); procedure EndProgress; procedure UpdateProgress(PercentY: Integer); protected procedure DefineProperties(Filer: TFiler); override; procedure Draw(ACanvas: TCanvas; const Rect: TRect); override; function GetEmpty: Boolean; override; function GetHeight: Integer; override; function GetPalette: HPalette; override; function GetWidth: Integer; override; procedure ReadData(Stream: TStream); override; procedure SetHeight(Value: Integer); override; procedure SetPalette(Value: HPalette); override; procedure SetWidth(Value: Integer); override; procedure WriteData(Stream: TStream); override; public ColorTable: TRGBQuads; PixelFormat: TDIBPixelFormat; constructor Create; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Clear; procedure Compress; procedure Decompress; procedure FreeHandle; procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override; procedure LoadFromStream(Stream: TStream); override; procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); override; procedure SaveToStream(Stream: TStream); override; procedure SetSize(AWidth, AHeight, ABitCount: Integer); procedure UpdatePalette; { Special effect } procedure Blur(ABitCount: Integer; Radius: Integer); procedure Greyscale(ABitCount: Integer); procedure Mirror(MirrorX, MirrorY: Boolean); procedure Negative; property BitCount: Integer read FBitCount write SetBitCount; property BitmapInfo: PBitmapInfo read GetBitmapInfo; property BitmapInfoSize: Integer read GetBitmapInfoSize; property Canvas: TCanvas read GetCanvas; property Handle: THandle read GetHandle; property Height: Integer read FHeight write SetHeight; property NextLine: Integer read FNextLine; property NowPixelFormat: TDIBPixelFormat read FNowPixelFormat write SetNowPixelFormat; property PaletteCount: Integer read GetPaletteCount; property PBits: Pointer read GetPBits; property PBitsReadOnly: Pointer read GetPBitsReadOnly; property Pixels[X, Y: Integer]: DWORD read GetPixel write SetPixel; property ScanLine[Y: Integer]: Pointer read GetScanLine; property ScanLineReadOnly[Y: Integer]: Pointer read GetScanLineReadOnly; property Size: Integer read FSize; property TopPBits: Pointer read GetTopPBits; property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly; property Width: Integer read FWidth write SetWidth; property WidthBytes: Integer read FWidthBytes; end; function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat; function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat; function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD; procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte); function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; function GreyscaleColorTable: TRGBQuads; function RGBQuad(R, G, B: Byte): TRGBQuad; function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad; function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads; function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry; function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries; implementation const SInvalidDIB = 'DIB is invalid'; SInvalidDIBBitCount = 'Bitcount in invalid (%d)'; SInvalidDIBPixelFormat = 'PixelFormat in invalid'; SCannotMade = '%s cannot be made'; SScanline = 'Index of the scanning line exceeded the range. (%d)'; function Max(B1, B2: Integer): Integer; begin if B1>=B2 then Result := B1 else Result := B2; end; function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat; begin Result.RBitMask := ((1 shl RBitCount)-1) shl (GBitCount+BBitCount); Result.GBitMask := ((1 shl GBitCount)-1) shl (BBitCount); Result.BBitMask := (1 shl BBitCount)-1; Result.RBitCount := RBitCount; Result.GBitCount := GBitCount; Result.BBitCount := BBitCount; Result.RBitCount2 := 8-RBitCount; Result.GBitCount2 := 8-GBitCount; Result.BBitCount2 := 8-BBitCount; Result.RShift := (GBitCount+BBitCount)-(8-RBitCount); Result.GShift := BBitCount-(8-GBitCount); Result.BShift := 8-BBitCount; end; function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat; function GetBitCount(b: Integer): Integer; var i: Integer; begin i := 0; while (i<31) and (((1 shl i) and b)=0) do Inc(i); Result := 0; while ((1 shl i) and b)<>0 do begin Inc(i); Inc(Result); end; end; begin Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask), GetBitCount(BBitMask)); end; function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD; begin with PixelFormat do Result := ((R shl RShift) and RBitMask) or ((G shl GShift) and GBitMask) or ((B shr BShift) and BBitMask); end; procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte); begin with PixelFormat do begin R := (Color and RBitMask) shr RShift; R := R or (R shr RBitCount2); G := (Color and GBitMask) shr GShift; G := G or (G shr GBitCount2); B := (Color and BBitMask) shl BShift; B := B or (B shr BBitCount2); end; end; function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; begin with PixelFormat do begin Result := (Color and RBitMask) shr RShift; Result := Result or (Result shr RBitCount); end; end; function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; begin with PixelFormat do begin Result := (Color and GBitMask) shr GShift; Result := Result or (Result shr GBitCount); end; end; function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; begin with PixelFormat do begin Result := (Color and BBitMask) shl BShift; Result := Result or (Result shr BBitCount); end; end; function GreyscaleColorTable: TRGBQuads; var i: Integer; begin for i:=0 to 255 do with Result[i] do begin rgbRed := i; rgbGreen := i; rgbBlue := i; rgbReserved := 0; end; end; function RGBQuad(R, G, B: Byte): TRGBQuad; begin with Result do begin rgbRed := R; rgbGreen := G; rgbBlue := B; rgbReserved := 0; end; end; function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad; begin with Result do with Entry do begin rgbRed := peRed; rgbGreen := peGreen; rgbBlue := peBlue; rgbReserved := 0; end; end; function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads; var i: Integer; begin for i:=0 to 255 do Result[i] := PaletteEntryToRGBQuad(Entries[i]); end; function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry; begin with Result do with RGBQuad do begin peRed := rgbRed; peGreen := rgbGreen; peBlue := rgbBlue; peFlags := 0; end; end; function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries; var i: Integer; begin for i:=0 to 255 do Result[i] := RGBQuadToPaletteEntry(RGBQuads[i]); end; { TDIBSharedImage } type PLocalDIBPixelFormat = ^TLocalDIBPixelFormat; TLocalDIBPixelFormat = packed record RBitMask, GBitMask, BBitMask: DWORD; end; TPaletteItem = class(TCollectionItem) private ID: Integer; Palette: HPalette; RefCount: Integer; ColorTable: TRGBQuads; ColorTableCount: Integer; destructor Destroy; override; procedure AddRef; procedure Release; end; TPaletteManager = class private FList: TCollection; constructor Create; destructor Destroy; override; function CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette; procedure DeletePalette(var Palette: HPalette); end; destructor TPaletteItem.Destroy; begin DeleteObject(Palette); inherited Destroy; end; procedure TPaletteItem.AddRef; begin Inc(RefCount); end; procedure TPaletteItem.Release; begin Dec(RefCount); if RefCount<=0 then Free; end; constructor TPaletteManager.Create; begin inherited Create; FList := TCollection.Create(TPaletteItem); end; destructor TPaletteManager.Destroy; begin FList.Free; inherited Destroy; end; function TPaletteManager.CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette; type TMyLogPalette = record palVersion: Word; palNumEntries: Word; palPalEntry: TPaletteEntries; end; var i, ID: Integer; Item: TPaletteItem; LogPalette: TMyLogPalette; begin { Hash key making } ID := ColorTableCount; for i:=0 to ColorTableCount-1 do with ColorTable[i] do begin Inc(ID, rgbRed); Inc(ID, rgbGreen); Inc(ID, rgbBlue); end; { Does the same palette already exist? } for i:=0 to FList.Count-1 do begin Item := TPaletteItem(FList.Items[i]); if (Item.ID=ID) and (Item.ColorTableCount=ColorTableCount) and CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount*SizeOf(TRGBQuad)) then begin Item.AddRef; Result := Item.Palette; Exit; end; end; { New palette making } Item := TPaletteItem.Create(FList); Item.ID := ID; Move(ColorTable, Item.ColorTable, ColorTableCount*SizeOf(TRGBQuad)); Item.ColorTableCount := ColorTableCount; with LogPalette do begin palVersion := $300; palNumEntries := ColorTableCount; palPalEntry := RGBQuadsToPaletteEntries(ColorTable); end; Item.Palette := Windows.CreatePalette(PLogPalette(@LogPalette)^); Item.AddRef; Result := Item.Palette; end; procedure TPaletteManager.DeletePalette(var Palette: HPalette); var i: Integer; Item: TPaletteItem; begin if Palette=0 then Exit; for i:=0 to FList.Count-1 do begin Item := TPaletteItem(FList.Items[i]); if (Item.Palette=Palette) then begin Palette := 0; Item.Release; Exit; end; end; end; var FPaletteManager: TPaletteManager; function PaletteManager: TPaletteManager; begin if FPaletteManager=nil then FPaletteManager := TPaletteManager.Create; Result := FPaletteManager; end; constructor TDIBSharedImage.Create; begin inherited Create; FMemoryImage := True; SetColorTable(GreyscaleColorTable); FColorTable := GreyscaleColorTable; FPixelFormat := MakeDIBPixelFormat(8, 8, 8); end; procedure TDIBSharedImage.NewImage(AWidth, AHeight, ABitCount: Integer; const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean); var InfoOfs: Integer; UsePixelFormat: Boolean; begin Create; { Pixel format check } case ABitCount of 1 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat); 4 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat); 8 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat); 16: begin if not (((PixelFormat.RBitMask=$7C00) and (PixelFormat.GBitMask=$03E0) and (PixelFormat.BBitMask=$001F)) or ((PixelFormat.RBitMask=$F800) and (PixelFormat.GBitMask=$07E0) and (PixelFormat.BBitMask=$001F))) then raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat); end; 24: begin if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat); end; 32: begin if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat); end; else raise EInvalidGraphicOperation.CreateFmt(SInvalidDIBBitCount, [ABitCount]); end; FBitCount := ABitCount; FHeight := AHeight; FWidth := AWidth; FWidthBytes := (((AWidth*ABitCount)+31) shr 5) * 4; FNextLine := -FWidthBytes; FSize := FWidthBytes*FHeight; UsePixelFormat := ABitCount in [16, 32]; FPixelFormat := PixelFormat; FPaletteCount := 0; if FBitCount<=8 then FPaletteCount := 1 shl FBitCount; FBitmapInfoSize := SizeOf(TBitmapInfoHeader); if UsePixelFormat then Inc(FBitmapInfoSize, SizeOf(TLocalDIBPixelFormat)); Inc(FBitmapInfoSize, SizeOf(TRGBQuad)*FPaletteCount); GetMem(FBitmapInfo, FBitmapInfoSize); FillChar(FBitmapInfo^, FBitmapInfoSize, 0); { BitmapInfo setting. } with FBitmapInfo^.bmiHeader do begin biSize := SizeOf(TBitmapInfoHeader); biWidth := FWidth; biHeight := FHeight; biPlanes := 1; biBitCount := FBitCount; if UsePixelFormat then biCompression := BI_BITFIELDS else begin if (FBitCount=4) and (Compressed) then biCompression := BI_RLE4 else if (FBitCount=8) and (Compressed) then biCompression := BI_RLE8 else biCompression := BI_RGB; end; biSizeImage := FSize; biXPelsPerMeter := 0; biYPelsPerMeter := 0; biClrUsed := 0; biClrImportant := 0; end; InfoOfs := SizeOf(TBitmapInfoHeader); if UsePixelFormat then begin with PLocalDIBPixelFormat(Integer(FBitmapInfo)+InfoOfs)^ do begin RBitMask := PixelFormat.RBitMask; GBitMask := PixelFormat.GBitMask; BBitMask := PixelFormat.BBitMask; end; Inc(InfoOfs, SizeOf(TLocalDIBPixelFormat)); end; FColorTablePos := InfoOfs; FColorTable := ColorTable; Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount); FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8]; FMemoryImage := MemoryImage or FCompressed; { DIB making. } if not Compressed then begin if MemoryImage then begin FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize)); if FPBits=nil then OutOfMemoryError; end else begin FDC := CreateCompatibleDC(0); FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0); if FHandle=0 then raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']); FOldHandle := SelectObject(FDC, FHandle); end; end; FTopPBits := Pointer(Integer(FPBits)+(FHeight-1)*FWidthBytes); end; procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean); begin if Source.FSize=0 then begin Create; FMemoryImage := MemoryImage; end else begin NewImage(Source.FWidth, Source.FHeight, Source.FBitCount, Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed); if FCompressed then begin FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage; GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage); Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage); end else begin Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage); end; end; end; procedure TDIBSharedImage.Compress(Source: TDIBSharedImage); procedure EncodeRLE4; var Size: Integer; function AllocByte: PByte; begin if Size mod 4096=0 then ReAllocMem(FPBits, Size+4095); Result := Pointer(Integer(FPBits)+Size); Inc(Size); end; var B1, B2, C: Byte; PB1, PB2: Integer; Src: PByte; X, Y: Integer; function GetPixel(x: Integer): Integer; begin if X and 1=0 then Result := PArrayByte(Src)[X shr 1] shr 4 else Result := PArrayByte(Src)[X shr 1] and $0F; end; begin Size := 0; for y:=0 to Source.FHeight-1 do begin x := 0; Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes); while x3) and (GetPixel(x)=GetPixel(x+2)) then begin { Encoding mode } B1 := 2; B2 := (GetPixel(x) shl 4) or GetPixel(x+1); Inc(x, 2); C := B2; while (x5) and ((GetPixel(x)<>GetPixel(x+2)) or (GetPixel(x+1)<>GetPixel(x+3))) and ((GetPixel(x+2)=GetPixel(x+4)) and (GetPixel(x+3)=GetPixel(x+5))) then begin { Encoding mode } AllocByte^ := 2; AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1); Inc(x, 2); end else begin if (Source.FWidth-x<4) then begin { Encoding mode } while Source.FWidth-x>=2 do begin AllocByte^ := 2; AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1); Inc(x, 2); end; if Source.FWidth-x=1 then begin AllocByte^ := 1; AllocByte^ := GetPixel(x) shl 4; Inc(x); end; end else begin { Absolute mode } PB1 := Size; AllocByte; PB2 := Size; AllocByte; B1 := 0; B2 := 4; AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1); AllocByte^ := (GetPixel(x+2) shl 4) or GetPixel(x+3); Inc(x, 4); while (x+13) and (GetPixel(x)=GetPixel(x+2)) and (GetPixel(x+1)=GetPixel(x+3)) then Break; AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1); Inc(B2, 2); Inc(x, 2); end; PByte(Integer(FPBits)+PB1)^ := B1; PByte(Integer(FPBits)+PB2)^ := B2; end; end; if Size and 1=1 then AllocByte; end; { End of line } AllocByte^ := 0; AllocByte^ := 0; end; { End of bitmap } AllocByte^ := 0; AllocByte^ := 1; FBitmapInfo.bmiHeader.biSizeImage := Size; FSize := Size; end; procedure EncodeRLE8; var Size: Integer; function AllocByte: PByte; begin if Size mod 4096=0 then ReAllocMem(FPBits, Size+4095); Result := Pointer(Integer(FPBits)+Size); Inc(Size); end; var B1, B2: Byte; PB1, PB2: Integer; Src: PByte; X, Y: Integer; begin Size := 0; for y:=0 to Source.FHeight-1 do begin x := 0; Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes); while x2) and (Src^=PByte(Integer(Src)+1)^) then begin { Encoding mode } B1 := 2; B2 := Src^; Inc(x, 2); Inc(Src, 2); while (x2) and (Src^<>PByte(Integer(Src)+1)^) and (PByte(Integer(Src)+1)^=PByte(Integer(Src)+2)^) then begin { Encoding mode } AllocByte^ := 1; AllocByte^ := Src^; Inc(Src); Inc(x); end else begin if (Source.FWidth-x<4) then begin { Encoding mode } if Source.FWidth-x=2 then begin AllocByte^ := 1; AllocByte^ := Src^; Inc(Src); AllocByte^ := 1; AllocByte^ := Src^; Inc(Src); Inc(x, 2); end else begin AllocByte^ := 1; AllocByte^ := Src^; Inc(Src); Inc(x); end; end else begin { Absolute mode } PB1 := Size; AllocByte; PB2 := Size; AllocByte; B1 := 0; B2 := 3; Inc(x, 3); AllocByte^ := Src^; Inc(Src); AllocByte^ := Src^; Inc(Src); AllocByte^ := Src^; Inc(Src); while (x3) and (Src^=PByte(Integer(Src)+1)^) and (Src^=PByte(Integer(Src)+2)^) and (Src^=PByte(Integer(Src)+3)^) then Break; AllocByte^ := Src^; Inc(Src); Inc(B2); Inc(x); end; PByte(Integer(FPBits)+PB1)^ := B1; PByte(Integer(FPBits)+PB2)^ := B2; end; end; if Size and 1=1 then AllocByte; end; { End of line } AllocByte^ := 0; AllocByte^ := 0; end; { End of bitmap } AllocByte^ := 0; AllocByte^ := 1; FBitmapInfo.bmiHeader.biSizeImage := Size; FSize := Size; end; begin if Source.FCompressed then Duplicate(Source, Source.FMemoryImage) else begin NewImage(Source.FWidth, Source.FHeight, Source.FBitCount, Source.FPixelFormat, Source.FColorTable, True, True); case FBitmapInfo.bmiHeader.biCompression of BI_RLE4: EncodeRLE4; BI_RLE8: EncodeRLE8; else Duplicate(Source, Source.FMemoryImage); end; end; end; procedure TDIBSharedImage.Decompress(Source: TDIBSharedImage; MemoryImage: Boolean); procedure DecodeRLE4; var B1, B2, C: Byte; Dest, Src, P: PByte; X, Y, i: Integer; begin Src := Source.FPBits; X := 0; Y := 0; while True do begin B1 := Src^; Inc(Src); B2 := Src^; Inc(Src); if B1=0 then begin case B2 of 0: begin { End of line } X := 0; Inc(Y); end; 1: Break; { End of bitmap } 2: begin { Difference of coordinates } Inc(X, B1); Inc(Y, B2); Inc(Src, 2); end; else { Absolute mode } Dest := Pointer(Longint(FPBits)+Y*FWidthBytes); C := 0; for i:=0 to B2-1 do begin if i and 1=0 then begin C := Src^; Inc(Src); end else begin C := C shl 4; end; P := Pointer(Integer(Dest)+X shr 1); if X and 1=0 then P^ := (P^ and $0F) or (C and $F0) else P^ := (P^ and $F0) or ((C and $F0) shr 4); Inc(X); end; end; end else begin { Encoding mode } Dest := Pointer(Longint(FPBits)+Y*FWidthBytes); for i:=0 to B1-1 do begin P := Pointer(Integer(Dest)+X shr 1); if X and 1=0 then P^ := (P^ and $0F) or (B2 and $F0) else P^ := (P^ and $F0) or ((B2 and $F0) shr 4); Inc(X); // Swap nibble B2 := (B2 shr 4) or (B2 shl 4); end; end; { Word arrangement } Inc(Src, Longint(Src) and 1); end; end; procedure DecodeRLE8; var B1, B2: Byte; Dest, Src: PByte; X, Y: Integer; begin Dest := FPBits; Src := Source.FPBits; X := 0; Y := 0; while True do begin B1 := Src^; Inc(Src); B2 := Src^; Inc(Src); if B1=0 then begin case B2 of 0: begin { End of line } X := 0; Inc(Y); Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X); end; 1: Break; { End of bitmap } 2: begin { Difference of coordinates } Inc(X, B1); Inc(Y, B2); Inc(Src, 2); Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X); end; else { Absolute mode } Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2); end; end else begin { Encoding mode } FillChar(Dest^, B1, B2); Inc(Dest, B1); end; { Word arrangement } Inc(Src, Longint(Src) and 1); end; end; begin if not Source.FCompressed then Duplicate(Source, MemoryImage) else begin NewImage(Source.FWidth, Source.FHeight, Source.FBitCount, Source.FPixelFormat, Source.FColorTable, MemoryImage, False); case Source.FBitmapInfo.bmiHeader.biCompression of BI_RLE4: DecodeRLE4; BI_RLE8: DecodeRLE8; else Duplicate(Source, MemoryImage); end; end; end; procedure TDIBSharedImage.ReadData(Stream: TStream; MemoryImage: Boolean); var BI: TBitmapInfoHeader; BC: TBitmapCoreHeader; BCRGB: array[0..255] of TRGBTriple; procedure LoadRLE4; begin FSize := BI.biSizeImage; FPBits := GlobalAllocPtr(GMEM_FIXED, FSize); FBitmapInfo.bmiHeader.biSizeImage := FSize; Stream.ReadBuffer(FPBits^, FSize); end; procedure LoadRLE8; begin FSize := BI.biSizeImage; FPBits := GlobalAllocPtr(GMEM_FIXED, FSize); FBitmapInfo.bmiHeader.biSizeImage := FSize; Stream.ReadBuffer(FPBits^, FSize); end; procedure LoadRGB; var y: Integer; begin if BI.biHeight<0 then begin for y:=0 to Abs(BI.biHeight)-1 do Stream.ReadBuffer(Pointer(Integer(FTopPBits)+y*FNextLine)^, FWidthBytes); end else begin Stream.ReadBuffer(FPBits^, FSize); end; end; var i, PalCount: Integer; OS2: Boolean; Localpf: TLocalDIBPixelFormat; AColorTable: TRGBQuads; APixelFormat: TDIBPixelFormat; begin { Header size reading } i := Stream.Read(BI.biSize, 4); if i=0 then begin Create; Exit; end; if i<>4 then raise EInvalidGraphic.Create(SInvalidDIB); { Kind check of DIB } OS2 := False; case BI.biSize of SizeOf(TBitmapCoreHeader): begin { OS/2 type } Stream.ReadBuffer(Pointer(Integer(@BC)+4)^, SizeOf(TBitmapCoreHeader)-4); with BI do begin biClrUsed := 0; biCompression := BI_RGB; biBitCount := BC.bcBitCount; biHeight := BC.bcHeight; biWidth := BC.bcWidth; end; OS2 := True; end; SizeOf(TBitmapInfoHeader): begin { Windows type } Stream.ReadBuffer(Pointer(Integer(@BI)+4)^, SizeOf(TBitmapInfoHeader)-4); end; else raise EInvalidGraphic.Create(SInvalidDIB); end; { Bit mask reading. } if BI.biCompression = BI_BITFIELDS then begin Stream.ReadBuffer(Localpf, SizeOf(Localpf)); with Localpf do APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask); end else begin if BI.biBitCount=16 then APixelFormat := MakeDIBPixelFormat(5, 5, 5) else if BI.biBitCount=32 then APixelFormat := MakeDIBPixelFormat(8, 8, 8) else APixelFormat := MakeDIBPixelFormat(8, 8, 8); end; { Palette reading } PalCount := BI.biClrUsed; if (PalCount=0) and (BI.biBitCount<=8) then PalCount := 1 shl BI.biBitCount; if PalCount>256 then PalCount := 256; FillChar(AColorTable, SizeOf(AColorTable), 0); if OS2 then begin { OS/2 type } Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple)*PalCount); for i:=0 to PalCount-1 do begin with BCRGB[i] do AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue); end; end else begin { Windows type } Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad)*PalCount); end; { DIB 쐬 } NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable, MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]); { Pixel data reading } case BI.biCompression of BI_RGB : LoadRGB; BI_RLE4 : LoadRLE4; BI_RLE8 : LoadRLE8; BI_BITFIELDS: LoadRGB; else raise EInvalidGraphic.Create(SInvalidDIB); end; end; destructor TDIBSharedImage.Destroy; begin if FHandle<>0 then begin if FOldHandle<>0 then SelectObject(FDC, FOldHandle); DeleteObject(FHandle); end else begin if FPBits<>nil then GlobalFreePtr(FPBits); end; PaletteManager.DeletePalette(FPalette); if FDC<>0 then DeleteDC(FDC); FreeMem(FBitmapInfo); inherited Destroy; end; procedure TDIBSharedImage.FreeHandle; begin end; function TDIBSharedImage.GetPalette: THandle; begin if FPaletteCount>0 then begin if FChangePalette then begin FChangePalette := False; PaletteManager.DeletePalette(FPalette); FPalette := PaletteManager.CreatePalette(FColorTable, FPaletteCount); end; Result := FPalette; end else Result := 0; end; procedure TDIBSharedImage.SetColorTable(const Value: TRGBQuads); begin FColorTable := Value; FChangePalette := True; if (FSize>0) and (FPaletteCount>0) then begin SetDIBColorTable(FDC, 0, 256, FColorTable); Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount); end; end; { TDIB } var FEmptyDIBImage: TDIBSharedImage; function EmptyDIBImage: TDIBSharedImage; begin if FEmptyDIBImage=nil then begin FEmptyDIBImage := TDIBSharedImage.Create; FEmptyDIBImage.Reference; end; Result := FEmptyDIBImage; end; constructor TDIB.Create; begin inherited Create; SetImage(EmptyDIBImage); end; destructor TDIB.Destroy; begin SetImage(EmptyDIBImage); FCanvas.Free; inherited Destroy; end; procedure TDIB.Assign(Source: TPersistent); procedure AssignBitmap(Source: TBitmap); var Data: array[0..1023] of Byte; BitmapRec: Windows.PBitmap; DIBSectionRec: PDIBSection; PaletteEntries: TPaletteEntries; begin GetPaletteEntries(Source.Palette, 0, 256, PaletteEntries); ColorTable := PaletteEntriesToRGBQuads(PaletteEntries); UpdatePalette; case GetObject(Source.Handle, SizeOf(Data), @Data) of SizeOf(Windows.TBitmap): begin BitmapRec := @Data; case BitmapRec^.bmBitsPixel of 16: PixelFormat := MakeDIBPixelFormat(5, 5, 5); else PixelFormat := MakeDIBPixelFormat(8, 8, 8); end; SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel); end; SizeOf(TDIBSection): begin DIBSectionRec := @Data; if DIBSectionRec^.dsBm.bmBitsPixel>=24 then begin PixelFormat := MakeDIBPixelFormat(8, 8, 8); end else if DIBSectionRec^.dsBm.bmBitsPixel>8 then begin PixelFormat := MakeDIBPixelFormat(DIBSectionRec^.dsBitfields[0], DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]); end else begin PixelFormat := MakeDIBPixelFormat(8, 8, 8); end; SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight, DIBSectionRec^.dsBm.bmBitsPixel); end; else Exit; end; FillChar(PBits^, Size, 0); Canvas.Draw(0, 0, Source); end; procedure AssignGraphic(Source: TGraphic); begin if Source is TBitmap then AssignBitmap(TBitmap(Source)) else begin SetSize(Source.Width, Source.Height, 24); FillChar(PBits^, Size, 0); Canvas.Draw(0, 0, Source); end; end; begin if Source=nil then begin Clear; end else if Source is TDIB then begin if Source<>Self then SetImage(TDIB(Source).FImage); end else if Source is TGraphic then begin AssignGraphic(TGraphic(Source)); end else if Source is TPicture then begin if TPicture(Source).Graphic<>nil then AssignGraphic(TPicture(Source).Graphic) else Clear; end else inherited Assign(Source); end; procedure TDIB.Draw(ACanvas: TCanvas; const Rect: TRect); var OldPalette: HPalette; OldMode: Integer; begin if Size>0 then begin if PaletteCount>0 then begin OldPalette := SelectPalette(ACanvas.Handle, Palette, False); RealizePalette(ACanvas.Handle); end else OldPalette := 0; try OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR); try GdiFlush; if FImage.FMemoryImage then begin with Rect do StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top, 0, 0, Width, Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS , ACanvas.CopyMode); end else begin with Rect do StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top, FImage.FDC, 0, 0, Width, Height, ACanvas.CopyMode); end; finally SetStretchBltMode(ACanvas.Handle, OldMode); end; finally SelectPalette(ACanvas.Handle, OldPalette, False); end; end; end; procedure TDIB.Clear; begin SetImage(EmptyDIBImage); end; procedure TDIB.CanvasChanging(Sender: TObject); begin Changing(False); end; procedure TDIB.Changing(MemoryImage: Boolean); var TempImage: TDIBSharedImage; begin if (FImage.RefCount>1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then begin TempImage := TDIBSharedImage.Create; try TempImage.Decompress(FImage, FImage.FMemoryImage and MemoryImage); except TempImage.Free; raise; end; SetImage(TempImage); end; end; procedure TDIB.AllocHandle; var TempImage: TDIBSharedImage; begin if FImage.FMemoryImage then begin TempImage := TDIBSharedImage.Create; try TempImage.Decompress(FImage, False); except TempImage.Free; raise; end; SetImage(TempImage); end; end; procedure TDIB.Compress; var TempImage: TDIBSharedImage; begin if (not FImage.FCompressed) and (BitCount in [4, 8]) then begin TempImage := TDIBSharedImage.Create; try TempImage.Compress(FImage); except TempImage.Free; raise; end; SetImage(TempImage); end; end; procedure TDIB.Decompress; var TempImage: TDIBSharedImage; begin if FImage.FCompressed then begin TempImage := TDIBSharedImage.Create; try TempImage.Decompress(FImage, FImage.FMemoryImage); except TempImage.Free; raise; end; SetImage(TempImage); end; end; procedure TDIB.FreeHandle; var TempImage: TDIBSharedImage; begin if not FImage.FMemoryImage then begin TempImage := TDIBSharedImage.Create; try TempImage.Duplicate(FImage, True); except TempImage.Free; raise; end; SetImage(TempImage); end; end; function TDIB.GetBitmapInfo: PBitmapInfo; begin Result := FImage.FBitmapInfo; end; function TDIB.GetBitmapInfoSize: Integer; begin Result := FImage.FBitmapInfoSize; end; function TDIB.GetCanvas: TCanvas; begin if (FCanvas=nil) or (FCanvas.Handle=0) then begin AllocHandle; FCanvas := TCanvas.Create; FCanvas.Handle := FImage.FDC; FCanvas.OnChanging := CanvasChanging; end; Result := FCanvas; end; function TDIB.GetEmpty: Boolean; begin Result := Size=0; end; function TDIB.GetHandle: THandle; begin Changing(True); Result := FImage.FHandle; end; function TDIB.GetHeight: Integer; begin Result := FHeight; end; function TDIB.GetPalette: HPalette; begin Result := FImage.GetPalette; end; function TDIB.GetPaletteCount: Integer; begin Result := FImage.FPaletteCount; end; function TDIB.GetPBits: Pointer; begin Changing(True); if not FImage.FMemoryImage then GDIFlush; Result := FPBits; end; function TDIB.GetPBitsReadOnly: Pointer; begin if not FImage.FMemoryImage then GDIFlush; Result := FPBits; end; function TDIB.GetScanLine(Y: Integer): Pointer; begin Changing(True); if (Y<0) or (Y>=FHeight) then raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]); if not FImage.FMemoryImage then GDIFlush; Result := Pointer(Integer(FTopPBits)+Y*FNextLine); end; function TDIB.GetScanLineReadOnly(Y: Integer): Pointer; begin if (Y<0) or (Y>=FHeight) then raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]); if not FImage.FMemoryImage then GDIFlush; Result := Pointer(Integer(FTopPBits)+Y*FNextLine); end; function TDIB.GetTopPBits: Pointer; begin Changing(True); if not FImage.FMemoryImage then GDIFlush; Result := FTopPBits; end; function TDIB.GetTopPBitsReadOnly: Pointer; begin if not FImage.FMemoryImage then GDIFlush; Result := FTopPBits; end; function TDIB.GetWidth: Integer; begin Result := FWidth; end; const Mask1: array[0..7] of DWORD = ($80, $40, $20, $10, $08, $04, $02, $01); Mask1n: array[0..7] of DWORD = ($FFFFFF7F, $FFFFFFBF, $FFFFFFDF, $FFFFFFEF, $FFFFFFF7, $FFFFFFFB, $FFFFFFFD, $FFFFFFFE); Mask4: array[0..1] of DWORD = ($F0, $0F); Mask4n: array[0..1] of DWORD = ($FFFFFF0F, $FFFFFFF0); Shift1: array[0..7] of DWORD = (7, 6, 5, 4, 3, 2, 1, 0); Shift4: array[0..1] of DWORD = (4, 0); function TDIB.GetPixel(X, Y: Integer): DWORD; begin Decompress; Result := 0; if (X>=0) and (X=0) and (Y=0) and (X=0) and (YSizeOf(TBitmapFileHeader) then raise EInvalidGraphic.Create(SInvalidDIB); { Is the head 'BM'? } if BF.bfType<>BitmapFileType then raise EInvalidGraphic.Create(SInvalidDIB); ReadData(Stream); end; procedure TDIB.ReadData(Stream: TStream); var TempImage: TDIBSharedImage; begin TempImage := TDIBSharedImage.Create; try TempImage.ReadData(Stream, FImage.FMemoryImage); except TempImage.Free; raise; end; SetImage(TempImage); end; procedure TDIB.SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); var P: Pointer; Stream: TMemoryStream; begin AFormat := CF_DIB; APalette := 0; Stream := TMemoryStream.Create; try WriteData(Stream); AData := GlobalAlloc(GHND, Stream.Size); if AData=0 then OutOfMemoryError; P := GlobalLock(AData); Move(Stream.Memory^, P^, Stream.Size); GlobalUnLock(AData); finally Stream.Free; end; end; procedure TDIB.SaveToStream(Stream: TStream); var BF: TBitmapFileHeader; begin if Empty then Exit; with BF do begin bfType := BitmapFileType; bfOffBits := SizeOf(TBitmapFileHeader)+BitmapInfoSize; bfSize := bfOffBits+FImage.FBitmapInfo^.bmiHeader.biSizeImage; bfReserved1 := 0; bfReserved2 := 0; end; Stream.WriteBuffer(BF, SizeOf(TBitmapFileHeader)); WriteData(Stream); end; procedure TDIB.WriteData(Stream: TStream); begin if Empty then Exit; if not FImage.FMemoryImage then GDIFlush; Stream.WriteBuffer(FImage.FBitmapInfo^, FImage.FBitmapInfoSize); Stream.WriteBuffer(FImage.FPBits^, FImage.FBitmapInfo.bmiHeader.biSizeImage); end; procedure TDIB.SetBitCount(Value: Integer); begin if Value<=0 then Clear else begin if Empty then begin SetSize(Max(Width, 1), Max(Height, 1), Value) end else begin ConvertBitCount(Value); end; end; end; procedure TDIB.SetHeight(Value: Integer); begin if Value<=0 then Clear else begin if Empty then SetSize(Max(Width, 1), Value, 8) else SetSize(Width, Value, BitCount); end; end; procedure TDIB.SetWidth(Value: Integer); begin if Value<=0 then Clear else begin if Empty then SetSize(Value, Max(Height, 1), 8) else SetSize(Value, Height, BitCount); end; end; procedure TDIB.SetImage(Value: TDIBSharedImage); begin if FImage<>Value then begin if FCanvas<>nil then FCanvas.Handle := 0; FImage.Release; FImage := Value; FImage.Reference; if FCanvas<>nil then FCanvas.Handle := FImage.FDC; ColorTable := FImage.FColorTable; PixelFormat := FImage.FPixelFormat; FBitCount := FImage.FBitCount; FHeight := FImage.FHeight; FNextLine := FImage.FNextLine; FNowPixelFormat := FImage.FPixelFormat; FPBits := FImage.FPBits; FSize := FImage.FSize; FTopPBits := FImage.FTopPBits; FWidth := FImage.FWidth; FWidthBytes := FImage.FWidthBytes; end; end; procedure TDIB.SetNowPixelFormat(const Value: TDIBPixelFormat); var Temp: TDIB; begin if CompareMem(@Value, @FImage.FPixelFormat, SizeOf(TDIBPixelFormat)) then exit; PixelFormat := Value; Temp := TDIB.Create; try Temp.Assign(Self); SetSize(Width, Height, BitCount); Canvas.Draw(0, 0, Temp); finally Temp.Free; end; end; procedure TDIB.SetPalette(Value: HPalette); var PaletteEntries: TPaletteEntries; begin GetPaletteEntries(Value, 0, 256, PaletteEntries); DeleteObject(Value); ColorTable := PaletteEntriesToRGBQuads(PaletteEntries); UpdatePalette; end; procedure TDIB.SetSize(AWidth, AHeight, ABitCount: Integer); var TempImage: TDIBSharedImage; begin if (AWidth=Width) and (AHeight=Height) and (ABitCount=BitCount) and (NowPixelFormat.RBitMask=PixelFormat.RBitMask) and (NowPixelFormat.GBitMask=PixelFormat.GBitMask) and (NowPixelFormat.BBitMask=PixelFormat.BBitMask) then Exit; if (AWidth<=0) or (AHeight<=0) then begin Clear; Exit; end; TempImage := TDIBSharedImage.Create; try TempImage.NewImage(AWidth, AHeight, ABitCount, PixelFormat, ColorTable, FImage.FMemoryImage, False); except TempImage.Free; raise; end; SetImage(TempImage); PaletteModified := True; end; procedure TDIB.UpdatePalette; var Col: TRGBQuads; begin if CompareMem(@ColorTable, @FImage.FColorTable, SizeOf(ColorTable)) then Exit; Col := ColorTable; Changing(True); ColorTable := Col; FImage.SetColorTable(ColorTable); PaletteModified := True; end; procedure TDIB.ConvertBitCount(ABitCount: Integer); var Temp: TDIB; procedure CreateHalftonePalette(R, G, B: Integer); var i: Integer; begin for i:=0 to 255 do with ColorTable[i] do begin rgbRed := ((i shr (G+B-1)) and (1 shl R-1)) * 255 div (1 shl R-1); rgbGreen := ((i shr (B-1)) and (1 shl G-1)) * 255 div (1 shl G-1); rgbBlue := ((i shr 0) and (1 shl B-1)) * 255 div (1 shl B-1); end; end; procedure PaletteToPalette_Inc; var x, y: Integer; i: DWORD; SrcP, DestP: Pointer; P: PByte; begin i := 0; for y:=0 to Height-1 do begin SrcP := Temp.ScanLine[y]; DestP := ScanLine[y]; for x:=0 to Width-1 do begin case Temp.BitCount of 1 : begin i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]; end; 4 : begin i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1]; end; 8 : begin i := PByte(SrcP)^; Inc(PByte(SrcP)); end; end; case BitCount of 1 : begin P := @PArrayByte(DestP)[X shr 3]; P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]); end; 4 : begin P := @PArrayByte(DestP)[X shr 1]; P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]); end; 8 : begin PByte(DestP)^ := i; Inc(PByte(DestP)); end; end; end; end; end; procedure PaletteToRGB_or_RGBToRGB; var x, y: Integer; SrcP, DestP: Pointer; cR, cG, cB: Byte; begin cR := 0; cG := 0; cB := 0; for y:=0 to Height-1 do begin SrcP := Temp.ScanLine[y]; DestP := ScanLine[y]; for x:=0 to Width-1 do begin case Temp.BitCount of 1 : begin with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do begin cR := rgbRed; cG := rgbGreen; cB := rgbBlue; end; end; 4 : begin with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do begin cR := rgbRed; cG := rgbGreen; cB := rgbBlue; end; end; 8 : begin with Temp.ColorTable[PByte(SrcP)^] do begin cR := rgbRed; cG := rgbGreen; cB := rgbBlue; end; Inc(PByte(SrcP)); end; 16: begin pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB); Inc(PWord(SrcP)); end; 24: begin with PBGR(SrcP)^ do begin cR := R; cG := G; cB := B; end; Inc(PBGR(SrcP)); end; 32: begin pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB); Inc(PDWORD(SrcP)); end; end; case BitCount of 16: begin PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB); Inc(PWord(DestP)); end; 24: begin with PBGR(DestP)^ do begin R := cR; G := cG; B := cB; end; Inc(PBGR(DestP)); end; 32: begin PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB); Inc(PDWORD(DestP)); end; end; end; end; end; begin if Size=0 then exit; Temp := TDIB.Create; try Temp.Assign(Self); SetSize(Temp.Width, Temp.Height, ABitCount); if FImage=Temp.FImage then Exit; if (Temp.BitCount<=8) and (BitCount<=8) then begin { The image is converted from the palette color image into the palette color image. } if Temp.BitCount<=BitCount then begin PaletteToPalette_Inc; end else begin case BitCount of 1: begin ColorTable[0] := RGBQuad(0, 0, 0); ColorTable[1] := RGBQuad(255, 255, 255); end; 4: CreateHalftonePalette(1, 2, 1); 8: CreateHalftonePalette(3, 3, 2); end; UpdatePalette; Canvas.Draw(0, 0, Temp); end; end else if (Temp.BitCount<=8) and (BitCount>8) then begin { The image is converted from the palette color image into the rgb color image. } PaletteToRGB_or_RGBToRGB; end else if (Temp.BitCount>8) and (BitCount<=8) then begin { The image is converted from the rgb color image into the palette color image. } case BitCount of 1: begin ColorTable[0] := RGBQuad(0, 0, 0); ColorTable[1] := RGBQuad(255, 255, 255); end; 4: CreateHalftonePalette(1, 2, 1); 8: CreateHalftonePalette(3, 3, 2); end; UpdatePalette; Canvas.Draw(0, 0, Temp); end else if (Temp.BitCount>8) and (BitCount>8) then begin { The image is converted from the rgb color image into the rgb color image. } PaletteToRGB_or_RGBToRGB; end; finally Temp.Free; end; end; { Special effect } procedure TDIB.StartProgress(const Name: string); begin FProgressName := Name; FProgressOld := 0; FProgressOldTime := GetTickCount; FProgressY := 0; FProgressOldY := 0; Progress(Self, psStarting, 0, False, Rect(0, 0, Width, Height), FProgressName); end; procedure TDIB.EndProgress; begin Progress(Self, psEnding, 100, True, Rect(0, FProgressOldY, Width, Height), FProgressName); end; procedure TDIB.UpdateProgress(PercentY: Integer); var Redraw: Boolean; Percent: DWORD; begin Redraw := (GetTickCount-FProgressOldTime>200) and (FProgressY-FProgressOldY>32) and (((Height div 3>Integer(FProgressY)) and (FProgressOldY=0)) or (FProgressOldY<>0)); Percent := PercentY*100 div Height; if (Percent<>FProgressOld) or (Redraw) then begin Progress(Self, psRunning, Percent, Redraw, Rect(0, FProgressOldY, Width, FProgressY), FProgressName); if Redraw then begin FProgressOldY := FProgressY; FProgressOldTime := GetTickCount; end; FProgressOld := Percent; end; Inc(FProgressY); end; procedure TDIB.Blur(ABitCount: Integer; Radius: Integer); type TAve = record cR, cG, cB: DWORD; c: DWORD; end; TArrayAve = array[0..0] of TAve; var Temp: TDIB; procedure AddAverage(Y, XCount: Integer; var Ave: TArrayAve); var X: Integer; SrcP: Pointer; AveP: ^TAve; R, G, B: Byte; begin case Temp.BitCount of 1 : begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do begin Inc(cR, rgbRed); Inc(cG, rgbGreen); Inc(cB, rgbBlue); Inc(c); end; Inc(AveP); end; end; 4 : begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do begin Inc(cR, rgbRed); Inc(cG, rgbGreen); Inc(cB, rgbBlue); Inc(c); end; Inc(AveP); end; end; 8 : begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with Temp.ColorTable[PByte(SrcP)^], AveP^ do begin Inc(cR, rgbRed); Inc(cG, rgbGreen); Inc(cB, rgbBlue); Inc(c); end; Inc(PByte(SrcP)); Inc(AveP); end; end; 16: begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B); with AveP^ do begin Inc(cR, R); Inc(cG, G); Inc(cB, B); Inc(c); end; Inc(PWord(SrcP)); Inc(AveP); end; end; 24: begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with PBGR(SrcP)^, AveP^ do begin Inc(cR, R); Inc(cG, G); Inc(cB, B); Inc(c); end; Inc(PBGR(SrcP)); Inc(AveP); end; end; 32: begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B); with AveP^ do begin Inc(cR, R); Inc(cG, G); Inc(cB, B); Inc(c); end; Inc(PDWORD(SrcP)); Inc(AveP); end; end; end; end; procedure DeleteAverage(Y, XCount: Integer; var Ave: TArrayAve); var X: Integer; SrcP: Pointer; AveP: ^TAve; R, G, B: Byte; begin case Temp.BitCount of 1 : begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do begin Dec(cR, rgbRed); Dec(cG, rgbGreen); Dec(cB, rgbBlue); Dec(c); end; Inc(AveP); end; end; 4 : begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do begin Dec(cR, rgbRed); Dec(cG, rgbGreen); Dec(cB, rgbBlue); Dec(c); end; Inc(AveP); end; end; 8 : begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with Temp.ColorTable[PByte(SrcP)^], AveP^ do begin Dec(cR, rgbRed); Dec(cG, rgbGreen); Dec(cB, rgbBlue); Dec(c); end; Inc(PByte(SrcP)); Inc(AveP); end; end; 16: begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B); with AveP^ do begin Dec(cR, R); Dec(cG, G); Dec(cB, B); Dec(c); end; Inc(PWord(SrcP)); Inc(AveP); end; end; 24: begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin with PBGR(SrcP)^, AveP^ do begin Dec(cR, R); Dec(cG, G); Dec(cB, B); Dec(c); end; Inc(PBGR(SrcP)); Inc(AveP); end; end; 32: begin SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine); AveP := @Ave; for x:=0 to XCount-1 do begin pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B); with AveP^ do begin Dec(cR, R); Dec(cG, G); Dec(cB, B); Dec(c); end; Inc(PDWORD(SrcP)); Inc(AveP); end; end; end; end; procedure Blur_Radius_Other; var FirstX, LastX, FirstX2, LastX2, FirstY, LastY: Integer; x, y, x2, y2, jx, jy: Integer; Ave: TAve; AveX: ^TArrayAve; DestP: Pointer; P: PByte; begin GetMem(AveX, Width*SizeOf(TAve)); try FillChar(AveX^, Width*SizeOf(TAve), 0); FirstX2 := -1; LastX2 := -1; FirstY := -1; LastY := -1; x := 0; for x2:=-Radius to Radius do begin jx := x+x2; if (jx>=0) and (jx=0) and (jy=Height then LastY := Height-1; AddAverage(LastY, Temp.Width, AveX^); end; { The average is calculated again. } FirstX := FirstX2; LastX := LastX2; FillChar(Ave, SizeOf(Ave), 0); for x:=FirstX to LastX do with AveX[x] do begin Inc(Ave.cR, cR); Inc(Ave.cG, cG); Inc(Ave.cB, cB); Inc(Ave.c, c); end; for x:=0 to Width-1 do begin { The average is updated. } if x-FirstX=Radius+1 then begin with AveX[FirstX] do begin Dec(Ave.cR, cR); Dec(Ave.cG, cG); Dec(Ave.cB, cB); Dec(Ave.c, c); end; Inc(FirstX); end; if LastX-x=Radius-1 then begin Inc(LastX); if LastX>=Width then LastX := Width-1; with AveX[LastX] do begin Inc(Ave.cR, cR); Inc(Ave.cG, cG); Inc(Ave.cB, cB); Inc(Ave.c, c); end; end; { The average is written. } case BitCount of 1 : begin P := @PArrayByte(DestP)[X shr 3]; with Ave do P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(((cR+cG+cB) div c) div 3>127)) shl Shift1[X and 7]); end; 4 : begin P := @PArrayByte(DestP)[X shr 1]; with Ave do P^ := (P^ and Mask4n[X and 1]) or (((((cR+cG+cB) div c) div 3) shr 4) shl Shift4[X and 1]); end; 8 : begin with Ave do PByte(DestP)^ := ((cR+cG+cB) div c) div 3; Inc(PByte(DestP)); end; 16: begin with Ave do PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c); Inc(PWORD(DestP)); end; 24: begin with PBGR(DestP)^, Ave do begin R := cR div c; G := cG div c; B := cB div c; end; Inc(PBGR(DestP)); end; 32: begin with Ave do PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c); Inc(PDWORD(DestP)); end; end; end; UpdateProgress(y); end; finally FreeMem(AveX); end; end; var i, j: Integer; begin if Empty or (Radius=0) then Exit; Radius := Abs(Radius); StartProgress('Blur'); try Temp := TDIB.Create; try Temp.Assign(Self); SetSize(Width, Height, ABitCount); if ABitCount<=8 then begin FillChar(ColorTable, SizeOf(ColorTable), 0); for i:=0 to (1 shl ABitCount)-1 do begin j := i * (1 shl (8-ABitCount)); j := j or (j shr ABitCount); ColorTable[i] := RGBQuad(j, j, j); end; UpdatePalette; end; Blur_Radius_Other; finally Temp.Free; end; finally EndProgress; end; end; procedure TDIB.Greyscale(ABitCount: Integer); var YTblR, YTblG, YTblB: array[0..255] of Byte; i, j, x, y: Integer; c: DWORD; R, G, B: Byte; Temp: TDIB; DestP, SrcP: Pointer; P: PByte; begin if Empty then exit; Temp := TDIB.Create; try Temp.Assign(Self); SetSize(Width, Height, ABitCount); if ABitCount<=8 then begin FillChar(ColorTable, SizeOf(ColorTable), 0); for i:=0 to (1 shl ABitCount)-1 do begin j := i * (1 shl (8-ABitCount)); j := j or (j shr ABitCount); ColorTable[i] := RGBQuad(j, j, j); end; UpdatePalette; end; for i:=0 to 255 do begin YTblR[i] := Trunc(0.3588*i); YTblG[i] := Trunc(0.4020*i); YTblB[i] := Trunc(0.2392*i); end; c := 0; StartProgress('Greyscale'); try for y:=0 to Height-1 do begin DestP := ScanLine[y]; SrcP := Temp.ScanLine[y]; for x:=0 to Width-1 do begin case Temp.BitCount of 1 : begin with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue]; end; 4 : begin with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue]; end; 8 : begin with Temp.ColorTable[PByte(SrcP)^] do c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue]; Inc(PByte(SrcP)); end; 16: begin pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B); c := YTblR[R]+YTblR[G]+YTblR[B]; Inc(PWord(SrcP)); end; 24: begin with PBGR(SrcP)^ do c := YTblR[R]+YTblG[G]+YTblB[B]; Inc(PBGR(SrcP)); end; 32: begin pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B); c := YTblR[R]+YTblR[G]+YTblR[B]; Inc(PDWORD(SrcP)); end; end; case BitCount of 1 : begin P := @PArrayByte(DestP)[X shr 3]; P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(c>127)) shl Shift1[X and 7]); end; 4 : begin P := @PArrayByte(DestP)[X shr 1]; P^ := (P^ and Mask4n[X and 1]) or ((c shr 4) shl Shift4[X and 1]); end; 8 : begin PByte(DestP)^ := c; Inc(PByte(DestP)); end; 16: begin PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c); Inc(PWord(DestP)); end; 24: begin with PBGR(DestP)^ do begin R := c; G := c; B := c; end; Inc(PBGR(DestP)); end; 32: begin PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c); Inc(PDWORD(DestP)); end; end; end; UpdateProgress(y); end; finally EndProgress; end; finally Temp.Free; end; end; procedure TDIB.Mirror(MirrorX, MirrorY: Boolean); var x, y, Width2, c: Integer; P1, P2, TempBuf: Pointer; begin if Empty then exit; if (not MirrorX) and (not MirrorY) then Exit; if (not MirrorX) and (MirrorY) then begin GetMem(TempBuf, WidthBytes); try StartProgress('Mirror'); try for y:=0 to Height shr 1-1 do begin P1 := ScanLine[y]; P2 := ScanLine[Height-y-1]; Move(P1^, TempBuf^, WidthBytes); Move(P2^, P1^, WidthBytes); Move(TempBuf^, P2^, WidthBytes); UpdateProgress(y*2); end; finally EndProgress; end; finally FreeMem(TempBuf, WidthBytes); end; end else if (MirrorX) and (not MirrorY) then begin Width2 := Width shr 1; StartProgress('Mirror'); try for y:=0 to Height-1 do begin P1 := ScanLine[y]; case BitCount of 1 : begin for x:=0 to Width2-1 do begin c := Pixels[x, y]; Pixels[x, y] := Pixels[Width-x-1, y]; Pixels[Width-x-1, y] := c; end; end; 4 : begin for x:=0 to Width2-1 do begin c := Pixels[x, y]; Pixels[x, y] := Pixels[Width-x-1, y]; Pixels[Width-x-1, y] := c; end; end; 8 : begin P2 := Pointer(Integer(P1)+Width-1); for x:=0 to Width2-1 do begin PByte(@c)^ := PByte(P1)^; PByte(P1)^ := PByte(P2)^; PByte(P2)^ := PByte(@c)^; Inc(PByte(P1)); Dec(PByte(P2)); end; end; 16: begin P2 := Pointer(Integer(P1)+(Width-1)*2); for x:=0 to Width2-1 do begin PWord(@c)^ := PWord(P1)^; PWord(P1)^ := PWord(P2)^; PWord(P2)^ := PWord(@c)^; Inc(PWord(P1)); Dec(PWord(P2)); end; end; 24: begin P2 := Pointer(Integer(P1)+(Width-1)*3); for x:=0 to Width2-1 do begin PBGR(@c)^ := PBGR(P1)^; PBGR(P1)^ := PBGR(P2)^; PBGR(P2)^ := PBGR(@c)^; Inc(PBGR(P1)); Dec(PBGR(P2)); end; end; 32: begin P2 := Pointer(Integer(P1)+(Width-1)*4); for x:=0 to Width2-1 do begin PDWORD(@c)^ := PDWORD(P1)^; PDWORD(P1)^ := PDWORD(P2)^; PDWORD(P2)^ := PDWORD(@c)^; Inc(PDWORD(P1)); Dec(PDWORD(P2)); end; end; end; UpdateProgress(y); end; finally EndProgress; end; end else if (MirrorX) and (MirrorY) then begin StartProgress('Mirror'); try for y:=0 to Height shr 1-1 do begin P1 := ScanLine[y]; P2 := ScanLine[Height-y-1]; case BitCount of 1 : begin for x:=0 to Width-1 do begin c := Pixels[x, y]; Pixels[x, y] := Pixels[Width-x-1, Height-y-1]; Pixels[Width-x-1, Height-y-1] := c; end; end; 4 : begin for x:=0 to Width-1 do begin c := Pixels[x, y]; Pixels[x, y] := Pixels[Width-x-1, Height-y-1]; Pixels[Width-x-1, Height-y-1] := c; end; end; 8 : begin P2 := Pointer(Integer(P2)+Width-1); for x:=0 to Width-1 do begin PByte(@c)^ := PByte(P1)^; PByte(P1)^ := PByte(P2)^; PByte(P2)^ := PByte(@c)^; Inc(PByte(P1)); Dec(PByte(P2)); end; end; 16: begin P2 := Pointer(Integer(P2)+(Width-1)*2); for x:=0 to Width-1 do begin PWord(@c)^ := PWord(P1)^; PWord(P1)^ := PWord(P2)^; PWord(P2)^ := PWord(@c)^; Inc(PWord(P1)); Dec(PWord(P2)); end; end; 24: begin P2 := Pointer(Integer(P2)+(Width-1)*3); for x:=0 to Width-1 do begin PBGR(@c)^ := PBGR(P1)^; PBGR(P1)^ := PBGR(P2)^; PBGR(P2)^ := PBGR(@c)^; Inc(PBGR(P1)); Dec(PBGR(P2)); end; end; 32: begin P2 := Pointer(Integer(P2)+(Width-1)*4); for x:=0 to Width-1 do begin PDWORD(@c)^ := PDWORD(P1)^; PDWORD(P1)^ := PDWORD(P2)^; PDWORD(P2)^ := PDWORD(@c)^; Inc(PDWORD(P1)); Dec(PDWORD(P2)); end; end; end; UpdateProgress(y*2); end; finally EndProgress; end; end; end; procedure TDIB.Negative; var i, i2: Integer; P: Pointer; begin if Empty then exit; if BitCount<=8 then begin for i:=0 to 255 do with ColorTable[i] do begin rgbRed := 255-rgbRed; rgbGreen := 255-rgbGreen; rgbBlue := 255-rgbBlue; end; UpdatePalette; end else begin P := PBits; i2 := Size; asm mov ecx,i2 mov eax,P mov edx,ecx { Unit of DWORD. } @@qword_skip: shr ecx,2 jz @@dword_skip dec ecx @@dword_loop: not dword ptr [eax+ecx*4] dec ecx jnl @@dword_loop mov ecx,edx shr ecx,2 add eax,ecx*4 { Unit of Byte. } @@dword_skip: mov ecx,edx and ecx,3 jz @@byte_skip dec ecx @@loop_byte: not byte ptr [eax+ecx] dec ecx jnl @@loop_byte @@byte_skip: end; end; end; initialization TPicture.RegisterClipBoardFormat(CF_DIB, TDIB); TPicture.RegisterFileFormat('dib', 'Device Independent Bitmap', TDIB); finalization TPicture.UnRegisterGraphicClass(TDIB); FEmptyDIBImage.Free; FPaletteManager.Free; end.