Delphi调用gd库演示

  由于需要在网络上传输图片，对图片的大小和质量要求比较高，在对比很多绘图库后选择了gd库。

  发现网上Delphi调用gd库的例子很少，所以我将自己写的一个调用gd库类发布给大家，希望对学Delphi的人有帮助。

 

  下面是调用gd库绘图函数的类:

  {*************************************************************** * 单元名称 : uGdImage.pas * 目的简介 : 调用gd.dll动态库 * 创建者 : 褚国峰 * 创建日期 : 2008-03-10 * 修改日志 : * 版权所有(c)2008 ***************************************************************} unit uGdImage; interface uses Windows, Classes, Graphics, SysUtils, Types, ShellAPI, SyncObjs; {type PgdFont = ^TgdFont; TgdFont = record nchars: integer; offset: integer; w: integer; h: integer; data: pchar; end;} {const FontHeight: integer = 8; //FontWidth: integer = 6;} function gdImageGd2Ptr(im: pointer; cs, fmt: integer; size: pinteger): pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageGd2Ptr@16'; procedure gdImageChar(im: pointer; f: pointer; x, y, c: integer; color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageChar@24'; procedure gdImageCharUp(im: pointer; f: pointer; x, y, c: integer; color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageCharUp@24'; procedure gdImageString(im: pointer; f: pointer; x, y: integer; s: pchar; color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageString@24'; procedure gdImageStringUp(im: pointer; f: pointer; x, y: integer; s: pchar; color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageStringUp@24'; procedure gdImageString16(im: pointer; f: pointer; x, y: integer; s: pchar; color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageString16@24'; procedure gdImageStringUp16(im: pointer; f: pointer; x, y: integer; s: pchar; color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageStringUp16@24'; procedure gdImageColorTransparent(im: Pointer; color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageColorTransparent@8'; //调色板 procedure gdImageTrueColorToPalette(im: Pointer; ditherFlag: integer; colorsWanted: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageTrueColorToPalette@12'; //使用交错式显示与否 procedure gdImageInterlace(im: Pointer; interlaceArg: Integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageInterlace@8'; function gdImagePngPtrEx(im: Pointer; size: PInteger; level: integer): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImagePngPtrEx@12'; function gdImagePngPtr(im: Pointer; size: PInteger): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImagePngPtr@8'; function gdImageCreateFromPngPtr(size: Integer; data: Pchar): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageCreateFromPngPtr@8'; function gdImageJpegPtr(im: Pointer; size: PInteger; quality: integer): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageJpegPtr@12'; function gdImageWBMPPtr(im: Pointer; size: PInteger; fg: integer): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageWBMPPtr@12'; function gdImageGifPtr(im: Pointer; size: PInteger): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageGifPtr@8'; function gdImageCreateFromGifPtr(size: Integer; data: Pchar): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageCreateFromGifPtr@8'; function gdImageGdPtr(im: Pointer; size: PInteger): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageGifPtr@8'; //结束图形 procedure gdImageDestroy(im: Pointer); stdcall; external 'bgd2.0.34.dll' name '_gdImageDestroy@4'; procedure gdFree(ByteArray: Pointer); stdcall; external 'bgd2.0.34.dll' name '_gdFree@4'; function gdFontCacheSetup: integer; stdcall; external 'bgd2.0.34.dll' name '_gdFontCacheSetup@0'; procedure gdFontCacheShutdown; stdcall; external 'bgd2.0.34.dll' name '_gdFontCacheShutdown@0'; procedure gdFreeFontCache; stdcall; external 'bgd2.0.34.dll' name '_gdFreeFontCache@0'; //字体加载 function gdFontGetGiant: pointer; stdcall; external 'bgd2.0.34.dll' name '_gdFontGetGiant@0'; function gdFontGetSmall: pointer; stdcall; external 'bgd2.0.34.dll' name '_gdFontGetSmall@0'; function gdFontGetTiny: pointer; stdcall; external 'bgd2.0.34.dll' name '_gdFontGetTiny@0'; //* Creates a palette-based image (up to 256 colors). */ // 建立新图 function gdImageCreate(sx: integer; sy: integer): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageCreate@8'; //* Creates a truecolor image (millions of colors). */ function gdImageCreateTrueColor(sx: integer; sy: integer): Pointer; stdcall; external 'bgd2.0.34.dll' name '_gdImageCreateTrueColor@8'; // 匹配颜色 function gdImageColorAllocate(im: Pointer; r, g, b: integer): integer; stdcall; external 'bgd2.0.34.dll' name '_gdImageColorAllocate@16'; //绘实线 procedure gdImageLine(im: Pointer; x1, y1, x2, y2, color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageLine@24'; //画弧线 procedure gdImageArc(im: Pointer; cx, cy, w, h, s, e, color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageArc@32'; //画填充矩形 procedure gdImageFilledRectangle(im: Pointer; x1, y1, x2, y2, color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageFilledRectangle@24'; //画矩形 procedure gdImageRectangle(im: Pointer; x1, y1, x2, y2, color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageRectangle@24'; //绘点 procedure gdImageSetPixel(im: Pointer; x, y, color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageSetPixel@16'; function gdImageStringTTF(im: Pointer; brect: pinteger; fg: integer; fontlist: pchar; ptsize, angle: double; x, y: integer; str: pchar): pchar; stdcall; external 'bgd2.0.34.dll' name '_gdImageStringTTF@44'; function gdImageStringFT(im: Pointer; brect: pinteger; fg: integer; fontlist: pchar; ptsize, angle: double; x, y: integer; str: pchar): pchar; stdcall; external 'bgd2.0.34.dll' name '_gdImageStringFT@44'; //procedure gdImageEllipse(im: pointer; cx, cy, w, h, color: integer); stdcall; // external 'bgd2.0.34.dll' name '_gdImageEllipse@24'; procedure gdImageFilledEllipse(im: pointer; cx, cy, w, h, color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageFillEllipse@24'; procedure gdImageFill(im: pointer; x, y, color: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageFill@16'; procedure gdImageCopy(dst, src: pointer; dstX, dstY, srcX, srcY, w, h: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageCopy@32'; procedure gdImageCopyMerge(dst, src: pointer; dstX, dstY, srcX, srcY, w, h, pct: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageCopyMerge@36'; {/* gd 2.0.8: gdImageCopyRotated is added. Source is a rectangle, with its upper left corner at srcX and srcY. Destination is the *center* of the rotated copy. Angle is in degrees, same as gdImageArc. Floating point destination center coordinates allow accurate rotation of objects of odd-numbered width or height. */ } procedure gdImageCopyRotated(dst, src: pointer; dstX, dstY: Double; srcX, srcY, srcWidth, srcHeight, angle: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageCopyRotated@44'; {/* Stretches or shrinks to fit, as needed. Does NOT attempt to average the entire set of source pixels that scale down onto the destination pixel. */} procedure gdImageCopyResized(dst, src: pointer; dstX, dstY, srcX, srcY: integer; dstW, dstH, srcW, srcH: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageCopyResized@40'; procedure gdImageSetStyle(im: pointer; style: pinteger; noOfPixels: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageSetStyle@12'; procedure gdImageSetThickness(im: pointer; thickness: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageSetThickness@8'; procedure gdImageAlphaBlending(im: pointer; alphaBlendingArg: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageAlphaBlending@8'; procedure gdImageSaveAlpha(im: pointer; saveAlphaArg: integer); stdcall; external 'bgd2.0.34.dll' name '_gdImageSaveAlpha@8'; procedure gdFTUseFontConfig(flag: integer); stdcall; external 'bgd2.0.34.dll' name '_gdFTUseFontConfig@4'; type TBitmapStyle = record //画片颜色定义 BitMap: integer; ImageWidth: integer; ImageHeight: integer; Frame: TColor; BackGround: TColor; TextFont: TColor; TagFont: TColor; TagBackGround: TColor; Transparent: boolean; end; TgdImageStyle = record //gd画片颜色定义 add by chugf BitMap: integer; //0=auto ,1=gif ,2=png ,3=wbmp ,4=jpg ImageWidth: integer; ImageHeight: integer; Frame: integer; BackGround: integer; TextFont: integer; TagFont: integer; TagBackGround: integer; White: integer; Green: integer; Fuchsia: integer; Yellow: integer; Lime: integer; Blue: integer; Teal: integer; Gray: integer; Other1: integer; Transparent: boolean; TransparentColor: integer; end; //存放已有的颜色 TColorList = record gdColor: integer; Color: TColor; end; type TgdImage = class private FgdImage: Pointer; FgdFont: Pointer; FColor: integer; FBrushColor: integer; FHeight: integer; FWidth: integer; FFontFile: string; FFontColor: integer; FFontSize: integer; FFontAngle: integer; FTransparent: boolean; FTransparentColor: integer; FColorList: array[0..99] of TColorList; //存放已有的颜色, 最多99种 FColorCount: integer; function IsValidPoint(x1, y1, x2, y2: integer): Boolean; function IsValidXY(x, y: integer): Boolean; protected function GetHeight: Integer; function GetWidth: Integer; function GetColor: integer; function GetgdFont: Pointer; function GetBrushColor: integer; function GetFontFile: string; function GetFontColor: integer; function GetFontSize: integer; function GetFontAngle: integer; function GetTransparent: boolean; function GetTransparentColor: integer; procedure SetHeight(Value: Integer); procedure SetWidth(Value: Integer); procedure SetColor(Value: integer); procedure SetgdFont(Value: Pointer); procedure SetBrushColor(Value: integer); procedure SetFontFile(Value: string); procedure SetFontColor(Value: integer); procedure SetFontSize(Value: integer); procedure SetFontAngle(Value: integer); procedure SetTransparent(Value: boolean); procedure SetTransparentColor(Value: integer); public FontWidth: integer; FontHeight: integer; constructor Create(Width, Height: integer); destructor Destroy; override; procedure TextOut(x: integer; y: integer; Text: string); //文字输出 procedure TextOutCH(x: integer; y: integer; Text: string); //文字输出 procedure Line(x1, y1, x2, y2: integer; Color: integer); //画线 procedure FilledRectangle(x1, y1, x2, y2: integer; Color: integer); //画填充矩形 procedure Rectangle(x1, y1, x2, y2: integer; Color: integer); //画矩形 procedure Pixel(x, y: integer; Color: integer); //画点 procedure Arc(cx, cy, w, h, s, e: integer; Color: integer); //画弧线 procedure FilledEllipse(cx, cy, w, h: integer; Color: integer); //椭圆形 procedure Fill(x, y: integer; Color: integer); //填充 procedure PolyLine(const Points: array of TPoint; const Color: integer); //连续画线 procedure FillUpTriangle(x1, y1, x2, y2, x3, y3: integer; Color: integer); //填充向上三角形 ↑ procedure FillDownTriangle(x1, y1, x2, y2, x3, y3: integer; Color: integer); //填充向下三角形 ↓ procedure CopyRotated90; //图片旋转90度 procedure CopyRotated180; //图片旋转180度 procedure CopyRotated270; //图片旋转270度 function Separates(num: integer): string; function ImagePngPtr2(Dest: pointer): string; //转换成Png function ColortoGDColor(Color: TColor): integer; //TColor转换成gd中的int型 function ImageJpegPtr: string; //转换成Jpeg function ImagePngPtr: string; //转换成Png function ImageGifPtr: string; //转换成Gif function ImageWBMPPtr: string; //转换成WBmp property Color: integer read GetColor write SetColor; //颜色 property BrushColor: integer read GetBrushColor write SetBrushColor; //刷子颜色 property FontFile: string read GetFontFile write SetFontFile; //字体文件 property FontColor: integer read GetFontColor write SetFontColor; //字体颜色 property FontSize: integer read GetFontSize write SetFontSize; //字体大小 property FontAngle: integer read GetFontAngle write SetFontAngle; //旋转角度 property Height: integer read GetHeight write SetHeight; //图片高度 property Width: integer read GetWidth write SetWidth; //图片宽度 property gdFont: Pointer read GetgdFont write SetgdFont; property TransparentColor: integer read GetTransparentColor write SetTransparentColor; property Transparent: boolean read GetTransparent write SetTransparent; end; procedure BitmaptoGDImageStyle(gdImage: TgdImage; BitmapStyle: TBitmapStyle; var gdImageStyle: TgdImageStyle); implementation procedure BitmaptoGDImageStyle(gdImage: TgdImage; BitmapStyle: TBitmapStyle; var gdImageStyle: TgdImageStyle); begin //gdImageStyle.ImageWidth := BitmapStyle.ImageWidth; //gdImageStyle.ImageHeight := BitmapStyle.ImageHeight; gdImageStyle.BitMap := BitmapStyle.BitMap; gdImageStyle.Frame := gdImage.ColortoGDColor(BitmapStyle.Frame); gdImageStyle.BackGround := gdImage.ColortoGDColor(BitmapStyle.BackGround); gdImageStyle.TextFont := gdImage.ColortoGDColor(BitmapStyle.TextFont); gdImageStyle.TagFont := gdImage.ColortoGDColor(BitmapStyle.TagFont); gdImageStyle.TagBackGround := gdImage.ColortoGDColor(BitmapStyle.TagBackGround); gdImageStyle.White := gdImage.ColortoGDColor(clWhite); gdImageStyle.Green := gdImage.ColortoGDColor(clGreen); gdImageStyle.Fuchsia := gdImage.ColortoGDColor(clFuchsia); gdImageStyle.Yellow := gdImage.ColortoGDColor(clYellow); gdImageStyle.Lime := gdImage.ColortoGDColor(clLime); gdImageStyle.Blue := gdImage.ColortoGDColor(clBlue); gdImageStyle.Teal := gdImage.ColortoGDColor(clTeal); gdImageStyle.Gray := gdImage.ColortoGDColor(clGray); //灰色 gdImageStyle.Other1 := gdImage.ColortoGDColor($FFFF50); gdImageStyle.TransparentColor := gdImageStyle.White; gdImageStyle.Transparent := BitmapStyle.Transparent; end; { TgdImage } function TgdImage.ColortoGDColor(Color: TColor): integer; var R, G, B: integer; c: integer; i: integer; begin for i := 0 to FColorCount - 1 do begin if FColorList[i].Color = Color then begin result := FColorList[i].gdColor; exit; end; end; R := Color and $000000FF; G := (Color and $0000FF00) shr 8; B := (Color and $00FF0000) shr 16; c := gdimagecolorallocate(FgdImage, R, G, B); //======= FColorList[FColorCount].gdColor := c; FColorList[FColorCount].Color := Color; inc(FColorCount); //======= result := c; end; constructor TgdImage.Create(Width, Height: integer); begin FHeight := Height; FWidth := Width; if FWidth > 640 then FWidth := 640; if FHeight > 640 then FHeight := 640; FFontFile := 'C:/WINDOWS/Fonts/SIMSUN.TTC'; //默认宋体字库 FFontSize := 8; FFontAngle := 0; FColorCount := 0; FTransparent := false; FgdImage := gdImageCreate(FWidth, FHeight); FgdFont := gdFontGetSmall; // gdFontGetTiny; FontWidth := 6; FontHeight := 8; if Width < 140 then begin FgdFont := gdFontGetTiny; FontWidth := 5; FontHeight := 6; end else if Width > 320 then begin FgdFont := gdFontGetGiant; FontWidth := 10; FontHeight := 12; end; //gdFontCacheSetup; //gdImageSetThickness(FgdImage, 1); //设置线宽 //FgdImage := gdImageCreateTrueColor(FWidth, FHeight); //gdImageAlphaBlending(FgdImage, 0); //gdImageSaveAlpha(FgdImage, 0); //gdFTUseFontConfig(0); end; destructor TgdImage.Destroy; begin // gdFontCacheShutdown; // gdFreeFontCache; if FgdImage <> nil then gdImageDestroy(FgdImage); inherited; end; function TgdImage.GetBrushColor: integer; begin result := FBrushColor; end; function TgdImage.GetColor: integer; begin result := FColor; end; function TgdImage.GetgdFont: Pointer; begin result := FgdFont; end; function TgdImage.GetFontAngle: integer; begin result := FFontAngle; end; function TgdImage.GetFontColor: integer; begin result := FFontColor; end; function TgdImage.GetFontFile: string; begin result := FFontFile; end; function TgdImage.GetFontSize: integer; begin if FFontSize <> 0 then result := FFontSize else result := 10; end; function TgdImage.GetHeight: Integer; begin result := FHeight; end; function TgdImage.GetWidth: Integer; begin result := FWidth; end; function TgdImage.Separates(num: integer): string; var Dest: pointer; iWidth, i, x: integer; list: TStringList; begin result := ''; iWidth := trunc(FWidth div num); list := TStringList.Create; try for i := 1 to num do begin x := iWidth * (i - 1); if i = num then iWidth := iWidth + (FWidth mod num); Dest := gdImageCreateTrueColor(iWidth, FHeight); try if FTransparent then gdImageColorTransparent(Dest, 0); gdImageCopy(Dest, FgdImage, 0, 0, x, 0, iWidth, FHeight); list.Add(ImagePngPtr2(Dest) + #13#10); //SetFiledata('./pic' + inttostr(i) + '.png', ImagePngPtr2(Dest)); finally gdImageDestroy(Dest); end; end; result := list.Text; finally //SetFiledata('./pic.txt', list.Text); list.Free; end; end; procedure TgdImage.SetBrushColor(Value: integer); begin FBrushColor := Value; end; procedure TgdImage.SetColor(Value: integer); begin FColor := Value; end; procedure TgdImage.SetgdFont(Value: Pointer); begin fgdfont := value; end; procedure TgdImage.SetFontAngle(Value: integer); begin FFontAngle := Value; end; procedure TgdImage.SetFontColor(Value: integer); begin FFontColor := Value; end; procedure TgdImage.SetFontFile(Value: string); begin FFontFile := Value; end; procedure TgdImage.SetFontSize(Value: integer); begin if Value <> 0 then FFontSize := Value else FFontSize := 8; end; procedure TgdImage.SetHeight(Value: Integer); begin FHeight := Value; end; procedure TgdImage.SetWidth(Value: Integer); begin FWidth := Value; end; function TgdImage.GetTransparentColor: integer; begin result := FTransparentColor; end; //只置属性，不影响图形，生效需调用SetTransparent procedure TgdImage.SetTransparentColor(Value: integer); begin if Value <> FTransparentColor then begin FTransparentColor := Value; end; end; function TgdImage.GetTransparent: boolean; begin result := FTransparent; end; procedure TgdImage.SetTransparent(Value: boolean); begin if Value <> FTransparent then FTransparent := Value; //指定透明背景色 if FTransparent then gdImageColorTransparent(FgdImage, FTransparentColor) else gdImageColorTransparent(FgdImage, -1); end; function TgdImage.IsValidPoint(x1, y1, x2, y2: integer): Boolean; begin result := (x1 >= -FWidth) and (x1 <= 2 * FWidth) and (x2 >= -FWidth) and (x2 <= 2 * FWidth) and (y1 >= -FHeight) and (y1 <= 2 * FHeight) and (y2 >= -FHeight) and (y2 <= 2 * FHeight); end; function TgdImage.IsValidXY(x, y: integer): Boolean; begin result := (X >= 0) and (x <= FWidth) and (y >= 0) and (y <= FHeight); end; procedure TgdImage.FilledRectangle(x1, y1, x2, y2: integer; Color: integer); begin //gd库的x,y(0,0)点从左上角开始 if IsValidPoint(x1, y1, x2, y2) then begin if y1 < y2 then gdImageFilledRectangle(FgdImage, x1, y1, x2, y2, Color) else gdImageFilledRectangle(FgdImage, x1, y2, x2, y1, Color); end; end; procedure TgdImage.Line(x1, y1, x2, y2: integer; Color: integer); begin if IsValidPoint(x1, y1, x2, y2) then gdimageline(FgdImage, x1, y1, x2, y2, Color); end; procedure TgdImage.Rectangle(x1, y1, x2, y2: integer; Color: integer); begin if IsValidPoint(x1, y1, x2, y2) then gdImageRectangle(FgdImage, x1, y1, x2, y2, Color); end; procedure TgdImage.PolyLine(const Points: array of TPoint; const Color: integer); var i: integer; begin for i := low(Points) to high(Points) - 1 do begin if IsValidPoint(Points[i].X, Points[i].Y, Points[i + 1].X, Points[i + 1].Y) then gdImageLine(FgdImage, Points[i].X, Points[i].Y, Points[i + 1].X, Points[i + 1].Y, Color); end; end; procedure TgdImage.Pixel(x, y: integer; Color: integer); begin if IsValidXY(x, y) then gdImageSetPixel(FgdImage, x, y, Color); end; procedure TgdImage.Fill(x, y: integer; Color: integer); begin if IsValidXY(x, y) then gdImageFill(FgdImage, x, y, Color); end; procedure TgdImage.FilledEllipse(cx, cy, w, h: integer; Color: integer); begin if IsValidXY(cx, cy) then gdImageFilledEllipse(FgdImage, cx, cy, w, h, Color); end; procedure TgdImage.Arc(cx, cy, w, h, s, e: integer; Color: integer); begin if IsValidXY(cx, cy) then gdimagearc(FgdImage, cx, cy, w, h, s, e, Color); end; procedure TgdImage.TextOut(x, y: integer; Text: string); var g: integer; begin if FWidth < 140 then g := 2 else if FWidth > 320 then g := 4 else g := 1; if IsValidXY(x, y) then gdImageString(FgdImage, FgdFont, x, y - (FontHeight div 2 - g), PChar(AnsiToUtf8(Text)), FFontColor); end; procedure TgdImage.TextOutCH(x, y: integer; Text: string); begin if IsValidXY(x, y) then gdImageStringFT(FgdImage, nil, FFontColor, PChar(FFontFile), FFontSize, FFontAngle, x, y, PChar(AnsiToUtf8(Text))); end; procedure TgdImage.CopyRotated90; var Dest: pointer; begin Dest := gdImageCreateTrueColor(FHeight, FWidth); try if FTransparent then gdImageColorTransparent(Dest, 0); gdImageCopyRotated(Dest, FgdImage, trunc(FHeight / 2), trunc(FWidth / 2), 0, 0, FWidth, FHeight, 90); //释放FgdImage，重新创建和加载图片 if FgdImage <> nil then gdImageDestroy(FgdImage); //FgdImage := gdImageCreate(FHeight, FWidth); FgdImage := gdImageCreateTrueColor(FHeight, FWidth); if FTransparent then gdImageColorTransparent(FgdImage, 0); gdImageCopy(FgdImage, Dest, 0, 0, 0, 0, FHeight, FWidth); //gdImageCopyResized(FgdImage, Dest, 0, 0, 0, 0, FHeight, FWidth, FHeight, FWidth); finally gdImageDestroy(Dest); end; end; procedure TgdImage.CopyRotated180; var Dest: pointer; begin Dest := gdImageCreateTrueColor(FHeight, FWidth); try if FTransparent then gdImageColorTransparent(Dest, 0); gdImageCopyRotated(Dest, FgdImage, trunc(FWidth / 2), trunc(FHeight / 2), 0, 0, FWidth, FHeight, 180); //释放FgdImage，重新创建和加载图片 if FgdImage <> nil then gdImageDestroy(FgdImage); //FgdImage := gdImageCreate(FWidth, FHeight); FgdImage := gdImageCreateTrueColor(FHeight, FWidth); if FTransparent then gdImageColorTransparent(FgdImage, 0); gdImageCopy(FgdImage, Dest, 0, 0, 0, 0, FWidth, FHeight); finally gdImageDestroy(Dest); end; end; procedure TgdImage.CopyRotated270; var Dest: pointer; begin Dest := gdImageCreateTrueColor(FHeight, FWidth); try if FTransparent then gdImageColorTransparent(Dest, 0); gdImageCopyRotated(Dest, FgdImage, trunc(FHeight / 2), trunc(FWidth / 2), 0, 0, FWidth, FHeight, 270); //释放FgdImage，重新创建和加载图片 if FgdImage <> nil then gdImageDestroy(FgdImage); FgdImage := gdImageCreateTrueColor(FHeight, FWidth); if FTransparent then gdImageColorTransparent(FgdImage, 0); gdImageCopy(FgdImage, Dest, 0, 0, 0, 0, FHeight, FWidth); finally gdImageDestroy(Dest); end; end; function TgdImage.ImageGifPtr: string; var pdata: pointer; Size: integer; begin gdImageTrueColorToPalette(FgdImage, 0, 128); gdImageInterlace(FgdImage, 0); pdata := gdImageGifPtr(FgdImage, @Size); //转换成Gif if pdata <> nil then begin SetString(result, pchar(pdata), Size); gdFree(pdata); end else result := ''; end; function TgdImage.ImageJpegPtr: string; var pdata: pointer; Size: integer; begin gdImageTrueColorToPalette(FgdImage, 0, 128); gdImageInterlace(FgdImage, 0); //pdata := gdImageJpegPtr(FgdImage, @Size, -1); //转换成Jpeg pdata := gdImageJpegPtr(FgdImage, @Size, 9); //比较模糊 if pdata <> nil then begin SetString(result, pchar(pdata), Size); gdFree(pdata); end else result := ''; end; function TgdImage.ImagePngPtr: string; begin result := ImagePngPtr2(FgdImage); end; function TgdImage.ImagePngPtr2(Dest: pointer): string; var pdata: pointer; Size: integer; begin gdImageTrueColorToPalette(Dest, 0, 128); gdImageInterlace(Dest, 0); pdata := gdImagePngPtrEx(Dest, @Size, 9); if pdata <> nil then begin SetString(result, pchar(pdata), Size); gdFree(pdata); end else result := ''; end; function TgdImage.ImageWBMPPtr: string; var pdata: pointer; Size: integer; fg: integer; begin gdImageTrueColorToPalette(FgdImage, 1, 8); gdImageInterlace(FgdImage, 0); fg := 0; pdata := gdImageWBMPPtr(FgdImage, @Size, fg); //转换成WBMP if pdata <> nil then begin SetString(result, pchar(pdata), Size); gdFree(pdata); end else result := ''; end; procedure TgdImage.FillUpTriangle(x1, y1, x2, y2, x3, y3, Color: integer); begin if IsValidPoint(x1, y1, x2, y2) then begin while (X1 < X2) do begin Line(X1, Y1, X2, Y2, Color); Line(X1, Y1, X3, Y3, Color); Line(X2, Y2, X3, Y3, Color); inc(X1); dec(Y1); dec(X2); dec(Y2); if (Y3 < Y1) then inc(Y3); end; end; end; procedure TgdImage.FillDownTriangle(x1, y1, x2, y2, x3, y3, Color: integer); begin if IsValidPoint(x1, y1, x2, y2) then begin while (X1 < X2) do begin Line(X1, Y1, X2, Y2, Color); Line(X1, Y1, X3, Y3, Color); Line(X2, Y2, X3, Y3, Color); inc(X1); inc(Y1); dec(X2); inc(Y2); if (Y3 > Y1) then dec(Y3); end; end; end; end.

 

  主单元调用绘制随即验证码示例：

  function GetRandomCheck(nLen: Integer; var ImageStr: string): string; var S: string; I: Integer; vPoint: TPoint; vLeft: Integer; Height, Width: integer; gdImage: TgdImage; gdColor: array[0..11] of integer; ColLen: integer; begin Randomize; Result := ''; if nLen <= 3 then nLen := 3; vLeft := 0; Height := 31; Width := (4 + 8) * (nLen + 1) + 4; gdImage := TgdImage.Create(Width, Height); try ColLen := Length(gdColor); gdImage.TransparentColor := gdImage.ColortoGDColor(clWhite); gdImage.Transparent := True; for i := 0 to ColLen - 1 do begin gdColor[i] := gdImage.ColortoGDColor(RGB(Random(256) and $C0, Random(256) and $C0, Random(256) and $C0)); end; for I := 1 to nLen do begin S := Format('%.1d', [Random(10)]); Result := Result + s; gdImage.FontSize := Random(10) + 9; gdImage.FontColor := gdColor[Random(100) mod ColLen]; vPoint.X := Random(4) + vLeft; vPoint.Y := Random(10) + 20; gdImage.TextOutCH(vPoint.X, vPoint.Y, S); vLeft := vPoint.X + Length(S) * 8; end; for I := 0 to 5 * nLen do begin gdImage.Color := gdColor[Random(100) mod ColLen]; vPoint.X := Random(vLeft); vPoint.Y := Random(30); gdImage.Line(vPoint.X + Random(3), vPoint.Y + Random(3), vPoint.X, vPoint.Y, gdImage.Color); end; ImageStr := gdImage.ImageGifPtr; finally gdImage.Free; end; end; procedure SaveFileData(FileName, Data: string); var f: TFileStream; s: integer; StrDire: string; begin try StrDire := ExtractFilePath(FileName); if StrDire <> '' then ForceDirectories(StrDire); if fileExists(FileName) then F := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyNone) else F := TFileStream.Create(FileName, fmCreate or fmShareDenyNone); s := F.Size; F.Seek(s, soFromBeginning); F.write(Data[1], Length(Data)); F.Free; except end; end; procedure TfrmMain.N1Click(Sender: TObject); var NumStr, ImageStr: string; begin NumStr := GetRandomCheck(4, ImageStr); SaveFileData('image.gif', ImageStr); Image1.Picture.Graphic := nil; Image1.Picture.LoadFromFile('image.gif'); end;

 

gd库下载地址：http://download.youkuaiyun.com/source/2442868

演示程序下载地址：http://download.youkuaiyun.com/source/2442868