保存的各函数

unit MySys;

interface

uses Windows, shlObj, Variants, StdCtrls, ComObj, Classes, SysUtils, Controls,
Printers, Messages, mmSystem, ComCtrls, UrlMon, winsock, TLhelp32, Registry,
Forms, Graphics, IniFiles, ADODB, StrUtils, ExtCtrls, jpeg, ShellAPI, Math,
MSHTML,IdStack,OleCtrls, SHDocVw,ActiveX,WinInet;

type
MyCharList = array[0..MAX_PATH] of Char;
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[Byte] of TRGBTriple;
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;
TShutReboot=(ShutDown,Reboot,Force,Logoff,Poweroff);
TGradientFillType = (rgsHorizontal, rgsVertical, rgsElliptic, rgsRectangle,
rgsVerticalCenter,
rgsHorizontalCenter, rgsNWSE, rgsNWSW, rgsSENW, rgsSWNE, rgsSweet,
rgsStrange, rgsNero);

const
Orignwidth = 800;
Orignheight = 600;

//-----------------------------------------------------------------------------------------
//字符串操作
function GetMemoSelectLineCount(Memo: TMemo): integer; //统计MEMO选定的行数
procedure MemoUndo(Memo: TMemo); //使Memo增加UNDO功能
function HZtoGB(S: string): string; //GB5转换
function GetLocaleInformation(Flag: integer): string; //获得系统本地信息
procedure PlayWav(const FileName: string; stopFlag: Boolean); //简单地播放和暂停WAV文件
function getit(S: string): integer; //获得双字节字符内码
procedure KeepScreen(Form: TForm);
function IsDigit(ch: Char): Boolean; {判断字符是否是数字}
function IsLower(ch: Char): Boolean; {判断字符是否是小写字符}
function p2pcount(S, ss1, ss2: string): integer; {返回两个子字符串之间字符的个数}
function ScanStr(ToScan: PChar; Sign: Char): PChar; {更快速的字符查询,快40%}
function HexToBin(HexNr: string): string; //把十六进制字符串转换为二进制字符串
function HexCharToInt(HexToken: Char): integer; //转换一个十六进制字符为整数
function HexCharToBin(HexToken: Char): string; //转换一个十六进制字符为二进制字符串
function pow(base, power: integer): integer; //指数函数
function BinStrToInt(BinStr: string): integer; //把二进制字符串转换为整数
function DecodeSMS7Bit(PDU: string): string; //解码一个7-bit SMS (GSM 03.38) 为ASCII码
function ReverseStr(SourceStr: string): string; //反转一个字符串
function DerivesFrom(Sender: TObject; Sorted: Boolean): TStrings; //获得子类的全部父类
function AnsiToUnicode(Ansi: string): string; //得到汉字的unicode
function ComboBoxIsDropDown(cmb: TComboBox): Boolean; //判断一个combobox是否处于下状态
//-----------------------------------------------------------------------------------------

//-----------------------------------------------------------------------------------------
//网络操作
function GetMACAddress: string; //获得本机网卡号
procedure SendMail(EmailAdd: string); //发送邮件
procedure OpenURL(url: string); //打开网页
function IsEMail(EMail: string): Boolean; //判断字符串是否是有效EMAIL地址
function NetInLine: Boolean;
function InetIsOffline(Flag: integer): Boolean; stdcall; external 'URL.DLL'; //判断系统是否连接INTERNET
procedure GetDomainList(TV: TTreeView); //查看网上邻居
function OpenIE(aURL: string): Boolean; //打开IE
function DownloadFile(Source, Dest: string): Boolean; //网络下载文件
function IPAddrToName(IPAddr: string): string; //解析服务器IP地址
function CheckShockwave: Boolean; //检测是否安装IE插件Shockwave&Quicktime
function IsIPText(str:string):Boolean; //判断str是否为有效的IP地址
procedure GetLinks(doc:IHTMLDocument2;var tsr:TStringList); //获得网页内的所有链接
function ConnnectToInternet:Boolean;
//-----------------------------------------------------------------------------------------

//-----------------------------------------------------------------------------------------
//文件操作
procedure DeleteExeAndDir; //删除程序本身
procedure deregisterFileType(ft: string); //删除文件名后缀与应用程序相关联
procedure GetProcessList(lst: TStrings); //列举当前系统运行进程
function GesSelfSize(ExeName: string): integer; //动态读取程序自身大小
function GetDiskSerial(DiskChar: Char): string; //读硬盘序列号
function EmptyDirectory(TheDirectory: string; Recursive: Boolean): Boolean; //如何清空一个目录
function GetDirectorySize(const ADirectory: string): integer; //如何计算一个目录的大小
procedure AddRecentFile(AFileName: string); //添加文件到最近访问的文件目录中
function GetRecentDir: string; //获得最近访问的文件
function GetShortName(sLongName: string): string; //长文件名转短文件名
function SetMySystemTime(Year, Month, Date: Word): Boolean; //设置系统时间
procedure GetSysPath(h: THandle; t: integer; varPath: MyCharList); //获得系统文件路径
procedure DeleteFiles(Handle: THandle; Source: string);
procedure MoveFile(Handle: THandle; Source, Dest: string);
function FileTimeToDateTime(AFileTime: TFileTime): TDateTime;
procedure GetTheFileTime(FileName: string; var DT1, DT2, DT3: TDateTime);
function FkFileListGet(vMask, vFolder: string; vSub: BOOL): TStringList;
function GetFileCount(ThePath, Ext: string): integer;
function GetDirCount(ThePath: string): integer;
procedure CutDir(SDir, DDir, SQz, SExt: string; MNum: integer; B: Boolean; Handle: THandle);
function Write_Inifile(IniF: TInifile; section, key: string; dtype: integer; value: variant): Boolean;
procedure WriteLogFile(WriteMode, LogFile, FileName: string; lstField: TStringList; iTag: integer = 0); overload; //写日志
procedure WriteLogFile(WriteMode, LogFile, FileName: string); overload;
procedure WriteLogFile(WriteMode, LogFile: string); overload;
function GetProgramPath: string; //获得Program file的路径
function selectdir: string; //选择目录
procedure CreateLink(ExePath,LinkName: WideString); //创建快捷方式
//-----------------------------------------------------------------------------------------

//-----------------------------------------------------------------------------------------
//数据库操作
function ExecQuery(var qry: TADOQuery; lstr: WideString): Boolean; //执行SQL语句(ExecSQL)
function MyTableExists(ADOConn: TADOConnection; const ATableName: string): Boolean;
procedure ShowQuery(var qry: TADOQuery; lstr: WideString); //执行SQL语句(Open)
procedure FillFieldToCombox(AdoTable: TADOQuery; Sql, FieldName: string; Combobox: TComboBox);
function DB_connect(connect: TADOConnection; Mode, Password, UserID, DBName, DBServer: string): Boolean; //连接数据库
function BackupDatabase(adoCon: TADOConnection; strFileName, DBName: string): Boolean; //备份数据库
function RestoreDatabase(adoQuery: TADOQuery; strPath, strName: string): integer; //还原数据库
function CompactAccess(srcfilename, tofilename: string): Boolean; //压缩ACCESS数据库
function RepaireAccess(FileName: string): Boolean; //修复数据库
function GetSelectText(TableName: string): string; //根据表名写出SELECT语句
//-----------------------------------------------------------------------------------------

//-----------------------------------------------------------------------------------------
//系统操作
function GetComputerName: string; //取得计算机名
procedure SetLocalTimer(ADOConnection: TADOConnection);
function SHFormatDrive(hWnd: hWnd; Drive: Word; fmtID: Word; Options: Word): Longint; stdcall; external 'Shell32.dll' name 'SHFormatDrive';
function FillString(str: string; leng: integer; chr: Char): string;
function ReplaceText(const S, ReplacePiece, ReplaceWith: string): string;
function Before(Src: string; var S: string): string;
//function IsSoundcardInstalled: longint; stdcall;external 'winmm.dll' name 'waveOutGetNumDevs'; //判断声卡是否存在
//shellExecute ( handle, 'open', 'rundll', 'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL ); //显示加入打印机对话框
//SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0); //关闭显示器
procedure hideicons; //隐藏桌面程序图标
procedure showicon; //显示桌面程序图标
function CheckSound: Boolean;
function ToBigRMB(RMB: string): string;
function WindowsVersion(var verinfo: string): integer; //获得WINDOWS版本信息
function FormatDrive(Handle: hWnd): integer;
function ReadStrRegistry(Root: HKEY; Path, key, value: string): Boolean; //读注册表
function WriteStrToRegistry(Root: HKEY; Path, key, value: string): Boolean; //写注册表
procedure SetSysState(state: Boolean); //屏蔽，开启系统功能键
procedure GetScreenMetric(var x, y: integer); //获取分辨率
function DynamicResolution(x, y: Word): BOOL; //改变分辨率
procedure MinMaxAll(bol: Boolean); //最大最小化
function GetCpuSpeed: Comp; //获取CPU时钟频率
function EnumWinProc(Wnd: hWnd; lst: TStrings): Boolean; //获得应用程序列表
procedure GetMetrics(Width, Height: integer); //获得屏幕分辨率
procedure GetPrintMatrics(Horz, Vert: integer); //获得打印机分辨率
function SoftIce95Running: Boolean; //怎样发现是否有 SOFTICE在运行
function SoftIceNTRunning: Boolean; //怎样发现是否有 SOFTICE在运行
procedure GetServerTime(ServerName: string); //获取服务器端的日期时间
procedure Monitor(S: string); //打开/关闭显示器
function RunInIDE: Boolean; //判断程序是否在IDE下运行
procedure RefreshDesktop; //刷新桌面
procedure ShowIcons(tag: Boolean); //显示或隐藏桌面图标
procedure PlayASound(tag: Word); //播放系统声音
procedure EnumPorts( PortList: TStrings ); //列举串口
procedure CloseWindow(Flag:TShutReboot); //关闭计算机或重启
//-----------------------------------------------------------------------------------------

//-----------------------------------------------------------------------------------------
//图形图像操作
procedure TColorToRGB(Color: TColor; var R, G, B: integer); //TColor转换为RGB值
function RgbToGray(Source: TColor): TColor; //颜色值转换为灰度值
procedure TextOutAngle(x, y, aAngle, aSize: integer; txt: string); //字体旋转
procedure SetAutoRun; //Windows开机自动运行的应用程序
procedure FadeOut(const BMP: TImage; Pause: integer); //BITMAP 淡入淡出效果
procedure CopyImageToBitmap(im: TImage; bm: tBitmap); //将图像转换为BITMAP
procedure BmpToIco(aBmp, aIco: string);
procedure BMPToJPG(BmpFileName, JpegFileName: string);
procedure JPGToBMP(JpegFileName, BmpFileName: string);
procedure WmfToBmp(FicheroWmf, FicheroBmp: string);
procedure BmpToWmf(BmpFile, WmfFile: string);
procedure DrawTrans(DestCanvas: TCanvas; x, y: smallint; SrcBitmap: tBitmap; AColor, BackColor: TColor); //绘制透明位图
procedure TextOutAngled(canvas: TCanvas; iCoordX, iCoordY: integer; const sString: string; iAngle, iSize: integer); //绘制倾斜文本
procedure Display(canvas: TCanvas; BMP: tBitmap; rect: TRect); //逆时针方向显示位图
procedure Twist(var BMP, Dst: tBitmap; Amount: integer); //图像扭曲算法
procedure ShowPicture(canvas: TCanvas; img: TImage; step: integer; PlayMode: integer); //图像载入显示效果(百叶窗，雨滴，随机等效果)
procedure ShowDanru(hnd: hWnd; canvas: TCanvas; img: TImage; strFileName: string); //淡入效果
procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer); //输出旋转字
procedure SetGray(SBmp, DBmp: tBitmap; iTag: integer); //灰度处理
procedure GrayDiagram(BMP: tBitmap; Image1, Image2: TImage); //求灰度直方图
procedure SetTwo(SBmp, DBmp: tBitmap); //二值化
procedure SetBright(SBmp, DBmp: tBitmap); //亮度调节
procedure SetContact(SBmp, DBmp: tBitmap); //对比度
procedure SetHue(SBmp, DBmp: tBitmap); //饱和度
procedure SetColor(aSource, ATarget: tBitmap; AColor: TColor); //图像着色
procedure SetInvert(SBmp, DBmp: tBitmap); //图像反色
procedure SetBaoguang(SBmp, DBmp: tBitmap); //图像曝光
procedure SetGamma(SBmp, DBmp: tBitmap); //Gamma校正
procedure SetNoise(SBmp, DBmp: tBitmap); //噪声调节
procedure Pingyi(SBmp, DBmp: tBitmap); //图像平移
procedure LeftRightMirror(SBmp, DBmp: tBitmap); //水平镜像
procedure Rotateangle(SBmp, DBmp: tBitmap; angle: extended); //任意角度旋转
procedure TwistPicture(BMP, Dst: tBitmap; Amount: integer); //图像的扭曲
procedure WaveWrap(SBmp, DBmp: tBitmap; XDIV, YDIV, RatioVal: integer); { TODO : 扭曲 }
procedure TiltBitmap(const InBitmap, OutBitmap: tBitmap;
const WidthTop, WidthBottom: integer); //远视图
procedure HSLtoRGB(h, S, L: integer; var R, G, B: integer);
procedure RGBtoHSL(R, G, B: integer; var h, S, L: integer);
procedure HSLBright(SBmp, DBmp: tBitmap); //基于HSL颜色系统的亮度调节
procedure HSLSaturation(SBmp, DBmp: tBitmap); //基于HSL颜色系统的饱和度调节
procedure RGBTripleToCMY(const RGB: TRGBTriple; var C, M, y: integer); //RGB到CMY颜色系统的转换
function CMYToRGBTriple(const C, M, y: integer): TRGBTriple;
procedure RGBTripleToCMYK(const RGB: TRGBTriple; var C, M, y, K: integer); //RGB到CMYK颜色系统的转换
function CMYKToRGBTriple(const C, M, y, K: integer): TRGBTriple;
procedure RGBTripleToHSV(const RGB: TRGBTriple; var h, S, V: integer); //RGB到HSV颜色系统的转换
function HSVToRGBTriple(const h, S, V: integer): TRGBTriple;
function RGBToRGBTriple(R, G, B: integer): TRGBTriple;
procedure GetRedChannel(SBmp, DBmp: tBitmap); //获得红色通道
procedure GetBlueChannel(SBmp, DBmp: tBitmap); //获得蓝色通道
procedure GetGreenChannel(SBmp, DBmp: tBitmap); //获得绿色通道
procedure GetCChannel(SBmp, DBmp: tBitmap); //获得C通道
procedure GetMChannel(SBmp, DBmp: tBitmap); //获得M通道
procedure GetYChannel(SBmp, DBmp: tBitmap); //获得Y通道
procedure RGBAdjust(SBmp, DBmp: tBitmap); //RGB颜色调整
procedure PaintRainbow(Dc: hDc; {Canvas to paint to}
x: integer; {Start position X}
y: integer; {Start position Y}
Width: integer; {Width of the rainbow}
Height: integer {Height of the rainbow};
bVertical: BOOL; {Paint verticallty}
WrapToRed: BOOL);
procedure RbsGradientFill(canvas: TCanvas; grdType: TGradientFillType; fromCol: TColor; toCol: TColor; ARect: TRect);
procedure GraySharpLine(SBmp, DBmp: tBitmap); //灰度线性变换
procedure GraySharpNotLine(SBmp, DBmp: tBitmap); //灰度非线性变换
procedure GrayStrech(SBmp, DBmp: tBitmap); //灰度拉伸
procedure SetSharp(SBmp, DBmp: tBitmap); //图像锐化
procedure SetSmooth(SBmp, DBmp: tBitmap); //图像平滑
procedure FakeColorSharp(SBmp, DBmp: tBitmap); //伪彩色增强
procedure MidFilter(SBmp, DBmp: tBitmap); //中值滤波
procedure PictureTwoValue(SBmp, DBmp: tBitmap); //二值化
function BitmapErose(SBmp, DBmp: tBitmap; Horic: Boolean): Boolean; //腐蚀
function BitmapDilate(SBmp,DBmp: TBitmap; Hori: Boolean): Boolean; //膨胀
procedure GetLunkuo(SBmp,DBmp: TBitmap); //轮廓提取
function Xihua(SBmp,DBmp: TBitmap): Boolean; //细化
procedure SetSobel(SBmp,DBmp: TBitmap); //边沿检测
procedure SetPrewitte(SBmp,DBmp: TBitmap); //Prewitte边沿检测
procedure HorizonProjection(SBmp,DBmp: TBitmap; Horic: Boolean); //竖直投影
procedure Convolve(ray: array of integer; z: word; SBmp,DBmp: TBitmap); //Hough变换
//-----------------------------------------------------------------------------------------

//-----------------------------------------------------------------------------------------
//数据结构
procedure InsertionSort(Items: TStrings); //插入排序
procedure BubbleSort(Items: TStrings); //冒泡排序
function gcd(a, B: integer): integer; //最大公约数
function lcm(a, B: integer): integer; //最小公倍数
function DecToRoman(iDecimal: Longint): string; //转换数字到罗马字符串
procedure SelectionSort(var a: array of integer); //选择排序
procedure QuickSortt(var a: array of integer); //快速排序
function Encrypt(const S: string; key: Word): string; //加密
function Decrypt(const S: string; key: Word): string; //解密
procedure OpenCDRom(bol: Boolean);
//-----------------------------------------------------------------------------------------

const
cWIN_95 = 1; { Windows version constants}
cWIN_98 = 2;
cWIN_NT = 3; // NT 4.0
cWIN_2000 = 4;
cWIN_ME = 5;
cWIN_XP = 6;
C1 = 52845;
C2 = 22719;

var
Grayclass: array[0..255] of integer;
OriginalRangeLeft, OriginalRangeRight: integer;

implementation

procedure GetSysPath(h: THandle; t: integer; varPath: MyCharList);
var
SFolder: pItemIDList;
SpecialPath: MyCharList;
begin
SHGetSpecialFolderLocation(h, t, SFolder);
SHGetPathFromIDList(SFolder, SpecialPath);
varPath := SpecialPath;
end;

function GetShortName(sLongName: string): string;
var
sShortName: string;
nShortNameLen: integer;
begin
SetLength(sShortName,
MAX_PATH);
nShortNameLen :=
GetShortPathName(
PChar(sLongName),
PChar(sShortName),
MAX_PATH - 1);
if (0 = nShortNameLen) then begin
// handle errors...
end;
SetLength(sShortName,
nShortNameLen);
Result := sShortName;

end;

function SetMySystemTime(Year, Month, Date: Word): Boolean;
var
MyTime: TSystemTime;
begin
Result := True;
FillChar(MyTime, sizeof(MyTime), #0);
MyTime.wYear := Year;
MyTime.wMonth := Month;
MyTime.wDay := Date;
// fill out more.. important!
if not SetSystemTime(MyTime) then
Result := False;
end;

function OpenIE(aURL: string): Boolean;
var
IE: variant;
WinHanlde: hWnd;
begin
Result := True;
if (VarIsEmpty(IE)) then begin
IE := CreateOleObject('InternetExplorer.Application');
IE.Visible := True;
IE.Navigate(aURL);
end
else begin
WinHanlde := FindWIndow('IEFrame', nil);
if (0 <> WinHanlde) then begin
IE.Navigate(aURL);
SetForegroundWindow(WinHanlde);
end
else
Result := False;
end;
end;

function EnumWinProc(Wnd: hWnd; lst: TStrings): Boolean;
var
WinText: array[0..255] of Char;
begin
GetWindowText(Wnd, WinText, 255);
Result := True;
if (StrPas(WinText) <> '') then
lst.Add(StrPas(WinText));
end;

procedure GetMetrics(Width, Height: integer);
begin
Width := GetSystemMetrics(SM_CXSCREEN);
Height := GetSystemMetrics(SM_CYSCREEN);
end;

procedure AddRecentFile(AFileName: string);
begin
{ Add file to Recent directory }
SHAddtoRecentDocs(SHARD_PATH, PChar(AFileName));
end;

function GetRecentDir: string;
var
PIDL: pItemIDList;
RecentPath: array[0..MAX_PATH] of Char;
begin

{ Get the PItemIDList for CSIDL_NETWORK }
SHGetSpecialFolderLocation(0,
CSIDL_RECENT,
PIDL);

{ convert our special folder location to a string}
SHGetPathFromIDList(PIDL,
RecentPath);

{ return our special folder location as a string }
Result := RecentPath;
end;

procedure GetPrintMatrics(Horz, Vert: integer);
begin
Vert := GetDeviceCaps(Printer.Handle, LogPixelsX);
Horz := GetDeviceCaps(Printer.Handle, LogPixelsY);
end;

function GetMemoSelectLineCount(Memo: TMemo): integer;
var
S, e: integer;
begin
with Memo do begin
S := sendmessage(Handle, EM_LINEFROMCHAR, selstart, 0);
e := sendmessage(Handle, EM_LINEFROMCHAR, selstart + selLength, 0);
end;
Result := e - S;
end;

procedure PlayASound(tag: Word);
begin
PlaySound(PChar('SYSTEMSTART'), 0, tag);
end;

procedure Monitor(S: string);
begin
if UpperCase(S) = 'ON' then
sendmessage(0, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
if UpperCase(S) = 'OFF' then
sendmessage(0, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
end;

procedure MemoUndo(Memo: TMemo);
begin
Memo.Perform(EM_UNDO, 0, 0);
end;

procedure ShowIcons(tag: Boolean);
var
h, hchild: hWnd;
begin
if tag then begin
h := FindWIndow(nil, 'Program Manager');
if h > 0 then begin
h := getwindow(h, GW_CHILD);
showwindow(h, SW_SHOW);
hchild := getwindow(h, GW_CHILD);
showwindow(hchild, SW_SHOW);
end;
end
else begin
h := FindWIndow(nil, 'Program Manager');
if h > 0 then begin
h := getwindow(h, GW_CHILD);
showwindow(h, SW_HIDE);
hchild := getwindow(h, GW_CHILD);
showwindow(hchild, SW_HIDE);
showwindow(h, SW_SHOW);
end;
end;
end;

procedure GetDomainList(TV: TTreeView);
var
a: integer;
ErrCode: integer;
NetRes: array[0..1023] of TNetResource;
EnumHandle: THandle;
EnumEntries: DWord;
BufferSize: DWord;
S: string;
itm: TTreeNode;
begin
{ Start here }
begin
with NetRes[0] do begin
dwScope := RESOURCE_GLOBALNET;
dwType := RESOURCETYPE_ANY;
dwDisplayType := RESOURCEDISPLAYTYPE_DOMAIN;
dwUsage := RESOURCEUSAGE_CONTAINER;
lpLocalName := nil;
lpRemoteName := nil;
lpComment := nil;
lpProvider := nil;
end;
{ get net root }
ErrCode := WNetOpenEnum(
RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
RESOURCEUSAGE_CONTAINER,
@NetRes[0],
EnumHandle
);
if ErrCode = NO_ERROR then begin
EnumEntries := 1;
BufferSize := sizeof(NetRes);
ErrCode := WNetEnumResource(
EnumHandle,
EnumEntries,
@NetRes[0],
BufferSize
);
WNetCloseEnum(EnumHandle);
ErrCode := WNetOpenEnum(
RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
RESOURCEUSAGE_CONTAINER,
@NetRes[0],
EnumHandle
);
EnumEntries := 1024;
BufferSize := sizeof(NetRes);
ErrCode := WNetEnumResource(
EnumHandle,
EnumEntries,
@NetRes[0],
BufferSize
);
end;
if ErrCode = NO_ERROR then begin
with TV do begin
a := 0;
Items.BeginUpDate;
Items.Clear;
itm := Items.Add(TV.Selected, string(NetRes[0].lpProvider));
itm.ImageIndex := 0;
itm.SelectedIndex := 0;
end;
end;
end;
end;

function HZtoGB(S: string): string;
begin
//
end;

function GetLocaleInformation(Flag: integer): string;
var
pcLCA: array[0..20] of Char;
begin
if (GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, Flag, pcLCA, 19) <= 0) then begin
pcLCA[0] := #0;
end;
Result := pcLCA;
end;

function IsEMail(EMail: string): Boolean;
var
S: string; ETpos: integer;
begin
ETpos := pos('@', EMail);
if ETpos > 1 then begin
S := copy(EMail, ETpos + 1, Length(EMail));
if (pos('.', S) > 1) and (pos('.', S) < Length(S)) then
Result := True
else
Result := False;
end
else
Result := False;
end;

function NetInLine: Boolean;
begin
Result := not InetIsOffline(0);
end;

procedure PlayWav(const FileName: string; stopFlag: Boolean);
begin
if stopFlag then
PlaySound(PChar(FileName), 0, SND_ASYNC)
else
PlaySound(PChar(FileName), 0, SND_PURGE);
end;

function DownloadFile(Source, Dest: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(Source), PChar(Dest), 0, nil) = 0;
except
Result := False;
end;
end;

function IPAddrToName(IPAddr: string): string;
var
SockAddrIn: TSockAddrIn;
HostEnt: PHostEnt;
WSAData: TWSAData;
begin
WSAStartup($101, WSAData);
SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr));
HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.s_addr, 4, AF_INET);
if HostEnt <> nil then
Result := StrPas(HostEnt^.h_name)
else
Result := '';
end;

function EmptyDirectory(TheDirectory: string; Recursive: Boolean): Boolean;
var
SearchRec: TSearchRec;
Res: integer;
begin
Result := False;
Res := FindFirst(TheDirectory + '*.*', faAnyFile, SearchRec);
try
while Res = 0 do begin
if (SearchRec.name <> '.') and (SearchRec.name <> '..') then begin
if ((SearchRec.Attr and faDirectory) > 0) and Recursive then begin
EmptyDirectory(TheDirectory + SearchRec.name, True);
RemoveDirectory(PChar(TheDirectory + SearchRec.name));
end
else begin
DeleteFile(PChar(TheDirectory + SearchRec.name))
end;
end;
Res := FindNext(SearchRec);
end;
Result := True;
finally
FindClose(SearchRec);
end;
end;

function GetDirectorySize(const ADirectory: string): integer;
var
Dir: TSearchRec;
Ret: integer;
Path: string;
begin
Result := 0;
Path := ExtractFilePath(ADirectory);
Ret := SysUtils.FindFirst(ADirectory, faAnyFile, Dir);
if Ret <> NO_ERROR then exit;
try
while Ret = NO_ERROR do begin
inc(Result, Dir.Size);
if (Dir.Attr in [faDirectory]) and (Dir.name[1] <> '.') then
inc(Result, GetDirectorySize(Path + Dir.name + '\*.*'));
Ret := SysUtils.FindNext(Dir);
end;
finally
SysUtils.FindClose(Dir);
end;
end;

function getit(S: string): integer;
begin
Result := Byte(S[1]) * $100 + Byte(S[2]);
end;

procedure GetProcessList(lst: TStrings);
var
lppe: TProcessEntry32;
found: Boolean;
Hand: THandle;
begin
Hand := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0);
found := Process32First(Hand, lppe);
while found do begin
lst.Add(StrPas(lppe.szExeFile));
found := Process32Next(Hand, lppe);
end;
end;

function GesSelfSize(ExeName: string): integer;
var
f: file of Byte;
begin
filemode := 0;
assignfile(f, ExeName);
reset(f);
Result := filesize(f); //单位是字节
closefile(f);
end;

function CheckSoundCard: Boolean;
begin
Result := (auxGetNumDevs() <= 0) //为FALSE无声卡,TRUE有声卡
end;

function GetDiskSerial(DiskChar: Char): string;
var
SerialNum: pdword;
a, B: DWord;
Buffer: array[0..255] of Char;
begin
Result := '';
if GetVolumeInformation(PChar(DiskChar + ':\'), Buffer, sizeof(Buffer), SerialNum, a, B, nil, 0) then
a := 1;
Result := '';
end;

function CheckShockwave: Boolean;
begin
{var myPlugin = navigator.plugins["Shockwave"];
if (myPlugin)
document.writeln("你已经安装了 Shockwave!")
else
document.writeln("你尚未安装 Shockwave!")}
end;

function SoftIce95Running: Boolean;
var
hFile: THandle;
begin
Result := False;
hFile := CreateFile('\\.\SICE',
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hFile <> INVALID_HANDLE_VALUE then begin
CloseHandle(hFile);
Result := True;
end;
end;

function SoftIceNTRunning: Boolean;
var
hFile: THandle;
begin
Result := False;
hFile := CreateFile('\\.\NTICE',
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hFile <> INVALID_HANDLE_VALUE then begin
CloseHandle(hFile);
Result := True;
end;
end;

procedure GetServerTime(ServerName: string);
var
strCommand: string;
begin
strCommand := 'net time \\' + ServerName + ' /set /yes';
winexec(PChar(strCommand), SW_HIDE);
end;

procedure deregisterFileType(ft: string);
var
myreg: TRegistry;
key: string;
begin
myreg := TRegistry.Create;
myreg.RootKey := HKEY_CLASSES_ROOT;
myreg.OpenKey(ft, False);
key := myreg.ReadString('');
myreg.CloseKey;
myreg.DeleteKey(ft);
myreg.DeleteKey(key);
myreg.Free;
// 调用例子：
// Example:
// deregisterFileType('.tst');
end;

procedure KeepScreen(Form: TForm);
begin
Form.Scaled := True;
if (screen.Width <> Orignwidth) then begin
Form.Height := Longint(Form.Height) * Longint
(screen.Height) div Orignheight;
Form.Width := Longint(Form.Width) * Longint
(screen.Width) div Orignwidth;
Form.scaleby(screen.Width, Orignwidth);
end;
end;

function IsDigit(ch: Char): Boolean;
begin
Result := ch in ['0'..'9'];
end;

function IsLower(ch: Char): Boolean;
begin
Result := ch in ['a'..'z'];
end;

function p2pcount(S, ss1, ss2: string): integer;
var i, j, slen: integer;
begin
i := pos(ss1, S);
j := pos(ss2, S);
slen := Length(ss2);
if j >= i then Result := j - i + slen else Result := 0;
end;

function ScanStr(ToScan: PChar; Sign: Char): PChar;
begin
Result := nil;
if ToScan <> nil then
while (ToScan^ <> #0) do begin
if ToScan^ = Sign then begin
Result := ToScan;
break;
end;
inc(ToScan);
end;
end;

function HexCharToInt(HexToken: Char): integer;
begin
{if HexToken>#97 then HexToken:=Chr(Ord(HexToken)-32);
{ use lowercase aswell }

Result := 0;

if (HexToken > #47) and (HexToken < #58) then { chars 0....9 }
Result := Ord(HexToken) - 48
else if (HexToken > #64) and (HexToken < #71) then { chars A....F }
Result := Ord(HexToken) - 65 + 10;
end;

function HexCharToBin(HexToken: Char): string;
var DivLeft: integer;
begin
DivLeft := HexCharToInt(HexToken); { first HEX->BIN }
Result := '';
{ Use reverse dividing }
repeat { Trick; divide by 2 }
if odd(DivLeft) then { result = odd ? then bit = 1 }
Result := '1' + Result { result = even ? then bit = 0 }
else
Result := '0' + Result;

DivLeft := DivLeft div 2; { keep dividing till 0 left and length = 4 }
until (DivLeft = 0) and (Length(Result) = 4); { 1 token = nibble = 4 bits }
end;

function HexToBin(HexNr: string): string;
{ only stringsize is limit of binnr }
var Counter: integer;
begin
Result := '';

for Counter := 1 to Length(HexNr) do
Result := Result + HexCharToBin(HexNr[Counter]);
end;

function pow(base, power: integer): integer;
var Counter: integer;
begin
Result := 1;

for Counter := 1 to power do
Result := Result * base;
end;

function BinStrToInt(BinStr: string): integer;
var Counter: integer;
begin
if Length(BinStr) > 16 then
raise ERangeError.Create(#13 + BinStr + #13 +
'is not within the valid range of a 16 bit binary.' + #13);

Result := 0;

for Counter := 1 to Length(BinStr) do
if BinStr[Counter] = '1' then
Result := Result + pow(2, Length(BinStr) - Counter);
end;

function DecodeSMS7Bit(PDU: string): string;
var OctetStr: string;
OctetBin: string;
Charbin: string;
PrevOctet: string;
Counter: integer;
Counter2: integer;
begin
PrevOctet := '';
Result := '';

for Counter := 1 to Length(PDU) do begin
if Length(PrevOctet) >= 7 then { if 7 Bit overflow on previous } begin
if BinStrToInt(PrevOctet) <> 0 then
Result := Result + chr(BinStrToInt(PrevOctet))
else Result := Result + ' ';

PrevOctet := '';
end;

if odd(Counter) then { only take two nibbles at a time } begin
OctetStr := copy(PDU, Counter, 2);
OctetBin := HexToBin(OctetStr);

Charbin := '';
for Counter2 := 1 to Length(PrevOctet) do
Charbin := Charbin + PrevOctet[Counter2];

for Counter2 := 1 to 7 - Length(PrevOctet) do
Charbin := OctetBin[8 - Counter2 + 1] + Charbin;

if BinStrToInt(Charbin) <> 0 then Result := Result + chr(BinStrToInt(Charbin))
else Result := Result + ' ';

PrevOctet := copy(OctetBin, 1, Length(PrevOctet) + 1);
end;
end;
end;

function ReverseStr(SourceStr: string): string;
var Counter: integer;
begin
Result := '';

for Counter := 1 to Length(SourceStr) do
Result := SourceStr[Counter] + Result;
end;

procedure DeleteExeAndDir;
var hModule: THandle;
szModuleName, szDirName: array[0..MAX_PATH] of Char;
hKrnl32: THandle;
pExitProcess, pDeleteFile, pUnmapViewOfFile, pRemoveDir: pointer;
ExitCode: UINT;
var R: integer;
begin
hModule := GetModuleHandle(nil);
GetModuleFileName(hModule, szModuleName, sizeof(szModuleName));
StrPCopy(szDirName, ExtractFileDir(szModuleName));
hKrnl32 := GetModuleHandle('kernel32');
pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');
pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');
pUnmapViewOfFile := GetProcAddress(hKrnl32, 'UnmapViewOfFile');
pRemoveDir := GetProcAddress(hKrnl32, 'RemoveDirectoryA');
ExitCode := system.ExitCode;

SetCurrentDirectory(PChar(ExtractFileDir(szDirName)));
if ($80000000 and GetVersion()) = 0 then begin
for R := 1 to 100 do begin
CloseHandle(R shl 2);
end;
end;

asm
lea eax, szModuleName
lea ecx, szDirName
push ExitCode
push 0
push ecx
push pExitProcess
push eax
push pRemoveDir
push hModule
push pDeleteFile
push pUnmapViewOfFile
ret
end
end;

function DerivesFrom(Sender: TObject; Sorted: Boolean): TStrings;
var
ClassRef: TClass;
Ancestorlist: TStringList;
SwitchList: TStringList;
Loopint: integer;

begin
Ancestorlist := TStringList.Create;
ClassRef := Sender.ClassType;
while ClassRef <> nil do begin
Ancestorlist.Add(ClassRef.ClassName);
ClassRef := ClassRef.ClassParent;
end;
if (not Sorted) then begin
Result := Ancestorlist;
exit;
end
else begin
SwitchList := TStringList.Create;
for Loopint := Ancestorlist.Count - 1 downto 0 do
SwitchList.Add(Ancestorlist.Strings[Loopint]);

Ancestorlist.Free;
Result := SwitchList;
end;
end;

function RunInIDE: Boolean;
begin
Result := (DebugHook = 1); //为1时运行在IDE下
end;

procedure RefreshDesktop;
begin
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;

procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);
var
LogFont: TLogFont;
SaveFont: TFont;
begin
SaveFont := TFont.Create;
SaveFont.Assign(CV.Font);
GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);
with LogFont do begin
lfEscapement := angle * 10;
lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;
end; {with}
CV.Font.Handle := CreateFontIndirect(LogFont);
SetBkMode(CV.Handle, TRANSPARENT);
CV.TextOut(x, y, sText);
CV.Font.Assign(SaveFont);
SaveFont.Free;
end;

function AnsiToUnicode(Ansi: string): string;
var
S: string;
i: integer;
j, K: string[2];
a: array[1..1000] of Char;
begin
S := '';
StringToWideChar(Ansi, @(a[1]), 500);
i := 1;
while ((a[i] <> #0) or (a[i + 1] <> #0)) do begin
j := IntToHex(integer(a[i]), 2);
K := IntToHex(integer(a[i + 1]), 2);
S := S + K + j;
i := i + 2;
end;
Result := S;
end;

function ReadHex(AString: string): integer;

begin

Result := StrToInt('$' + AString)

end;

function UnicodeToAnsi(Unicode: string): string;
var
S: string;
i: integer;
j, K: string[2];
begin
i := 1;
S := '';
while i < Length(Unicode) + 1 do begin
j := copy(Unicode, i + 2, 2);
K := copy(Unicode, i, 2);
i := i + 4;
S := S + Char(ReadHex(j)) + Char(ReadHex(K));
end;
if S <> '' then
S := WideCharToString(PWideChar(S + #0#0#0#0))
else
S := '';
Result := S;
end;

function ComboBoxIsDropDown(cmb: TComboBox): Boolean;
begin
Result := (sendmessage(cmb.Handle, CB_GETDROPPEDSTATE, 0, 0) = 1);
end;

function GetMACAddress: string;

procedure RunDosCommand(Command: string; Output: TStrings);
var
hReadPipe: THandle;
hWritePipe: THandle;
SI: TStartUpInfo;
PI: TProcessInformation;
SA: TSecurityAttributes;
BytesRead: DWord;
Dest: array[0..1023] of Char;
CmdLine: array[0..512] of Char;
TmpList: TStringList;
Avail, ExitCode, wrResult: DWord;
osVer: TOSVERSIONINFO;
tmpstr: AnsiString;
begin
osVer.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
GetVersionEX(osVer);

if osVer.dwPlatformId = VER_PLATFORM_WIN32_NT then begin
SA.nLength := sizeof(SA);
SA.lpSecurityDescriptor := nil; //@SD;
SA.bInheritHandle := True;
CreatePipe(hReadPipe, hWritePipe, @SA, 0);
end
else
CreatePipe(hReadPipe, hWritePipe, nil, 1024);
try
screen.Cursor := crHourglass;
FillChar(SI, sizeof(SI), 0);
SI.cb := sizeof(TStartUpInfo);
SI.wShowWindow := SW_HIDE;
SI.dwFlags := STARTF_USESHOWWINDOW;
SI.dwFlags := SI.dwFlags or STARTF_USESTDHANDLES;
SI.hStdOutput := hWritePipe;
SI.hStdError := hWritePipe;
StrPCopy(CmdLine, Command);
if CreateProcess(nil, CmdLine, nil, nil, True, NORMAL_PRIORITY_CLASS, nil, nil, SI, PI) then begin
ExitCode := 0;
while ExitCode = 0 do begin
wrResult := WaitForSingleObject(PI.hProcess, 500);
if PeekNamedPipe(hReadPipe, @Dest[0], 1024, @Avail, nil, nil) then begin
if Avail > 0 then begin
TmpList := TStringList.Create;
try
FillChar(Dest, sizeof(Dest), 0);
ReadFile(hReadPipe, Dest[0], Avail, BytesRead, nil);
tmpstr := copy(Dest, 0, BytesRead - 1);
TmpList.Text := tmpstr;
Output.AddStrings(TmpList);
finally
TmpList.Free;
end;
end;
end;
if wrResult <> WAIT_TIMEOUT then ExitCode := 1;
end;
GetExitCodeProcess(PI.hProcess, ExitCode);
CloseHandle(PI.hProcess);
CloseHandle(PI.hThread);
end;
finally
CloseHandle(hReadPipe);
CloseHandle(hWritePipe);
screen.Cursor := crDefault;
end;
end;

var
rstList: TStringList;
i, j: integer;
begin
Result := '';
rstList := TStringList.Create;
RunDosCommand('ipconfig /all', rstList);
for i := 0 to rstList.Count - 1 do begin
if pos('Physical Address', rstList[i]) > 0 then begin
j := pos(':', rstList[i]);
if j > 0 then begin
Result := copy(rstList[i], j + 2, 17);
break;
end;
end;
end;
rstList.Free;
end;

function Write_Inifile(IniF: TInifile; section, key: string; dtype: integer; value: variant): Boolean;
begin
Result := True;
try
if dtype = 0 then
IniF.WriteString(section, key, value)
else if dtype = 1 then
IniF.WriteInteger(section, key, value);
except
Application.MessageBox('写入文件出错,请重新操作!', '系统提示', MB_IconInformation);
Result := False;
end;
end;

function GetComputerName: string;
var
pComputerName: PChar;
ComputerNameLen: DWord;
ComputerName: string;
begin
ComputerNameLen := 255;
GetMem(pComputerName, ComputerNameLen);
try
if not Windows.GetComputerName(pComputerName, ComputerNameLen) then
pComputerName := '未知计算机名';
ComputerName := StrPas(pComputerName);
finally
FreeMem(pComputerName);
end;
Result := ComputerName;
end;

procedure SetLocalTimer(ADOConnection: TADOConnection);
var
Re: TADODataSet;
SystemTime: TSystemTime;
begin
ShortDateFormat := 'yyyy-mm-dd';
LongDateFormat := 'yyyy-mm-dd';
try
Re := TADODataSet.Create(nil);
Re.Connection := ADOConnection;
Re.CommandText := 'select getdate() as serverTime';
Re.Open;
DateTimeToSystemTime(Re.Fields[0].AsDateTime - 8 / 24, SystemTime); //将时间变成系统时间的函数
SetSystemTime(SystemTime); //设置本地系统时间
finally
Re.Free;
end;
end;

//执行SQL语句操作(ExecSQL)
function ExecQuery(var qry: TADOQuery; lstr: WideString): Boolean;
begin
Result := False;
try
if qry.Active then
qry.Close;
qry.Sql.Clear;
//codesite.SendMsg(lstr);

qry.Sql.Text := lstr;
qry.ExecSQL;
Result := True;
except
end;
end;

//执行SQL语句操作(Open)
procedure ShowQuery(var qry: TADOQuery; lstr: WideString);
begin
if qry.Active then
qry.Close;
qry.Sql.Clear;
qry.Sql.Text := lstr;
qry.Open;
end;

procedure FillFieldToCombox(AdoTable: TADOQuery;
Sql, FieldName: string; Combobox: TComboBox);
var
tmpstr: string;
begin
if AdoTable.Active then
AdoTable.Close;
AdoTable.Sql.Clear;
AdoTable.Sql.Text := Sql;
AdoTable.Open;
Combobox.Items.Clear;
if AdoTable.IsEmpty then
exit;
AdoTable.First;
while not AdoTable.Eof do begin
tmpstr := AdoTable.FieldByName(FieldName).AsString;
if Combobox.Items.IndexOf(tmpstr) < 0 then
Combobox.Items.Add(tmpstr);
AdoTable.Next;
end;
end;

function FillString(str: string; leng: integer;
chr: Char): string;
begin
if Length(str) > leng then
Result := copy(str, 1, leng)
else
Result := StringOfChar(chr, leng - Length(str)) + str;
end;

function ReplaceText(const S, ReplacePiece, ReplaceWith: string): string;
var Position: integer;
TempStr: string;
begin
Position := pos(ReplacePiece, S);
if Position > 0 then begin
TempStr := S;
Delete(TempStr, 1, Position - 1 + Length(ReplacePiece));
Result :=
copy(S, 1, Position - 1) + ReplaceWith + ReplaceText(TempStr, ReplacePiece, ReplaceWith)
end
else Result := S;
end;

function Before(Src: string; var S: string): string;
var
f: Word;
begin
f := pos(Src, S);
if f = 0 then
Before := S
else
Before := copy(S, 1, f - 1);
end;

procedure hideicons;
var
h, hchild: hWnd;
begin
h := FindWIndow(nil, 'Program Manager');
if h > 0 then begin
h := getwindow(h, GW_CHILD);
showwindow(h, SW_HIDE);
hchild := getwindow(h, GW_CHILD);
showwindow(hchild, SW_HIDE);
showwindow(h, SW_SHOW);
end;
end;

procedure showicon;
var
h, hchild: hWnd;
begin
h := FindWIndow(nil, 'Program Manager');
if h > 0 then begin
h := getwindow(h, GW_CHILD);
showwindow(h, SW_SHOW);
hchild := getwindow(h, GW_CHILD);
showwindow(hchild, SW_SHOW);
end;
end;

{
参数"Flag"可以取下列值:

LOCALE_NOUSEROVERRIDE { do not use user overrides }
//LOCALE_USE_CP_ACP { use the system ACP }
//LOCALE_ILANGUAGE { 语言代号 }
//LOCALE_SLANGUAGE { 本地语言名称 }
//LOCALE_SENGLANGUAGE { 语言的英语名 }
//LOCALE_SABBREVLANGNAME { 语言名称缩写 }
//LOCALE_SNATIVELANGNAME { 本地语言名称 }
//LOCALE_ICOUNTRY { 国家代号 }
//LOCALE_SCOUNTRY { 国家名 }
//LOCALE_SENGCOUNTRY { 国家的英语名称 }
//LOCALE_SABBREVCTRYNAME { 国家名缩写 }
//LOCALE_SNATIVECTRYNAME { 国家名 }
//LOCALE_IDEFAULTLANGUAGE { 缺省语言代号 }
//LOCALE_IDEFAULTCOUNTRY { 缺省国家代码 }
//LOCALE_IDEFAULTCODEPAGE { 缺省oem代码页 }
//LOCALE_IDEFAULTANSICODEPAGE { 缺省ansi代码页 }
//LOCALE_IDEFAULTMACCODEPAGE { 缺省mac页 }
//LOCALE_SLIST { 列表项分割符 }
//LOCALE_IMEASURE { 测量单位0 = 米制, 1 = 英制 }
//LOCALE_SDECIMAL { 小数点符号 }
//LOCALE_STHOUSAND { 千位分割符 }
//LOCALE_SGROUPING { digit grouping }
//LOCALE_IDIGITS { number of fractional digits }
//LOCALE_ILZERO { leading zeros for decimal }
//LOCALE_INEGNUMBER { 负数模式 }
//LOCALE_SNATIVEDIGITS { native ascii 0-9 }
//LOCALE_SCURRENCY { 本地货币符号 }
//LOCALE_SINTLSYMBOL { 国际货币符号 }
//LOCALE_SMONDECIMALSEP { 货币小数点分割符 }
//LOCALE_SMONTHOUSANDSEP { 货币千位分割符 }
//LOCALE_SMONGROUPING { monetary grouping }
//LOCALE_ICURRDIGITS { # local monetary digits }
//LOCALE_IINTLCURRDIGITS { # intl monetary digits }
//LOCALE_ICURRENCY { positive currency mode }
//LOCALE_INEGCURR { negative currency mode }
//LOCALE_SDATE { 日期分割符 }
//LOCALE_STIME { 时间分割符 }
//LOCALE_SSHORTDATE { 短日期字符串 }
//LOCALE_SLONGDATE { 长日期字符串 }
//LOCALE_STIMEFORMAT { time format string }
//LOCALE_IDATE { short date format ordering }
//LOCALE_ILDATE { long date format ordering }
//LOCALE_ITIME { time format specifier }
//LOCALE_ITIMEMARKPOSN { time marker position }
//LOCALE_ICENTURY { century format specifier (short date) }
//LOCALE_ITLZERO { leading zeros in time field }
//LOCALE_IDAYLZERO { leading zeros in day field (short date) }
//LOCALE_IMONLZERO { leading zeros in month field (short date) }
//LOCALE_S1159 { AM designator }
//LOCALE_S2359 { PM designator }
//LOCALE_ICALENDARTYPE { type of calendar specifier }
//LOCALE_IOPTIONALCALENDAR { additional calendar types specifier }
//LOCALE_IFIRSTDAYOFWEEK { first day of week specifier }
//LOCALE_IFIRSTWEEKOFYEAR { first week of year specifier }
//LOCALE_SDAYNAME1 { long name for Monday }
//LOCALE_SDAYNAME2 { long name for Tuesday }
//LOCALE_SDAYNAME3 { long name for Wednesday }
//LOCALE_SDAYNAME4 { long name for Thursday }
//LOCALE_SDAYNAME5 { long name for Friday }
//LOCALE_SDAYNAME6 { long name for Saturday }
//LOCALE_SDAYNAME7 { long name for Sunday }
//LOCALE_SABBREVDAYNAME1 { 星期一的缩写 }
//LOCALE_SABBREVDAYNAME2 { 星期二的缩写 }
//LOCALE_SABBREVDAYNAME3 { 星期三的缩写 }
//LOCALE_SABBREVDAYNAME4 { 星期四的缩写 }
//LOCALE_SABBREVDAYNAME5 { 星期五的缩写 }
//LOCALE_SABBREVDAYNAME6 { 星期六的缩写 }
//LOCALE_SABBREVDAYNAME7 { 星期天的缩写 }
//LOCALE_SMONTHNAME1 { long name for January }
//LOCALE_SMONTHNAME2 { long name for February }
//LOCALE_SMONTHNAME3 { long name for March }
//LOCALE_SMONTHNAME4 { long name for April }
//LOCALE_SMONTHNAME5 { long name for May }
//LOCALE_SMONTHNAME6 { long name for June }
//LOCALE_SMONTHNAME7 { long name for July }
//LOCALE_SMONTHNAME8 { long name for August }
//LOCALE_SMONTHNAME9 { long name for September }
//LOCALE_SMONTHNAME10 { long name for October }
//LOCALE_SMONTHNAME11 { long name for November }
//LOCALE_SMONTHNAME12 { long name for December }
//LOCALE_SMONTHNAME13 { long name for 13th month (if exists) }
//LOCALE_SABBREVMONTHNAME1 { 一月的缩写 }
//LOCALE_SABBREVMONTHNAME2 { 二月的缩写 }
//LOCALE_SABBREVMONTHNAME3 { 三月的缩写 }
//LOCALE_SABBREVMONTHNAME4 { 四月的缩写 }
//LOCALE_SABBREVMONTHNAME5 { 五月的缩写 }
//LOCALE_SABBREVMONTHNAME6 { 六月的缩写 }
//LOCALE_SABBREVMONTHNAME7 { 七月的缩写 }
//LOCALE_SABBREVMONTHNAME8 { 八月的缩写 }
//LOCALE_SABBREVMONTHNAME9 { 九月的缩写 }
//LOCALE_SABBREVMONTHNAME10 { 十月的缩写 }
//LOCALE_SABBREVMONTHNAME11 { 十一月的缩写 }
//LOCALE_SABBREVMONTHNAME12 { 十二月的缩写 }
//LOCALE_SABBREVMONTHNAME13 { 十三月的缩写（如果有的话） }
//LOCALE_SPOSITIVESIGN { 正号 }
//LOCALE_SNEGATIVESIGN { 负号 }
//LOCALE_IPOSSIGNPOSN { 正号位置 }
//LOCALE_INEGSIGNPOSN { 负号位置 }
//LOCALE_IPOSSYMPRECEDES { mon sym precedes pos amt }
//LOCALE_IPOSSEPBYSPACE { mon sym sep by space from pos amt }
//LOCALE_INEGSYMPRECEDES { mon sym precedes neg amt }
//LOCALE_INEGSEPBYSPACE { mon sym sep by space from neg amt }
//LOCALE_FONTSIGNATURE { font signature }
//LOCALE_SISO639LANGNAME { ISO 缩写语言名称 }
//LOCALE_SISO3166CTRYNAME { ISO 缩写国家名称 }
//}

//function GetLocaleInformation(Flag: Integer): String;
//var
// pcLCA: Array[0..20] of Char;
//begin
// if( GetLocaleInfo(LOCALE_SYSTEM_DEFAULT,Flag,pcLCA,19) <= 0 ) then begin
// pcLCA[0] := #0;
// end;
// Result := pcLCA;
//end;

function CheckSound: Boolean;
begin
Result := auxGetNumDevs() <= 0;
end;

//procedure deregisterFileType(ft: String);
////ft:将要删除文件关联的后缀，如.tst
//var
// myreg:TRegistry;
// key: String;
//begin
// myreg:=TRegistry.Create;
// myReg.RootKey:=HKEY_CLASSES_ROOT;
// myReg.OpenKey(ft, False);
// key:=MyReg.ReadString('');
// MyReg.CloseKey;
// myReg.DeleteKey(ft);
// myReg.DeleteKey(key);
// myReg.Free;
//end;

//强行让EDIT控件获得焦点:SendMessage(edtName.Handle,WM_SETFOCUS,0,0);

{
如何判断窗体变为最小化
方法一：截获WM_SYSCOMMAND消息，看窗体是否处于最小化状态
type
TForm1 = class(TForm)
private
procedure WMSysCommand(var Message: TMessage); message WM_SYSCOMMAND;
//...
end;

implementation

procedure TForm1.WMSysCommand(var Message:TMessage);
begin
if Message.WParam = SC_ICON then //最小化了
begin
//form1.hide; ...
end
else
inherited;
end;
}

function ToBigRMB(RMB: string): string;
const
BigNumber = '零壹贰叁肆伍陆柒捌玖';
BigUnit = '万仟佰拾亿仟佰拾万仟佰拾元'; {共可表示13为金额}
var
nLeft, nRigth, lTemp, rTemp, BigNumber1, BigUnit1: string;
i: integer;
minus: Boolean;
begin
minus := False;
{取整数和小数部分}
if strtofloat(RMB) < 0
then begin
RMB := FloattostrF(abs(strtofloat(RMB)), fffixed, 9, 2);
minus := True;
end
else RMB := FloattostrF(abs(strtofloat(RMB)), fffixed, 9, 2);
nLeft := copy(RMB, 1, pos('.', RMB) - 1);
nRigth := copy(RMB, pos('.', RMB) + 1, 2); {转换整数部分}
for i := 1 to Length(nLeft) do begin
BigNumber1 := copy(BigNumber, StrToInt(nLeft[i]) * 2 + 1, 2);
BigUnit1 := copy(BigUnit, (Trunc(Length(BigUnit) / 2) - Length(nLeft) + i - 1) * 2 + 1, 2);
if (BigNumber1 = '零') and ((copy(lTemp, Length(lTemp) - 1, 2)) = '零')
then lTemp := copy(lTemp, 1, Length(lTemp) - 2);
if (BigNumber1 = '零') and ((BigUnit1 = '亿') or (BigUnit1 = '万') or (BigUnit1 = '元'))
then begin
BigNumber1 := BigUnit1;
if BigUnit1 <> '元'
then BigUnit1 := '零'
else BigUnit1 := '';
end;
if (BigNumber1 = '零') and (BigUnit1 <> '亿') and (BigUnit1 <> '万') and (BigUnit1 <> '元')
then BigUnit1 := '';
lTemp := lTemp + BigNumber1 + BigUnit1;
end;
if trim(lTemp) = '元' then lTemp := '零' + lTemp;
if pos('亿万', lTemp) <> 0
then Delete(lTemp, pos('亿万', lTemp) + 2, 2); {转换小数部分}
if (trim(copy(lTemp, Length(lTemp) - 3, 2)) <> '') and (pos(copy(lTemp, Length(lTemp) - 3, 2), BigUnit) > 0) and (StrToInt(nRigth[1]) <> 0 or StrToInt(nRigth[2]))
then lTemp := lTemp + '零';
if (trim(lTemp) = '零元') and (StrToInt(nRigth[1]) <> 0 or StrToInt(nRigth[2])) then lTemp := '';
if minus then lTemp := '(负)' + lTemp;
if StrToInt(nRigth[1]) <> 0
then rTemp := copy(BigNumber, StrToInt(nRigth[1]) * 2 + 1, 2) + '角';
if StrToInt(nRigth[2]) <> 0
then begin
if (StrToInt(nRigth[1]) = 0) and ((rightstr(lTemp, 2) <> '零') and (trim(rightstr(lTemp, 2)) <> ''))
then rTemp := '零';
rTemp := rTemp + copy(BigNumber, StrToInt(nRigth[2]) * 2 + 1, 2) + '分';
Result := '(币):' + lTemp + rTemp;
end
else Result := '(币):' + lTemp + rTemp + '整';
end;

//写日志文件
procedure WriteLogFile(WriteMode, LogFile, FileName: string; lstField: TStringList; iTag: integer = 0);
var
ListLogFile: TStringList;
i: integer;
begin
ListLogFile := TStringList.Create;
ListLogFile.LoadFromFile(LogFile);
if iTag = 0 then begin
ListLogFile.Add(FileName + ' ' + WriteMode);
end
else if iTag = 2 then begin
ListLogFile.Add(FileName + ' ' + WriteMode);
for i := 0 to lstField.Count - 1 do begin
ListLogFile.Add(lstField[i])
end;
end;

ListLogFile.SaveToFile(LogFile);
ListLogFile.Free;
end;

procedure WriteLogFile(WriteMode, LogFile, FileName: string);
var
ListLogFile: TStringList;
i: integer;
begin
ListLogFile := TStringList.Create;
ListLogFile.LoadFromFile(LogFile);
ListLogFile.Add(FileName + ' ' + WriteMode);
ListLogFile.SaveToFile(LogFile);
ListLogFile.Free;
end;

procedure WriteLogFile(WriteMode, LogFile: string);
var
ListLogFile: TStringList;
i: integer;
begin
ListLogFile := TStringList.Create;
ListLogFile.LoadFromFile(LogFile);
ListLogFile.Add(WriteMode);
ListLogFile.SaveToFile(LogFile);
ListLogFile.Free;
end;

function WindowsVersion(var verinfo: string): integer;
var
OSVersionInfo32: OSVERSIONINFO;
begin
{
Function returns:
1 = Win95
2 = Win98
3 = WinNT
4 = W2k
5 = Win ME
6 = Win XP
}
Result := -1;

OSVersionInfo32.dwOSVersionInfoSize := sizeof(OSVersionInfo32);
GetVersionEX(OSVersionInfo32);

case OSVersionInfo32.dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS: { Windows 95/98 } begin
with OSVersionInfo32 do begin
{ If minor version is zero, we are running on Win 95.
Otherwise we are running on Win 98 }
if (dwMinorVersion = 0) then begin
{ Windows 95 }
Result := cWIN_95;
verinfo := Format('Windows-95 %d.%.2d.%d%s',
[dwMajorVersion, dwMinorVersion,
Lo(dwBuildNumber),
szCSDVersion]);
end
else if (dwMinorVersion < 90) then begin
{ Windows 98 }
Result := cWIN_98;
verinfo := Format('Windows-98 %d.%.2d.%d%s',
[dwMajorVersion, dwMinorVersion,
Lo(dwBuildNumber),
szCSDVersion]);
end
else if (dwMinorVersion >= 90) then begin
{ Windows ME }
Result := cWIN_ME;
verinfo := Format('Windows-ME %d.%.2d.%d%s',
[dwMajorVersion, dwMinorVersion,
Lo(dwBuildNumber),
szCSDVersion]);
end;
end; { end with }
end;
VER_PLATFORM_WIN32_NT: begin
with OSVersionInfo32 do begin
if (dwMajorVersion <= 4) then begin
{ Windows NT 3.5/4.0 }
Result := cWIN_NT;
verinfo := Format('Windows-NT %d.%.2d.%d%s', [dwMajorVersion,
dwMinorVersion, dwBuildNumber, szCSDVersion]);
end
else begin
if (dwMinorVersion > 0) then begin
{ Windows XP }
Result := cWIN_XP;
verinfo := Format('Windows-XP %d.%.2d.%d%s', [dwMajorVersion,
dwMinorVersion, dwBuildNumber, szCSDVersion]);
end
else begin
{ Windows 2000 }
Result := cWIN_2000;
verinfo := Format('Windows-2000 %d.%.2d.%d%s', [dwMajorVersion,
dwMinorVersion, dwBuildNumber, szCSDVersion]);
end;
end;
end;
end;
end; { end case }
end;

procedure TColorToRGB(Color: TColor; var R, G, B: integer);
begin
R := Color and $FF;
G := (Color and $FF00) shr 8;
B := (Color and $FF0000) shr 16;
end;

function RgbToGray(Source: TColor): TColor;
var Target: Byte;
begin
Target := Round((0.30 * GetRValue(Source)) + (0.59 * GetGValue(Source))
+ (0.11 * GetBValue(Source)));
Result := RGB(Target, Target, Target);
end;

procedure TextOutAngle(x, y, aAngle, aSize: integer; txt: string);
var hFont, Fontold: integer;
Dc: hDc;
Fontname: string;
begin
if Length(txt) = 0 then
exit;
Dc := screen.ActiveForm.canvas.Handle;
SetBkMode(Dc, TRANSPARENT);
Fontname := screen.ActiveForm.canvas.Font.name;
hFont := CreateFont(-aSize, 0, aAngle * 10, 0, fw_normal, 0, 0,
0, 1, 4, $10, 2, 4, PChar(Fontname));
Fontold := SelectObject(Dc, hFont);
TextOut(Dc, x, y, PChar(txt), Length(txt));
SelectObject(Dc, Fontold);
DeleteObject(hFont);
end;

procedure SetAutoRun;
begin
WriteStrToRegistry(HKEY_LOCAL_MACHINE, 'Software\Microsoft\Windows\CurrentVersion\Run',
Application.Title, Application.ExeName);
end;

//读注册表
function ReadStrRegistry(Root: HKEY; Path, key, value: string): Boolean;
var
Registry: TRegistry;
begin
Result := True;
Registry := TRegistry.Create;
try
try
Registry.RootKey := Root;
if Registry.OpenKey(Path, False) then
value := Registry.ReadString(key)
else
Result := False;
except
Result := False;
end;
finally
Registry.Free;
end;
end;

//写注册表
function WriteStrToRegistry(Root: HKEY; Path, key, value: string): Boolean;
var
Registry: TRegistry;
begin
Result := True;
Registry := TRegistry.Create;
try
try
Registry.RootKey := Root;
Registry.OpenKey(Path, True);
Registry.WriteString(key, value);
except
Registry.Free;
Result := False;
end;
finally
Registry.Free;
end;
end;

//根据表明特定Select语句
function GetSelectText(TableName: string): string;
const
str = 'Select * from %s';
begin
Result := Format(str, [TableName]);
end;

//屏蔽，开启系统功能键
procedure SetSysState(state: Boolean);
var
tempint: integer;
begin
//state为真时屏蔽,为0时开启
if state then
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @tempint, 0)
else
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, @tempint, 0);
end;

procedure FadeOut(const BMP: TImage; Pause: integer);
var
BytesPorScan: integer;
w, h: integer;
p: pByteArray;
Counter: integer;
begin
{ This only works with 24 or 32 bits bitmaps }

if not (BMP.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit])
then raise exception.Create('Error, bitmap format not supported.');

try
BytesPorScan := abs(integer(BMP.Picture.Bitmap.ScanLine[1]) -
integer(BMP.Picture.Bitmap.ScanLine[0]));
except
raise exception.Create('Error');
end;

{ Decrease the RGB components of each single pixel }
for Counter := 1 to 256 do begin
for h := 0 to BMP.Picture.Bitmap.Height - 1 do begin
p := BMP.Picture.Bitmap.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
if p^[w] > 0 then p^[w] := p^[w] - 1;
end;
Sleep(Pause);
BMP.Refresh;
end;
end; {procedure FadeOut}

procedure CopyImageToBitmap(im: TImage; bm: tBitmap);
begin
if bm = nil
then begin
bm := tBitmap.Create;
bm.PixelFormat := pfDevice;
end;
bm.Width := im.Picture.Width;
bm.Height := im.Picture.Height;
if (im.Picture.Graphic is TJPEGImage) then
bm.canvas.Draw(0, 0, im.Picture.Graphic) // it's a JPG
else
bm.canvas.Draw(0, 0, im.Picture.Bitmap); // it's a BMP
end;

procedure MinMaxAll(bol: Boolean);
begin
if bol then begin
keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), 0, 0);
keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), 0, 0);
keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0);
end
else begin
keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), 0, 0);
keybd_event(VK_SHIFT, MapvirtualKey(VK_SHIFT, 0), 0, 0);
keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), 0, 0);
keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_SHIFT, MapvirtualKey(VK_SHIFT, 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0);
end;
end;

procedure GetScreenMetric(var x, y: integer); //获取分辨率
begin
x := GetSystemMetrics(SM_CXSCREEN);
y := GetSystemMetrics(SM_CYSCREEN);
end;

function DynamicResolution(x, y: Word): BOOL; //改变分辨率
var
lpDevMode: TDeviceMode;
begin
Result := EnumDisplaySettings(nil, 0, lpDevMode);
if Result then begin
lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := x;
lpDevMode.dmPelsHeight := y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end;
end;

function DB_connect(connect: TADOConnection; Mode, Password, UserID, DBName, DBServer: string): Boolean; //连接数据库
begin
Result := True;
//为SQL登陆模式时的登陆连接字
if connect.Connected = True then connect.Connected := False;
if Mode = 'sqlmode' then
connect.ConnectionString := ' Provider=SQLOLEDB.1;'
+ ' password=' + Password + ';'
+ ' Persist Security Info=False;'
+ ' User ID=' + UserID + ';'
+ ' Initial Catalog=' + DBName + ';'
+ ' Data Source=' + DBServer
else
//为WINDOWS登陆模式时的登陆连接字
if Mode = 'windowsmode' then
connect.ConnectionString := ' Provider=SQLOLEDB.1;'
+ ' password=' + Password + ';'
+ ' Integrated Security=SSPI;'
+ ' Persist Security Info=False;'
+ ' Data Source=' + DBServer + '' + ';'
+ ' Use Procedure for Prepare=1;'
+ ' Auto Translate=True;'
+ ' Initial Catalog=' + DBName + ';'
+ ' Packet Size=4096;'
+ ' Use Encryption for Data=False;'
+ ' Tag with column collation when possible=False';
try
connect.Connected := True;
SetLocalTimer(connect);
except
Application.MessageBox('数据库连接失败,请检查数据库参数是否正确或网络故障！', '', MB_OK + MB_IconInformation);
Result := False;
exit;
end;
end;

function BackupDatabase(adoCon: TADOConnection; strFileName, DBName: string): Boolean; //备份数据库
var
adoCommand: TADOCommand;
i: integer;
begin
Result := True;
if trim(strFileName) = '' then begin
Result := False;
exit;
end;
adoCommand := TADOCommand.Create(nil);
adoCommand.Connection := adoCon;
adoCommand.CommandType := cmdText;
adoCommand.CommandText := 'backup DataBase ' + DBName + ' to Disk=''' + strFileName + '''';
try
adoCommand.Execute;
except
Result := False;
end;
adoCommand.Free;
end;

procedure BmpToIco(aBmp, aIco: string);
var
BMP, mbmp: tBitmap;
ico: ticon;
rbmp: Bitmap;
a: array[0..4096] of Byte;
len: DWord;
i: integer;
imglist: timagelist;
begin
BMP := tBitmap.Create;
mbmp := tBitmap.Create;
mbmp.Assign(BMP);
ico := ticon.Create;
imglist := timagelist.CreateSize(32, 32);
try
BMP.LoadFromFile(aBmp);
len := GetBitmapBits(BMP.Handle, 4096, @a);
mbmp.Handle := CreateBitmapIndirect(rbmp);
for i := 0 to len do
a[i] := a[i] and a[i];
SetBitmapBits(BMP.Handle, len, @a);
imglist.Add(BMP, mbmp);
imglist.GetIcon(0, ico);
finally
BMP.Free;
ico.Free;
imglist.Free;
end;
end;

procedure WmfToBmp(FicheroWmf, FicheroBmp: string);
var
MetaFile: TMetafile;
BMP: tBitmap;
begin
MetaFile := TMetafile.Create;
{Create a Temporal Bitmap}
BMP := tBitmap.Create;
{Load the Metafile}
MetaFile.LoadFromFile(FicheroWmf);
{Draw the metafile in Bitmap's canvas}
with BMP do begin
Height := MetaFile.Height;
Width := MetaFile.Width;
canvas.Draw(0, 0, MetaFile);
{Save the BMP}
SaveToFile(FicheroBmp);
{Free BMP}
Free;
end;
{Free Metafile}
MetaFile.Free;
end;

procedure JPGToBMP(JpegFileName, BmpFileName: string);
var
jpeg: TJPEGImage;
BMP: tBitmap;
begin
jpeg := TJPEGImage.Create;
BMP := tBitmap.Create;
jpeg.LoadFromFile(JpegFileName);
with BMP do begin
Height := jpeg.Height;
Width := jpeg.Width;
canvas.Draw(0, 0, jpeg);
SaveToFile(BmpFileName);
Free;
end;
{Free Metafile}
jpeg.Free;
end;

procedure BmpToWmf(BmpFile, WmfFile: string);
var
MetaFile: TMetafile;
MFCanvas: TMetaFileCanvas;
BMP: tBitmap;
begin
{Create temps}
MetaFile := TMetafile.Create;
BMP := tBitmap.Create;
BMP.LoadFromFile(BmpFile);
{Igualemos tama ?os}
{Equalizing sizes}
MetaFile.Height := BMP.Height;
MetaFile.Width := BMP.Width;
{Create a canvas for the Metafile}
MFCanvas := TMetaFileCanvas.Create(MetaFile, 0);
with MFCanvas do begin
{Draw the BMP into canvas}
Draw(0, 0, BMP);
{Free the Canvas}
Free;
end;
{Free the BMP}
BMP.Free;
with MetaFile do begin
{Save the Metafile}
SaveToFile(WmfFile);
{Free it...}
Free;
end;
end;

procedure DrawTrans(DestCanvas: TCanvas; x, y: smallint; SrcBitmap: tBitmap; AColor, BackColor: TColor);
var ANDBitmap, ORBitmap: tBitmap;
CM: TCopyMode;
Src: TRect;
begin
ANDBitmap := nil;
ORBitmap := nil;
try
ANDBitmap := tBitmap.Create;
ORBitmap := tBitmap.Create;
Src := Bounds(0, 0, SrcBitmap.Width, SrcBitmap.Height);
with ORBitmap do begin
Width := SrcBitmap.Width;
Height := SrcBitmap.Height;
canvas.Brush.Color := clBlack;
canvas.CopyMode := cmSrcCopy;
canvas.BrushCopy(Src, SrcBitmap, Src, AColor);
end;
with ANDBitmap do begin
Width := SrcBitmap.Width;
Height := SrcBitmap.Height;
canvas.Brush.Color := BackColor;
canvas.CopyMode := cmSrcInvert;
canvas.BrushCopy(Src, SrcBitmap, Src, AColor);
end;
with DestCanvas do begin
CM := CopyMode;
CopyMode := cmSrcAnd;
Draw(x, y, ANDBitmap);
CopyMode := cmSrcPaint;
Draw(x, y, ORBitmap);
CopyMode := CM;
end;
finally
ANDBitmap.Free;
ORBitmap.Free;
end;
end;
{Example call :
DrawTrans(Image2.Canvas, 0,0, Image1.Picture.Bitmap, clBlack, clSilver);}

procedure TextOutAngled(canvas: TCanvas; iCoordX, iCoordY: integer; const sString: string; iAngle, iSize: integer);
var
oLogFont: TLogFont;
SaveFont: TFont;
begin
SaveFont := TFont.Create;
SaveFont.Assign(canvas.Font);
GetObject(SaveFont.Handle, sizeof(TLogFont), @oLogFont);

with oLogFont do begin
lfHeight := iSize * 2;
lfEscapement := iAngle * 10;
lfQuality := PROOF_QUALITY;
lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;
end;

with canvas do begin
Font.Handle := CreateFontIndirect(oLogFont);
SetBkMode(Handle, TRANSPARENT);
TextOut(iCoordX, iCoordY, sString);
Font.Assign(SaveFont);
end;
SaveFont.Free;
end;

procedure Display(canvas: TCanvas; BMP: tBitmap; rect: TRect);
// 功能 : 以逆时针方向逐渐显示一幅位图 .
//Canvas : 窗口的 Canvas;
//bmp : 待显示的位图 ;
//rect : 显示区域
var
i, a, B, x0, y0, x, y: integer;
d: extended;
R: TRect;
Membmp: tBitmap;
begin
a := (rect.right - rect.left) div 2; // 椭圆横轴
B := (rect.bottom - rect.top) div 2; // 椭圆纵轴
x0 := rect.left + a; // 椭圆中心
y0 := rect.top + B; //
R.left := 0;
R.top := 0;
R.right := 2 * a;
R.bottom := 2 * B;

Membmp := tBitmap.Create; // 建立等大的内存位图
Membmp.Width := 2 * a;
Membmp.Height := 2 * B;
Membmp.canvas.Brush.Color := clBlack; // 涂黑
Membmp.canvas.FillRect(R);
Membmp.canvas.Brush.Color := clWhite;
for i := 1 to 36 do begin
d := i / 18 * 3.1415926;
Sleep(10);
x := x0 + Round(a * Cos(d));
y := y0 - Round(B * Sin(d));
// 用白色画扇形
if (i = 36) then
Membmp.canvas.Ellipse(x0 - a, y0 - B, x0 + a, y0 + B)
else
Membmp.canvas.Pie(x0 - a, y0 - B, x0 + a, y0 + B, x0 + a, y0, x, y);
Membmp.canvas.CopyMode := cmSrcAnd;
// 显示位图的扇形区域
Membmp.canvas.CopyRect(R, BMP.canvas, R);
canvas.CopyRect(rect, Membmp.canvas, R);
end;
Membmp.Free;
end;

{这里的 Bmp 为源位图 ,Dst 为目标位图 ,Amount 为扭曲常数 ,你可以定义为任意整数 ,例如 100.}
procedure Twist(var BMP, Dst: tBitmap; Amount: integer);
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
R: Single;
theta: Single;
ifx, ify: integer;
dx, dy: Single;
OFFSET: Single;
ty, tx: integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: integer;
new_blue: integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: integer;
sli, slo: pByteArray;

function ArcTan2(xt, yt: Single): Single;
begin
if xt = 0 then
if yt > 0 then
Result := PI / 2
else
Result := -(PI / 2)
else begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := PI + ArcTan(yt / xt);
end;
end;

begin
OFFSET := -(PI / 2);
dx := BMP.Width - 1;
dy := BMP.Height - 1;
R := Sqrt(dx * dx + dy * dy);
tx2 := R;
ty2 := R;
txmid := (BMP.Width - 1) / 2; //Adjust these to move center of rotation
tymid := (BMP.Height - 1) / 2; //Adjust these to move ......
fxmid := (BMP.Width - 1) / 2;
fymid := (BMP.Height - 1) / 2;
if tx2 >= BMP.Width then tx2 := BMP.Width - 1;
if ty2 >= BMP.Height then ty2 := BMP.Height - 1;

for ty := 0 to Round(ty2) do begin
for tx := 0 to Round(tx2) do begin
dx := tx - txmid;
dy := ty - tymid;
R := Sqrt(dx * dx + dy * dy);
if R = 0 then begin
fx := 0;
fy := 0;
end
else begin
theta := ArcTan2(dx, dy) - R / Amount - OFFSET;
fx := R * Cos(theta);
fy := R * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;

if fx >= 0 then begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else begin
weight_x[0] := -(fx - ifx);
weight_x[1] := 1 - weight_x[0];
end;

if ifx < 0 then
ifx := BMP.Width - 1 - (-ifx mod BMP.Width)
else if ifx > BMP.Width - 1 then
ifx := ifx mod BMP.Width;
if ify < 0 then
ify := BMP.Height - 1 - (-ify mod BMP.Height)
else if ify > BMP.Height - 1 then
ify := ify mod BMP.Height;

total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do begin
for iy := 0 to 1 do begin
if ify + iy < BMP.Height then
sli := BMP.ScanLine[ify + iy]
else
sli := BMP.ScanLine[BMP.Height - ify - iy];
if ifx + ix < BMP.Width then begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else begin
new_red := sli[(BMP.Width - ifx - ix) * 3];
new_green := sli[(BMP.Width - ifx - ix) * 3 + 1];
new_blue := sli[(BMP.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.ScanLine[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
end;
end;
end;

function RestoreDatabase(adoQuery: TADOQuery; strPath, strName: string): integer; //还原数据库
var
i, Num: integer;
begin
Result := 0;
if trim(strPath) = '' then begin
Result := 1; //表示备份路径错误
exit;
end;
adoQuery.Close;
adoQuery.Sql.Text := 'use master select * from sysdatabases where name =''' + strName + '''';
adoQuery.Open;
Num := adoQuery.RecordCount;
if Num > 0 then begin
Result := 2; //表示数据库名错误，已有此数据库
exit;
end;
//adoCommand.CommandText :='backup DataBase '+DBName+' to Disk='''+strFileName+'''';
adoQuery.Close;
//adoQuery.SQL.Text :=' Restore FILELISTONLY from disk=''' + Path.Text + '''';
adoQuery.Sql.Text := adoQuery.Sql.Text + 'Restore database ' + strName + ' from disk=''' + strPath + '''';
adoQuery.Sql.Text := adoQuery.Sql.Text + ' with move ''Oil_dat'' to ''E:\'
+ strName + '.mdf'',move ''Oil_log'' to ''E:\' + strName + '_log.LDF'' ';
try
try
adoQuery.ExecSQL;
except
Result := 3; //表示其它错误
end;
finally
ExecQuery(adoQuery, 'USE Oil');
end;
end;

procedure InsertionSort(Items: TStrings);
var
i, Position, n: integer;
value: string;
Done: Boolean;
begin
n := Items.Count;
for i := 1 to n - 1 do begin
value := Items[i];
Position := i;
Done := False;

while not Done do begin
if Position <= 0 then
Done := True
else
if value >= Items[Position - 1] then
Done := True
else begin
Items[Position] := Items[Position - 1];
Position := Position - 1;
end;
end;
Items[Position] := value;
end;
end;

procedure BubbleSort(Items: TStrings);
var
Done: Boolean;
i, n: integer;
Dummy: string;
begin
n := Items.Count;

repeat
Done := True;
for i := 0 to n - 2 do
if Items[i] > Items[i + 1] then begin
Dummy := Items[i];
Items[i] := Items[i + 1];
Items[i + 1] := Dummy;

Done := False;
end;
until Done;
end;

//最大公约数
function gcd(a, B: integer): integer;
var
i, C: integer;
begin
if a > B then
C := B
else
C := a;

for i := C to 2 do begin
if ((C mod a = 0) and (C mod B = 0)) then
Result := i;
end;
end;

//最小公倍数
function lcm(a, B: integer): integer;
var
C, i: integer;
begin
if a > B then
C := a
else
C := B;

while (C mod B) <> 0 do
C := C + B;
Result := C;
end;

//转换数字到罗马字符串
function DecToRoman(iDecimal: Longint): string;
const
aRomans: array[1..13] of string = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
aArabics: array[1..13] of integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
var
i: integer;
begin
Result := '';
for i := 13 downto 1 do begin
while (iDecimal >= aArabics[i]) do begin
iDecimal := iDecimal - aArabics[i];
Result := Result + aRomans[i];
end;
end;
end;

procedure SelectionSort(var a: array of integer);
var
i, j, t: integer;
begin
for i := Low(a) to High(a) - 1 do
for j := High(a) downto i + 1 do
if a[i] > a[j] then begin
t := a[i];
a[i] := a[j];
a[j] := t;
end;
end;

procedure QuickSortt(var a: array of integer);
procedure QuickSort(var a: array of integer; iLo, iHi: integer);
var
Lo, Hi, Mid, t: integer;
begin
Lo := iLo;
Hi := iHi;
Mid := a[(Lo + Hi) div 2];
repeat
while a[Lo] < Mid do inc(Lo);
while a[Hi] > Mid do Dec(Hi);
if Lo <= Hi then begin
t := a[Lo];
a[Lo] := a[Hi];
a[Hi] := t;
inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSort(a, iLo, Hi);
if Lo < iHi then QuickSort(a, Lo, iHi);
end;

begin
QuickSort(a, Low(a), High(a));
end;

procedure ShowPicture(canvas: TCanvas; img: TImage; step: integer; PlayMode: integer); //图像载入显示效果(百叶窗，雨滴，随机等效果)
var
newBmp: tBitmap;
i, j, bmpheight, bmpwidth, xgroup, xcount, xtotal, h, w: integer;
begin
newBmp := tBitmap.Create;
newBmp.canvas.Brush.Color := clBlack;
newBmp.Width := img.Width;
newBmp.Height := img.Height;
bmpheight := img.Height;
bmpwidth := img.Width;
case PlayMode of
0: {//水平百叶窗} begin
xgroup := img.Height div step;
xcount := bmpheight div xgroup;
for i := 0 to xcount do
for j := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, xcount * j + i, bmpwidth, xcount * j + i + 1), img.canvas,
rect(0, xcount * j + i, bmpwidth, xcount * j + i + 1));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.Free;
end;
1: {//垂直百叶窗} begin
xgroup := img.Width div step;
xcount := bmpwidth div xgroup;
for i := 0 to xcount do
for j := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(xcount * j + i, 0, xcount * j + i + 1, bmpheight), img.canvas,
rect(xcount * j + i, 0, xcount * j + i + 1, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.Free;
end;
2: {//盒状展开} begin
xgroup := step;
xcount := bmpwidth div (xgroup * 2);
xtotal := bmpheight div (xgroup * 2);
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(bmpwidth div 2 - xcount * i - i, bmpheight div 2 - xtotal * i - i, bmpwidth div 2 + xcount * i + i, bmpheight div 2 + xtotal * i + i),
img.canvas, rect(bmpwidth div 2 - xcount * i - i, bmpheight div 2 - xtotal * i - i, bmpwidth div 2 + xcount * i + i, bmpheight div 2 + xtotal * i + i));
canvas.Draw(img.left, img.top, newBmp);
Sleep(10);
Application.ProcessMessages;
end;
newBmp.Free;
end;
3: {//盒状缩放} begin
canvas.Brush.Color := clBlack;
xgroup := step;
xcount := bmpwidth div (xgroup * 2);
xtotal := bmpheight div (xgroup * 2);
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(xcount * i, xtotal * i, bmpwidth - xcount * i, bmpheight - xtotal * i),
img.canvas, rect(xcount * i, xtotal * i, bmpwidth - xcount * i, bmpheight - xtotal * i));
canvas.Draw(img.left, img.top, newBmp);
newBmp.canvas.Rectangle(0, 0, bmpwidth, bmpheight);
Sleep(10);
Application.ProcessMessages;
end;
canvas.Rectangle(img.left, img.top, img.Width, img.Height);
newBmp.Free;
end;
4: {//从上进入} begin
xgroup := step;
xcount := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, xcount * i),
img.canvas, rect(0, bmpheight - xcount * i, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
5: {//从下进入} begin
xgroup := step;
xcount := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, bmpheight - xcount * i, bmpwidth, bmpheight),
img.canvas, rect(0, img.top, bmpwidth, xcount * i));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
6: {//从左进入} begin
xgroup := step;
xcount := bmpwidth div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, 0, xcount * i, bmpheight),
img.canvas, rect(bmpwidth - xcount * i, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
7: {//从右进入} begin
xgroup := step;
xcount := bmpwidth div xgroup;
xtotal := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(bmpwidth - xcount * i, 0, bmpwidth, bmpheight),
img.canvas, rect(0, 0, xcount * i, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
8: {//从左上进入} begin
xgroup := step;
xcount := bmpwidth div xgroup;
xtotal := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, 0, xcount * i, xtotal * i), img.canvas, rect(bmpwidth - xcount * i, bmpheight - xtotal * i, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;

9: {//从右下进入} begin
xgroup := step;
xcount := bmpwidth div xgroup;
xtotal := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(bmpwidth - xcount * i, bmpheight - xtotal * i, bmpwidth, bmpheight),
img.canvas, rect(0, 0, xcount * i, xtotal * i));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
10: {//从左下进入} begin
xgroup := step;
xcount := bmpwidth div xgroup;
xtotal := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, bmpheight - xtotal * i, xcount * i, bmpheight),
img.canvas, rect(bmpwidth - xcount * i, 0, bmpwidth, xtotal * i));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
11: {//从右上进入} begin
xgroup := step;
xcount := bmpwidth div xgroup;
xtotal := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(bmpwidth - xcount * i, 0, bmpwidth, xtotal * i),
img.canvas, rect(0, bmpheight - xtotal * i, xcount * i, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
12: {//开门效果} begin
xgroup := step;
xtotal := bmpwidth div 2;
xcount := bmpwidth div (xgroup * 2);
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(xtotal - xcount * i, 0, xtotal, bmpheight),
img.canvas, rect(xtotal - xcount * i, 0, xtotal, bmpheight));
newBmp.canvas.CopyRect(rect(xtotal, 0, xtotal + xcount * i, bmpheight),
img.canvas, rect(xtotal, 0, xtotal + xcount * i, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
13: {//关门效果} begin
xgroup := step;
xtotal := bmpwidth div 2;
xcount := bmpwidth div (xgroup * 2);
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, 0, xcount * i, bmpheight),
img.canvas, rect(xtotal - xcount * i, 0, xtotal, bmpheight));
newBmp.canvas.CopyRect(rect(bmpwidth - xcount * i, 0, bmpwidth, bmpheight),
img.canvas, rect(xtotal, 0, xtotal + xcount * i, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
14: {//水平伸展} begin
xgroup := step;
xtotal := bmpwidth div 2;
xcount := bmpwidth div (xgroup * 2);
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(xtotal - xcount * i, 0, xtotal + xcount * i, bmpheight),
img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
15: {//从右伸展} begin
xgroup := step;
xcount := bmpwidth div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(bmpwidth - xcount * i, 0, bmpwidth, bmpheight),
img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
16: {//从左伸展} begin
xgroup := step;
xcount := bmpwidth div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, 0, xcount * i, bmpheight),
img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
17: {//从上伸展} begin
xgroup := step;
xtotal := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, xtotal * i),
img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
18: {//从下伸展} begin
xgroup := step;
xtotal := bmpheight div xgroup;
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(0, bmpheight - xtotal * i, bmpwidth, bmpheight),
img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
19: {//闪烁效果} begin
canvas.Brush.Color := clBlack;
xgroup := step;
xtotal := xgroup div 24;
if xtotal < 1 then
exit;
if (xtotal > 1) and (xtotal < 5) then
xcount := 5;
if (xtotal > 5) and (xtotal < 10) then
xcount := 10;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(xcount * 100);
Application.ProcessMessages;
canvas.Rectangle(img.left, img.top, img.Width + img.left, img.Height + img.top);
newBmp.Free;
end;
20: {//回旋} begin
canvas.Brush.Color := clBlack;
xgroup := step;
xtotal := bmpwidth div 2;
xcount := bmpwidth div (xgroup * 2);
for j := 0 to 2 do begin
for i := 0 to xgroup do begin
newBmp.canvas.CopyRect(rect(xtotal - xcount * i, 0, xtotal + xcount * i, bmpheight),
img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
for i := 0 to xgroup do begin
if j = 2 then
else begin
newBmp.canvas.Rectangle(0, 0, bmpwidth, bmpheight);
newBmp.canvas.CopyRect(rect(xcount * i, 0, bmpwidth - xcount * i, bmpheight),
img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(1);
Application.ProcessMessages;
end;
end;
end;
newBmp.Free;
end;
21: {//两侧伸展} begin
canvas.Brush.Color := clBlack;
xgroup := step;
xcount := bmpwidth div (xgroup * 2);
for i := 0 to xgroup do begin
newBmp.canvas.Rectangle(0, 0, bmpwidth, bmpheight);
newBmp.canvas.CopyRect(rect(xcount * i, 0, bmpwidth - xcount * i, bmpheight),
img.canvas, rect(xcount * i, 0, bmpwidth - xcount * i, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
Sleep(10);
Application.ProcessMessages;
end;
newBmp.Free;
end;
22: {//随机样条} begin
canvas.Brush.Color := clBlack;
for i := 0 to bmpheight do begin
xtotal := Random(bmpheight);
newBmp.canvas.CopyRect(rect(0, xtotal, bmpwidth, xtotal + 6), img.canvas, rect(0, xtotal, bmpwidth, xtotal + 6));
canvas.Draw(img.left, img.top, newBmp);
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
23: {//溶解效果} begin
for i := 0 to bmpwidth do begin
xcount := Random(bmpwidth div 80) * 80;
xtotal := Random(bmpheight div 60) * 60;
newBmp.canvas.CopyRect(rect(xcount, xtotal, xcount + 80, xtotal + 60), img.canvas, rect(xcount, xtotal, xcount + 80, xtotal + 60));
canvas.Draw(img.left, img.top, newBmp);
end;
newBmp.canvas.CopyRect(rect(0, 0, bmpwidth, bmpheight), img.canvas, rect(0, 0, bmpwidth, bmpheight));
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
24: {//上三角} begin
h := img.Height;
w := img.Width;
for i := 1 to h do
for j := 1 to w div 2 do begin
bitblt(newBmp.canvas.Handle, (w div 2) - (i * j) div h, i, 1, 1, img.canvas.Handle, (w div 2) - j, i, srccopy);
bitblt(newBmp.canvas.Handle, (w div 2) + (i * j) div h, i, 1, 1, img.canvas.Handle, (w div 2) + j, i, srccopy);
end;
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
25: {//下三角} begin
h := img.Height;
w := img.Width;
for i := 1 to h do
for j := w div 2 downto 1 do begin
bitblt(newBmp.canvas.Handle, (w div 2) - (i * j) div h, h - i, 1, 1, img.canvas.Handle, (w div 2) - j, h - i, srccopy);
bitblt(newBmp.canvas.Handle, (w div 2) + (i * j) div h, h - i, 1, 1, img.canvas.Handle, (w div 2) + j, h - i, srccopy);
end;
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
26: {//左三角} begin
h := img.Height;
w := img.Width;
for i := 1 to w do
for j := 1 to h div 2 do begin
bitblt(newBmp.canvas.Handle, i, (h div 2) - (i * j) div w, 1, 1, img.canvas.Handle, i, (h div 2) - j, srccopy);
bitblt(newBmp.canvas.Handle, i, (h div 2) + (i * j) div w, 1, 1, img.canvas.Handle, i, (h div 2) + j, srccopy);
end;
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
27: {//右三角} begin
h := img.Height;
w := img.Width;
for i := 1 to w do
for j := 1 to h div 2 do begin
bitblt(newBmp.canvas.Handle, w - i, (h div 2) - (i * j) div w, 1, 1, img.canvas.Handle, w - i, (h div 2) - j, srccopy);
bitblt(newBmp.canvas.Handle, w - i, (h div 2) + (i * j) div w, 1, 1, img.canvas.Handle, w - i, (h div 2) + j, srccopy);
end;
canvas.Draw(img.left, img.top, newBmp);
newBmp.Free;
end;
end;
end;

procedure ShowDanru(hnd: hWnd; canvas: TCanvas; img: TImage; strFileName: string); //淡入效果
var
newBmp, basebmp: tBitmap;
baserow, row: PRGBTripleArray;
step, x, y: integer;
begin
newBmp := tBitmap.Create;
try
newBmp.PixelFormat := pf32Bit;
newBmp.LoadFromFile(strFileName);
basebmp := tBitmap.Create;
try
basebmp.PixelFormat := pf32Bit;
basebmp.Assign(newBmp);
for step := 0 to 32 do begin
for y := 0 to (newBmp.Height - 1) do begin
baserow := basebmp.ScanLine[y];
row := newBmp.ScanLine[y];
for x := 0 to (newBmp.Width - 1) do begin
row[x].rgbtRed := (step * baserow[x].rgbtRed) shr 5;
row[x].rgbtGreen := (step * baserow[x].rgbtGreen) shr 5;
row[x].rgbtBlue := (step * baserow[x].rgbtBlue) shr 5;
end;
end;
canvas.Draw(img.left, img.top, newBmp);
invalidaterect(hnd, nil, False);
redrawwindow(hnd, nil, 0, rdw_updatenow);
end;
finally
basebmp.Free;
end;
finally
newBmp.Free;
end;
end;

//压缩ACCESS数据库
function CompactAccess(srcfilename, tofilename: string): Boolean;
var
dao: OLEVariant;
begin
Result := True;
try
dao := CreateOleObject('DAO.DBEngine.35');
dao.CompactDatabase(srcfilename, tofilename);
except
Result := False;
end;
end;

function RepaireAccess(FileName: string): Boolean;
var
dao: OLEVariant;
begin
Result := True;
try
dao := CreateOleObject('DAO.DBEngine.35');
dao.RepairDatabase(FileName);
except
Result := False;
end;
end;

function FormatDrive(Handle: hWnd): integer;
const
SHFMT_DRV_A = 0;
SHFMT_DRV_B = 1;
SHFMT_ID_DEFAULT = $FFFF;
SHFMT_OPT_QUICKFORMAT = 0;
SHFMT_OPT_FULLFORMAT = 1;
SHFMT_OPT_SYSONLY = 2;
SHFMT_ERROR = -1;
SHFMT_CANCEL = -2;
SHFMT_NOFORMAT = -3;
var
FmtRes: Longint;
begin
try
FmtRes := SHFormatDrive(Handle, SHFMT_DRV_A,
SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);
case FmtRes of
SHFMT_ERROR: Result := 1; //ShowMessage('Error formatting the drive');
SHFMT_CANCEL: Result := 2; //ShowMessage('User canceled formatting the drive');
SHFMT_NOFORMAT: Result := 3;
else
Result := 4;
end;
except
Result := 5;
end;
end;

function Encrypt(const S: string; key: Word): string;
var
i: Byte;
begin
Result := '';
for i := 1 to Length(S) do begin
Result[i] := Char(Byte(S[i]) xor (key shr 8));
key := (Byte(Result[i]) + key) * C1 + C2;
end;
end;

function Decrypt(const S: string; key: Word): string;
var
i: Byte;
begin
Result := '';
for i := 1 to Length(S) do begin
Result[i] := Char(Byte(S[i]) xor (key shr 8));
key := (Byte(S[i]) + key) * C1 + C2;
end;
end;

procedure OpenCDRom(bol: Boolean);
var
Handle: hWnd;
begin
if bol then
mciSendString('Set cdaudio door open wait', nil, 0, Handle)
else
mciSendString('Set cdaudio door closed wait', nil, 0, Handle);
end;

function GetCpuSpeed: Comp;
var
t: DWord;
mhi, mlo, nhi, nlo: DWord;
t0, t1, chi, clo, shr32: Comp;
begin
shr32 := 65536;
shr32 := shr32 * 65536;

t := GetTickCount;
while t = GetTickCount do begin
end;
asm
DB 0FH
DB 031H
mov mhi,edx
mov mlo,eax
end;

while GetTickCount < (t + 1000) do begin
end;
asm
DB 0FH
DB 031H
mov nhi,edx
mov nlo,eax
end;

chi := mhi;
if mhi < 0 then chi := chi + shr32;

clo := mlo;
if mlo < 0 then clo := clo + shr32;

t0 := chi * shr32 + clo;
chi := nhi;
if nhi < 0 then chi := chi + shr32;
clo := nlo;
if nlo < 0 then clo := clo + shr32;

t1 := chi * shr32 + clo;
Result := (t1 - t0) / 1E6;
end;

//获得Program file的路径
function GetProgramPath: string;
var
reg: TRegistry;
begin
Result := '';
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
if reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion', False) then begin
Result := reg.ReadString('ProgramFilesDir');
reg.CloseKey;
reg.Free;
end;
end;

//发送邮件
procedure SendMail(EmailAdd: string);
begin
ShellExecute(0, PChar('open'), PChar('mailto:' + EmailAdd), nil, nil, SW_SHOWNORMAL);
end;

//打开网页
procedure OpenURL(url: string);
begin
ShellExecute(0, PChar('open'), PChar(url), nil, nil, SW_SHOWNORMAL);
end;

procedure DeleteFiles(Handle: THandle; Source: string);
var
FO: TShFileOpStruct;
begin
FillChar(FO, sizeof(FO), #0);
FO.Wnd := Handle;
FO.wFunc := FO_DELETE;
FO.fFlags := FOF_NOCONFIRMATION;
FO.pFrom := PChar(Source);
ShFileOperation(FO);
end;

procedure MoveFile(Handle: THandle; Source, Dest: string);
var
FO: TShFileOpStruct;
begin
FillChar(FO, sizeof(FO), #0);
FO.Wnd := Handle;
FO.wFunc := FO_MOVE;
FO.fFlags := FOF_NOCONFIRMATION;
FO.pFrom := PChar(Source + #0#0);
FO.pTo := PChar(Dest + #0#0);
ShFileOperation(FO);
end;

function FileTimeToDateTime(AFileTime: TFileTime): TDateTime;
var
SysTime: TSystemTime;
begin
FileTimeToLocalFileTime(AFileTime, AFileTime);
FileTimeToSystemTime(AFileTime, SysTime);
Result := SystemTimeToDateTime(SysTime);
end;

procedure GetTheFileTime(FileName: string; var DT1, DT2, DT3: TDateTime);
var
hFile: THandle;
FT1, FT2, FT3: TFileTime;
begin
hFile := FileOpen(FileName, fmShareDenyNone);
if hFile = INVALID_HANDLE_VALUE then
exit;
GetFileTime(hFile, @FT1, @FT2, @FT3);
DT1 := FileTimeToDateTime(FT1);
DT2 := FileTimeToDateTime(FT2);
DT3 := FileTimeToDateTime(FT3);
CloseHandle(hFile);
end;

function FkFileListGet(vMask, vFolder: string;
vSub: BOOL): TStringList;
var
sTemp, sProc, sResult: string;
K, M, n: integer;
srList: TSearchRec;
DirList, Filelist, TempList: TStringList;
oFound: Boolean;
intOldAttr: integer;
fileSearch: integer;
begin
// 建立一个文件夹列表
DirList := TStringList.Create;
Filelist := TStringList.Create;
TempList := TStringList.Create;

vFolder := trim(vFolder);
if vFolder[Length(vFolder)] <> '\' then vFolder := vFolder + '\';
// 生成文件夹列表
oFound := (FindFirst(vFolder + '*.*', (SysUtils.faDirectory + SysUtils.faHidden + SysUtils.faSysFile + SysUtils.faReadOnly), srList) = 0);
while oFound do begin
if (DirectoryExists(vFolder + srList.name) and (srList.name <> '.') and (srList.name <> '..')) then begin
DirList.Add(vFolder + srList.name);
end;
oFound := (FindNext(srList) = 0);
end;
FindClose(srList);

//查找当前目录的文件
oFound := (FindFirst(vFolder + '*.*', (SysUtils.faDirectory + SysUtils.faHidden + SysUtils.faSysFile + SysUtils.faReadOnly), srList) = 0);
while oFound do begin
if FileExists(vFolder + srList.name) then begin
intOldAttr := FileGetAttr(vFolder + srList.name);
FileSetAttr(vFolder + srList.name, 0);
fileSearch := FileOpen(vFolder + srList.name, fmOpenReadWrite);
if fileSearch > 0 then begin
FileClose(fileSearch);
FileSetAttr(vFolder + srList.name, intOldAttr);
Filelist.Add(vFolder + srList.name);
end;
end;
oFound := (FindNext(srList) = 0);
end;
FindClose(srList);
//查找列表的子目录
if vSub then begin
for K := 0 to DirList.Count - 1 do begin
TempList := FkFileListGet(vMask, DirList[K], vSub);
for M := 0 to TempList.Count - 1 do Filelist.Add(TempList[M]);
end;
end;
DirList.Free; TempList.Free;
Result := Filelist;
end;

function MyTableExists(ADOConn: TADOConnection; const ATableName: string): Boolean;
var
SL: TStringList;
i: integer;
S: string;
begin
Result := False;
S := UpperCase(ATableName);
SL := TStringList.Create;
try
ADOConn.GetTableNames(SL, False); //取得表名
for i := 0 to (SL.Count - 1) do begin
if UpperCase(SL[i]) = S then begin
Result := True;
break;
end; {if}
end; {for}
finally
SL.Free;
end; {try}
end;

//获得文件夹ThePath下的文件数目
function GetFileCount(ThePath, Ext: string): integer;
var
Num: integer;
sr: TSearchRec;
begin
Num := 0;
if ThePath[Length(ThePath)] <> '\' then
ThePath := ThePath + '\';
if (FindFirst(ThePath + Ext, faAnyFile, sr) = 0) then begin
Num := Num + 1;
while (FindNext(sr) = 0) do
Num := Num + 1;
end;
Result := Num;
end;

//获得文件夹ThePath下的子目录数目
function GetDirCount(ThePath: string): integer;

function IsValidDir(SearchRec: TSearchRec): Boolean;
begin
if (SearchRec.Attr = 16) and (SearchRec.name <> '.') and (SearchRec.name <> '..') then
Result := True
else
Result := False;
end;

var
Num: integer;
sr: TSearchRec;
begin
Num := 0;
if (FindFirst(ThePath, faDirectory, sr) = 0) then begin
if IsValidDir(sr) then begin
Num := Num + 1;
end;
while (FindNext(sr) = 0) do begin
if IsValidDir(sr) then
Num := Num + 1;
end;
end;
Result := Num;
end;

//分解文件，SDir:源目录名 DDir:目的目录名 SQz:生成的子目录前(后)缀名
// SExt:文件类型 MNum:每个文件的文件数目 B:SQz为前缀还是后缀
procedure CutDir(SDir, DDir, SQz, SExt: string; MNum: integer; B: Boolean; Handle: THandle);
var
S, i, iFileCount, iFileNum, iDirCount, iDirNum: integer;
tsr: TStringList;
DFileName, SFileName: string;
bSearch: Boolean;
begin
bSearch := False;
tsr := TStringList.Create;
tsr := FkFileListGet(SExt, SDir, False);
if SDir[Length(SDir)] <> '\' then
SDir := SDir + '\';
if DDir[Length(DDir)] <> '\' then
DDir := DDir + '\';

for i := 0 to tsr.Count - 1 do begin
SFileName := tsr[i];
if not bSearch then begin
iDirCount := GetDirCount(SDir + '*.*');
iDirNum := iDirCount;
end;

if iDirNum = 0 then begin
if B then begin
MkDir(DDir + SQz + '1');
DFileName := DDir + SQz + '1\' + ExtractFileName(SFileName);
end
else begin
MkDir(DDir + '1' + SQz);
DFileName := DDir + '1' + SQz + '\' + ExtractFileName(SFileName);
end;
iFileNum := 1;
end
else begin
if not bSearch then begin
if B then
iFileCount := GetFileCount(DDir + SQz + IntToStr(iDirCount), SExt)
else
iFileCount := GetFileCount(DDir + IntToStr(iDirCount) + SQz, SExt);
iFileNum := iFileCount;
bSearch := True;
end;

if iFileNum >= MNum then begin
if B then begin
MkDir(DDir + SQz + IntToStr(iDirNum + 1));
DFileName := DDir + SQz + IntToStr(iDirNum + 1) + '\' + ExtractFileName(SFileName)
end
else begin
MkDir(DDir + IntToStr(iDirNum + 1) + SQz);
DFileName := DDir + IntToStr(iDirNum + 1) + SQz + '\' + ExtractFileName(SFileName);
end;
iDirNum := iDirNum + 1;
iFileNum := 1;
end
else begin
if B then
DFileName := DDir + SQz + IntToStr(iDirNum) + '\' + ExtractFileName(SFileName)
else
DFileName := DDir + IntToStr(iDirNum) + SQz + '\' + ExtractFileName(SFileName);
iFileNum := iFileNum + 1;
end;
end;
MoveFile(Handle, SFileName, DFileName);
end;
end;

//BMP格式图片转JPG格式
procedure BMPToJPG(BmpFileName, JpegFileName: string);
var
jpeg: TJPEGImage;
BMP: tBitmap;
begin
BMP := tBitmap.Create;
try
BMP.LoadFromFile(BmpFileName);
jpeg := TJPEGImage.Create;
try
jpeg.Assign(BMP);
jpeg.Compress;
//保存图片
jpeg.SaveToFile(JpegFileName);
finally
jpeg.Free;
end;
finally
BMP.Free;
end;
end;

//灰度处理; 1表示取rgb的平均值 2表示取rgb的最大值
// 3表示根据YUV求出Y分量
procedure SetGray(SBmp, DBmp: tBitmap; iTag: integer);
var
x, y, Gray: integer;
p: pByteArray;
begin
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
case iTag of
1:
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
Gray := (p[3 * x + 2] + p[3 * x + 1] + p[3 * x]) div 3;
p[3 * x + 2] := Gray;
p[3 * x + 1] := Gray;
p[3 * x] := Gray;
end;
end;
2:
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
//这里采用方法二
Gray := Max(p[3 * x + 2], p[3 * x + 1]);
//Max函数在Math单元中定义
Gray := Max(Gray, p[3 * x]);
p[3 * x + 2] := Byte(Gray);
p[3 * x + 1] := Byte(Gray);
p[3 * x] := Byte(Gray);
end;
end;
3:
for y := 0 to DBmp.Height - 1 do begin
//获取每一行象素信息
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
//这里采用方法三
//即 Y＝0.299R+0587G+0.114B
Gray := Round(p[3 * x + 2] * 0.3 + p[3 * x + 1] * 0.59
+ p[3 * x] * 0.11);
//由于是24位真彩色，故一个象素点为三个字节
p[3 * x + 2] := Byte(Gray);
p[3 * x + 1] := Byte(Gray);
p[3 * x] := Byte(Gray);
//Gray的值必须在0～255之间
end;
end;
end;
end;

procedure GrayDiagram(BMP: tBitmap; Image1, Image2: TImage); //求灰度直方图
var
x, y, Gray, i, j, maxvalue: integer;
p: pByteArray;
bmp2: tBitmap;
Color: TColor;
begin
BMP.PixelFormat := pf24Bit;
for y := 0 to BMP.Height - 1 do begin
p := BMP.ScanLine[y];
for x := 0 to BMP.Width - 1 do begin
//算出每一点的灰度值
Gray := Round(p[x * 3 + 2] * 0.3 + p[x * 3 + 1] * 0.59 + p[x
* 3] * 0.11);
//Application.MessageBox(PChar(IntToStr(Gray)),'');
for i := 0 to 255 do begin
if Gray = i then begin
//统计出每一个灰度级上象素点的个数
Grayclass[i] := Grayclass[i] + 1;
end;
end;
end;
end;
//初始化最大值变量
maxvalue := Grayclass[0];
Image1.canvas.Brush.Color := clSkyBlue;
//填充背景
Image1.canvas.FillRect(rect(0, 0, Image1.Width, Image1.Height));
Image1.canvas.Pen.Color := clyellow;
for i := 1 to 255 do begin
if maxvalue < Grayclass[i] then begin
//获取某个灰度值上最大象素点数
maxvalue := Grayclass[i];
end;
end;
//开始绘制
for i := 0 to 255 do begin
//选用灰度渐变的画笔
Image1.canvas.Pen.Color := RGB(i, i, i);
Image1.canvas.MoveTo(i, 273);
Image1.canvas.LineTo(i, 273 - Round(50 * (log10(Grayclass[i] + 1))));
//统计的数据进行对数降级
end;
bmp2 := tBitmap.Create;
bmp2.Width := Image2.Width;
bmp2.Height := Image2.Height;
//在image2上绘制256级灰度分布图
for i := 0 to bmp2.Width do begin
Color := RGB(i, i, i);
for j := 0 to bmp2.Height do begin
bmp2.canvas.Pixels[i, j] := Color;
end;
end;
Image2.Picture.Bitmap.Assign(bmp2);
bmp2.Free;
end;

procedure SetTwo(SBmp, DBmp: tBitmap); //二值化
var
x, y, Gray: integer;
p: pByteArray;
begin
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
randomize;
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
//一个象素点三个字节
Gray := Round(p[x * 3 + 2] * 0.3 + p[x * 3 + 1] * 0.59 + p[x
* 3] * 0.11);
if Gray > 128 then {//全局阀值128} begin
p[x * 3] := 255;
p[x * 3 + 1] := 255;
p[x * 3 + 2] := 255;
end
else begin
p[x * 3] := 0;
p[x * 3 + 1] := 0;
p[x * 3 + 2] := 0;
end;
end;
end;
end;

procedure SetBright(SBmp, DBmp: tBitmap); //亮度调节
var
x, y: integer;
p: pByteArray;
begin
//24位真彩色
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
randomize;
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
//每个象素点的R、G、B分量进行调节
begin
p[x * 3] := Min(255, p[x * 3] + 20); //不能越界，限制在0～255
p[x * 3 + 1] := Min(255, p[x * 3 + 1] + 20);
p[x * 3 + 2] := Min(255, p[x * 3 + 2] + 20);
end;
end;
end;
end;

procedure SetContact(SBmp, DBmp: tBitmap); //对比度
var
x, y: integer;
p: pByteArray;
begin
//24位真彩色
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
randomize;
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
//确定阀值为128
if (p[x * 3] < 246) and (p[x * 3] > 128) and (p[x * 3 + 1] > 128)
and (p[x * 3 + 1] < 246) and (p[x * 3 + 2] > 128) and (p[x * 3 + 2] < 246) then begin
p[x * 3] := (p[x * 3] + 10);
p[x * 3 + 1] := (p[x * 3 + 1] + 10);
p[x * 3 + 2] := (p[x * 3 + 2] + 10);
end;
if (p[x * 3] > 10) and (p[x * 3] < 128) and (p[x * 3 + 1] > 10) and (p[x *
3 + 1] < 128) and (p[x * 3 + 2] > 10) and (p[x * 3 + 2] < 128) then begin
p[x * 3] := (p[x * 3] - 10);
p[x * 3 + 1] := (p[x * 3 + 1] - 10);
p[x * 3 + 2] := (p[x * 3 + 2] - 10);
end;
end;
end;
end;

procedure SetHue(SBmp, DBmp: tBitmap); //饱和度
var
x, y: integer;
p: pByteArray;
begin
//24位真彩色
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
randomize;
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
if p[x * 3] > 128 then begin
p[x * 3] := p[x * 3] + 15;
end
else begin
p[x * 3] := p[x * 3] - 15;
end;
end;

if p[x * 3 + 1] > 128 then begin
p[x * 3 + 1] := p[x * 3 + 1] + 15;
end
else begin
p[x * 3 + 1] := p[x * 3 + 1] - 15;
end;
if p[x * 3 + 2] > 128 then begin
p[x * 3 + 2] := p[x * 3 + 2] + 15;
end
else
p[x * 3 + 2] := p[x * 3 + 2] - 15;
end;
end;

procedure SetColor(aSource, ATarget: tBitmap; AColor: TColor); //图像着色
var
i, j: integer;
S, t: pRGBTriple;
R, G, B: Byte;
cl: TColor;
begin
cl := ColorToRGB(AColor);
//获取选中颜色的R、G、B三个分量
R := GetRValue(cl);
G := GetGValue(cl);
B := GetBValue(cl);
//都指定是24位真彩色位图
aSource.PixelFormat := pf24Bit;
ATarget.PixelFormat := pf24Bit;
ATarget.Width := aSource.Width;
ATarget.Height := aSource.Height;
for i := 0 to aSource.Height - 1 do begin
S := aSource.ScanLine[i];
t := ATarget.ScanLine[i];
for j := 0 to aSource.Width - 1 do begin
//由源图象的象素点的情况获得目标象素点的情况
t^.rgbtBlue := (B * S^.rgbtBlue) div 255;
t^.rgbtGreen := (G * S^.rgbtGreen) div 255;
t^.rgbtRed := (R * S^.rgbtRed) div 255;
inc(S);
inc(t);
end;
end;
end;

procedure SetInvert(SBmp, DBmp: tBitmap); //图像反色
//var
// MyDC: HDC;
begin
//MyDC := GetDC(Form1.Handle);
// if not PatBlt(MyDC,
// Image1.Left,
// Image1.Top,
// Image1.Left + Image1.Width,
// Image1.Top + Image1.Height,
// DSTINVERT) then
// ShowMessage('ERROR :~(');
DBmp.Width := SBmp.Width;
DBmp.Height := SBmp.Height;
bitblt(DBmp.canvas.Handle, 0, 0, DBmp.Width, DBmp.Height, SBmp.canvas.Handle, 0, 0, NOTSRCCOPY);
end;

procedure SetBaoguang(SBmp, DBmp: tBitmap); //图像曝光
var
x, y: integer;
p: pByteArray;
begin
//24位真彩色
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
randomize;
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
if p[x * 3] < 128 then
p[x * 3] := not p[x * 3]; { TODO : 各分量取反 }
if p[x * 3 + 1] < 128 then
p[x * 3 + 1] := not p[x * 3 + 1];
if p[x * 3 + 2] < 128 then
p[x * 3 + 2] := not p[x * 3 + 2];
end;
end;
end;

procedure SetGamma(SBmp, DBmp: tBitmap); //Gamma校正
var
x, y: integer;
p: pByteArray;
R, G, B: Byte;
begin
//24位真彩色
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
randomize;
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
B := p[x * 3];
G := p[x * 3 + 1];
R := p[x * 3 + 2];
p[x * 3 + 2] := Min(255, Round(255 * power((R / 256), 0.45)));
p[x * 3 + 1] := Min(255, Round(255 * power((G / 256), 0.45)));
p[x * 3] := Min(255, Round(255 * power((B / 256), 0.45)));
end
end;
end;

procedure SetNoise(SBmp, DBmp: tBitmap); //噪声调节
var
x, y: integer;
p: pByteArray;
R, G, B: integer;
begin
//24位真彩色
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
randomize;
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
R := p[3 * x + 2] + Random(50) - 50 div 2;
G := p[3 * x + 1] + Random(50) - 50 div 2;
B := p[3 * x] + Random(50) - 50 div 2;
p[x * 3] := Max(0, Min(255, B));
p[x * 3 + 1] := Max(0, Min(255, G));
p[x * 3 + 2] := Max(0, Min(255, R));
end;
end;
end;

procedure Pingyi(SBmp, DBmp: tBitmap); //图像平移
type
//定义一个pRGBTripleArray类型，用于处理24位的位图
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..32768 - 1] of TRGBTriple;
var
i, j, bmpheight, bmp integer;
ImageShifted: PRGBTripleArray;
ImageUnShifted: PRGBTripleArray;
OriginalY, OriginalX: integer;
tx, ty: integer; //x，y方向上的偏移量
begin
//都转化为24位真彩色
DBmp.PixelFormat := pf24Bit;
DBmp.Width := SBmp.Width;
DBmp.Height := SBmp.Height;
bmpheight := SBmp.Height;
bmpwidth := SBmp.Width;
//初始化偏移量
tx := 30;
ty := 40;
for j := bmpheight - 1 downto 0 do begin
//获取平移后图像的每一行的象素信息
ImageShifted := DBmp.ScanLine[j];
for i := bmpwidth - 1 downto 0 do begin
//由当前点的坐标以及偏移量算出原始图像对应点的坐标
OriginalX := i - tx;
OriginalY := j - ty;
if (OriginalX >= 0) and (OriginalX <= bmpwidth - 1) and
(OriginalY >= 0) and (OriginalY <= bmpheight - 1) then begin
ImageUnShifted := SBmp.ScanLine[OriginalY];
ImageShifted[i] := ImageUnShifted[OriginalX];
end
else
{//如果算出的点不在原图有效范围，则象素点的颜色设置为白色} begin
ImageShifted[i].rgbtBlue := 255;
ImageShifted[i].rgbtGreen := 255;
ImageShifted[i].rgbtRed := 255;
end
end
end;
end;

procedure LeftRightMirror(SBmp, DBmp: tBitmap); //水平镜像
var
bmp1, bmp2: tBitmap;
t, p: pByteArray;
x, y: integer;
begin
bmp1 := tBitmap.Create;
bmp2 := tBitmap.Create;
bmp2.Assign(SBmp);
bmp1.Assign(SBmp);
DBmp.Width := 2 * bmp1.Width;
DBmp.Height := SBmp.Height;
for y := 0 to bmp2.Height - 1 do begin
t := bmp2.ScanLine[y];
p := bmp1.ScanLine[y];
for x := 0 to bmp2.Width - 1 do begin
p[3 * x + 2] := t[3 * (bmp2.Width - 1 - x) + 2];
p[3 * x + 1] := t[3 * (bmp2.Width - 1 - x) + 1];
p[3 * x] := t[3 * (bmp2.Width - 1 - x)];
end;
end;
DBmp.canvas.Draw(0, 0, bmp2);
DBmp.canvas.Draw(bmp2.Width, 0, bmp1);
bmp1.Free;
bmp2.Free;
end;

procedure Rotateangle(SBmp, DBmp: tBitmap; angle: extended); //任意角度旋转
var
c1x, c1y, c2x, c2y: integer;
p1x, p1y, p2x, p2y: integer;
radius, n: integer;
alpha: extended;
c0, C1, C2, c3: TColor;
begin
if SBmp.Width > SBmp.Height then begin
DBmp.Width := SBmp.Width;
DBmp.Height := SBmp.Width;
end
else
DBmp.Width := SBmp.Height;
DBmp.Height := SBmp.Height;
//将角度转换为PI值
angle := (angle / 180) * PI;
// 计算中心点，你可以修改它
c1x := SBmp.Width div 2;
c1y := SBmp.Height div 2;
c2x := DBmp.Width div 2;
c2y := DBmp.Height div 2;
// 步骤数值number
if c2x < c2y then
n := c2y
else
n := c2x;
Dec(n, 1);
// 开始旋转
for p2x := 0 to n do begin
for p2y := 0 to n do begin
if p2x = 0 then
alpha := PI / 2
else
alpha := ArcTan2(p2y, p2x);
radius := Round(Sqrt((p2x * p2x) + (p2y * p2y)));
p1x := Round(radius * Cos(angle + alpha));
p1y := Round(radius * Sin(angle + alpha));

c0 := SBmp.canvas.Pixels[c1x + p1x, c1y + p1y];
C1 := SBmp.canvas.Pixels[c1x - p1x, c1y - p1y];
C2 := SBmp.canvas.Pixels[c1x + p1y, c1y - p1x];
c3 := SBmp.canvas.Pixels[c1x - p1y, c1y + p1x];

DBmp.canvas.Pixels[c2x + p2x, c2y + p2y] := c0;
DBmp.canvas.Pixels[c2x - p2x, c2y - p2y] := C1;
DBmp.canvas.Pixels[c2x + p2y, c2y - p2x] := C2;
DBmp.canvas.Pixels[c2x - p2y, c2y + p2x] := c3;
end;
Application.ProcessMessages
end;
end;

procedure TwistPicture(BMP, Dst: tBitmap; Amount: integer); //图像的扭曲
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
R: Single;
theta: Single;
ifx, ify: integer;
dx, dy: Single;
OFFSET: Single;
ty, tx: integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: integer;
new_blue: integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: integer;
sli, slo: pByteArray;

function ArcTan2(xt, yt: Single): Single;
begin
if xt = 0 then
if yt > 0 then
Result := PI / 2
else
Result := -(PI / 2)
else begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := PI + ArcTan(yt / xt);
end;
end;

begin
OFFSET := -(PI / 2);
dx := BMP.Width - 1;
dy := BMP.Height - 1;
R := Sqrt(dx * dx + dy * dy);
tx2 := R;
ty2 := R;
txmid := (BMP.Width - 1) / 2; //Adjust these to move center of rotation
tymid := (BMP.Height - 1) / 2; //Adjust these to move ......
fxmid := (BMP.Width - 1) / 2;
fymid := (BMP.Height - 1) / 2;
if tx2 >= BMP.Width then
tx2 := BMP.Width - 1;
if ty2 >= BMP.Height then
ty2 := BMP.Height - 1;
for ty := 0 to Round(ty2) do begin
for tx := 0 to Round(tx2) do begin
dx := tx - txmid;
dy := ty - tymid;
R := Sqrt(dx * dx + dy * dy);
if R = 0 then begin
fx := 0;
fy := 0;
end
else begin
theta := ArcTan2(dx, dy) - R / Amount - OFFSET;
fx := R * Cos(theta);
fy := R * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;

ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else begin
weight_x[0] := -(fx - ifx);
weight_x[1] := 1 - weight_x[0];
end;

if ifx < 0 then
ifx := BMP.Width - 1 - (-ifx mod BMP.Width)
else if ifx > BMP.Width - 1 then
ifx := ifx mod BMP.Width;
if ify < 0 then
ify := BMP.Height - 1 - (-ify mod BMP.Height)
else if ify > BMP.Height - 1 then
ify := ify mod BMP.Height;

total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do begin
for iy := 0 to 1 do begin
if ify + iy < BMP.Height then
sli := BMP.ScanLine[ify + iy]
else
sli := BMP.ScanLine[BMP.Height - ify -
iy];
if ifx + ix < BMP.Width then begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else begin
new_red := sli[(BMP.Width - ifx - ix)
* 3];
new_green := sli[(BMP.Width - ifx -
ix) * 3 +
1];
new_blue := sli[(BMP.Width - ifx - ix)
* 3 +
2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green *
weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.ScanLine[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
end;
end;
end;

procedure WaveWrap(SBmp, DBmp: tBitmap; XDIV, YDIV, RatioVal: integer); { TODO : 扭曲 }
var
Tmp, BMP: tBitmap;
i, j, XSrc, YSrc: integer;
starttime, endtime: Cardinal;
begin
if (YDIV = 0) or (XDIV = 0) then
exit;
starttime := GetTickCount;
for i := 0 to SBmp.Width - 1 do begin
for j := 0 to SBmp.Height - 1 do begin
XSrc := Round(i + RatioVal * Sin(j / YDIV));
YSrc := Round(j + RatioVal * Sin(i / XDIV));
if XSrc < 0 then
XSrc := SBmp.Width - 1 - (-XSrc mod SBmp.Width)
else if XSrc >= SBmp.Width then
XSrc := XSrc mod SBmp.Width;
if YSrc < 0 then
YSrc := SBmp.Height - 1 - (-YSrc mod SBmp.Height)
else if YSrc >= SBmp.Height then
YSrc := YSrc mod (SBmp.Height - 1);

BMP.canvas.Pixels[i, j] := SBmp.canvas.Pixels[XSrc, YSrc];
// end;
end;
end;
endtime := GetTickCount;
end;

procedure TiltBitmap(const InBitmap, OutBitmap: tBitmap;
const WidthTop, WidthBottom: integer);
const
clBackColor = clBlack;
BestQuality = True;
var
y, xWidthDiff, xWidthCurrentLine: integer;
d: Real;
begin
OutBitmap.PixelFormat := InBitmap.PixelFormat;
if WidthTop > WidthBottom then
OutBitmap.Width := WidthTop
else
OutBitmap.Width := WidthBottom;
OutBitmap.Height := InBitmap.Height;
OutBitmap.canvas.Brush.Color := clBlack;
OutBitmap.canvas.FillRect(OutBitmap.canvas.ClipRect);
OutBitmap.canvas.CopyMode := cmSrcCopy;
if BestQuality then begin
{slower but better quality with color images}
SetStretchBltMode(OutBitmap.canvas.Handle, HALFTONE);
SetBrushOrgEx(OutBitmap.canvas.Handle, 0, 0, nil);
end
else
{quicker but slightly lower quality}
SetStretchBltMode(OutBitmap.canvas.Handle, HALFTONE);
OutBitmap.canvas.CopyMode := cmSrcCopy;
d := (WidthBottom - WidthTop) / OutBitmap.Height;

for y := 0 to OutBitmap.Height - 1 do begin
xWidthCurrentLine := Trunc(WidthTop + d * y);
xWidthDiff := (OutBitmap.Width - xWidthCurrentLine) div 2;
OutBitmap.canvas.CopyRect(rect(xWidthDiff, y, xWidthDiff +
xWidthCurrentLine, y + 1),
InBitmap.canvas, rect(0, y, InBitmap.Width, y + 1));
end;
end;

procedure HSLtoRGB(h, S, L: integer; var R, G, B: integer);
//hsl颜色空间到rgb空间的转换
var //类似于返回多个值的函数
Sat, Lum: Double;
begin
R := 0;
G := 0;
B := 0;
if (h < 360) and (h >= 0) and (S <= 100) and (S >= 0) and (L <= 100) and (L
>=
0) then begin
if h <= 60 then begin
R := 255;
G := Round((255 / 60) * h);
B := 0;
end
else if h <= 120 then begin
R := Round(255 - (255 / 60) * (h - 60));
G := 255;
B := 0;
end
else if h <= 180 then begin
R := 0;
G := 255;
B := Round((255 / 60) * (h - 120));
end
else if h <= 240 then begin
R := 0;
G := Round(255 - (255 / 60) * (h - 180));
B := 255;
end
else if h <= 300 then begin
R := Round((255 / 60) * (h - 240));
G := 0;
B := 255;
end
else if h < 360 then begin
R := 255;
G := 0;
B := Round(255 - (255 / 60) * (h - 300));
end;

Sat := abs((S - 100) / 100);
R := Round(R - ((R - 128) * Sat));
G := Round(G - ((G - 128) * Sat));
B := Round(B - ((B - 128) * Sat));

Lum := (L - 50) / 50;
if Lum > 0 then begin
R := Round(R + ((255 - R) * Lum));
G := Round(G + ((255 - G) * Lum));
B := Round(B + ((255 - B) * Lum));
end
else if Lum < 0 then begin
R := Round(R + (R * Lum));
G := Round(G + (G * Lum));
B := Round(B + (B * Lum));
end;
end;
end;

procedure RGBtoHSL(R, G, B: integer; var h, S, L: integer);
// RGB空间到HSL空间的转换
var
Delta: Double;
CMax, CMin: Double;
Red, Green, Blue, Hue, Sat, Lum: Double;
begin
Red := R / 255;
Green := G / 255;
Blue := B / 255;
CMax := Max(Red, Max(Green, Blue));
CMin := Min(Red, Min(Green, Blue));
Lum := (CMax + CMin) / 2;
if CMax = CMin then begin
Sat := 0;
Hue := 0;
end
else begin
if Lum < 0.5 then
Sat := (CMax - CMin) / (CMax + CMin)
else
Sat := (CMax - CMin) / (2 - CMax - CMin);
Delta := CMax - CMin;
if Red = CMax then
Hue := (Green - Blue) / Delta
else if Green = CMax then
Hue := 2 + (Blue - Red) / Delta
else
Hue := 4.0 + (Red - Green) / Delta;
Hue := Hue / 6;
if Hue < 0 then
Hue := Hue + 1;
end;
h := Round(Hue * 360);
S := Round(Sat * 100);
L := Round(Lum * 100);
end;

procedure HSLBright(SBmp, DBmp: tBitmap); //基于HSL颜色系统的S亮度调节
var
x, y, ScanlineBytes: integer;
p: PRGBTripleArray;
RVALUE, bvalue, gvalue: integer;
hVALUE, sVALUE, lVALUE: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
//指定为24位
p := SBmp.ScanLine[0];
ScanlineBytes := integer(DBmp.ScanLine[1]) - integer(DBmp.ScanLine[0]);
//获取两行间距，此法只需执行Scanline两次，速度快，是优化的
for y := 0 to DBmp.Height - 1 do begin
for x := 0 to DBmp.Width - 1 do begin
//获取RGB的三个分量值，并进行赋值
RVALUE := p[x].rgbtRed;
gvalue := p[x].rgbtGreen;
bvalue := p[x].rgbtBlue;
// 调用前面的RGB转HSL过程，获取HSL三个分量值
RGBtoHSL(RVALUE, gvalue, bvalue, hVALUE, sVALUE, lVALUE);
//亮度值进行线性调节。
lVALUE := lVALUE + 20;
lVALUE := Min(100, lVALUE);
//下面两行是亮度减小操作
//SVALUE := SVALUE - 5;
//调用前面的HSL空间转RGB颜色空间的过程，获得RGB三个分量
HSLtoRGB(hVALUE, sVALUE, lVALUE, RVALUE, gvalue, bvalue);
p[x].rgbtRed := RVALUE;
p[x].rgbtGreen := gvalue;
p[x].rgbtBlue := bvalue;
end;
inc(integer(p), ScanlineBytes);
//指针递增
end;
end;

procedure HSLSaturation(SBmp, DBmp: tBitmap); //基于HSL颜色系统的饱和度调节
var
x, y, ScanlineBytes: integer;
p: PRGBTripleArray;
RVALUE, bvalue, gvalue: integer;
hVALUE, sVALUE, lVALUE: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
//指定为24位
p := SBmp.ScanLine[0];
ScanlineBytes := integer(DBmp.ScanLine[1]) - integer(DBmp.ScanLine[0]);
//获取两行间距，此法只需执行Scanline两次，速度快，是优化的
for y := 0 to DBmp.Height - 1 do begin
for x := 0 to DBmp.Width - 1 do begin
//获取RGB的三个分量值，并进行赋值
RVALUE := p[x].rgbtRed;
gvalue := p[x].rgbtGreen;
bvalue := p[x].rgbtBlue;
// 调用前面的RGB转HSL过程，获取HSL三个分量值
RGBtoHSL(RVALUE, gvalue, bvalue, hVALUE, sVALUE, lVALUE);
//饱和度值进行线性调节。
sVALUE := sVALUE + 20;
sVALUE := Min(100, sVALUE);
//下面两行是饱和度度减小操作
//SVALUE := SVALUE - 5;
//调用前面的HSL空间转RGB颜色空间的过程，获得RGB三个分量
HSLtoRGB(hVALUE, sVALUE, lVALUE, RVALUE, gvalue, bvalue);
p[x].rgbtRed := RVALUE;
p[x].rgbtGreen := gvalue;
p[x].rgbtBlue := bvalue;
end;
inc(integer(p), ScanlineBytes);
//指针递增
end;
end;

procedure RGBTripleToCMY(const RGB: TRGBTriple; var C, M, y: integer); //RGB到CMY颜色系统的转换
begin
with RGB do begin
C := 255 - rgbtRed;
M := 255 - rgbtGreen;
y := 255 - rgbtBlue;
end;
end;

procedure RGBTripleToCMYK(const RGB: TRGBTriple; var C, M, y, K: integer); //RGB到CMYK颜色系统的转换
begin
RGBTripleToCMY(RGB, C, M, y);
K := MinIntValue([C, M, y]);
C := C - K;
M := M - K;
y := y - K;
end;

function CMYToRGBTriple(const C, M, y: integer): TRGBTriple;
begin
with Result do begin
rgbtRed := 255 - C;
rgbtGreen := 255 - M;
rgbtBlue := 255 - y;
end;
end;

function CMYKToRGBTriple(const C, M, y, K: integer): TRGBTriple;
begin
with Result do begin
rgbtRed := 2550 - (C + K);
rgbtBlue := 255 - (y + K);
rgbtGreen := 255 - (M + K);
end;
end;

procedure RGBTripleToHSV(const RGB: TRGBTriple; var h, S, V: integer); //RGB到HSV颜色系统的转换
var
Delta: integer;
Min: integer;
begin
with RGB do begin
Min := MinIntValue([rgbtRed, rgbtBlue, rgbtGreen]);
V := MaxIntValue([rgbtRed, rgbtBlue, rgbtGreen]);
end;
Delta := V - Min;
if V = 0 then
S := 0
else
S := MulDiv(Delta, 255, V);

if S = 0 then
h := 0
else begin
with RGB do begin
if rgbtRed = V then
h := MulDiv(rgbtGreen - rgbtBlue, 60, Delta)
else if rgbtGreen = V then
h := 120 + MulDiv(rgbtBlue - rgbtRed, 60, Delta)
else if rgbtRed = V then
h := 240 + MulDiv(rgbtRed - rgbtGreen, 60, Delta);
end;
if h < 0 then
h := h + 360;
end;
end;

function HSVToRGBTriple(const h, S, V: integer): TRGBTriple;
const
divisor: integer = 255 * 60;
var
f, hTemp, p, q, t, VS: integer;
begin
if S = 0 then
Result := RGBToRGBTriple(V, V, V)
else begin
if h = 360 then
hTemp := 0
else
hTemp := h;

f := hTemp mod 60;
hTemp := hTemp div 60;
VS := V * S;
p := V - VS div 255;
q := V - (VS * f) div divisor;
t := V - (VS * (60 - f)) div divisor;
case hTemp of
0: Result := RGBToRGBTriple(V, t, p);
1: Result := RGBToRGBTriple(q, V, p);
2: Result := RGBToRGBTriple(p, V, t);
3: Result := RGBToRGBTriple(p, q, V);
4: Result := RGBToRGBTriple(t, p, V);
5: Result := RGBToRGBTriple(V, p, q);
else
Result := RGBToRGBTriple(0, 0, 0);
end;
end;
end;

function RGBToRGBTriple(R, G, B: integer): TRGBTriple;
begin
Result.rgbtRed := R;
Result.rgbtGreen := G;
Result.rgbtBlue := B;
end;

procedure GetRedChannel(SBmp, DBmp: tBitmap); //获得红色通道
var
p: pByteArray;
x, y: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
p[x * 3] := 0;
p[x * 3 + 1] := 0;
end;
end;
end;

procedure GetBlueChannel(SBmp, DBmp: tBitmap); //获得蓝色通道
var
p: pByteArray;
x, y: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
p[x * 3 + 1] := 0;
p[x * 3 + 2] := 0;
end;
end;
end;

procedure GetGreenChannel(SBmp, DBmp: tBitmap); //获得绿色通道
var
p: pByteArray;
x, y: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
p[x * 3] := 0;
p[x * 3 + 2] := 0;
end;
end;
end;

procedure GetCChannel(SBmp, DBmp: tBitmap); //获得C通道
var
p: pByteArray;
x, y: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
p[x * 3 + 2] := 0;
end;
end;
end;

procedure GetMChannel(SBmp, DBmp: tBitmap); //获得M通道
var
p: pByteArray;
x, y: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
p[x * 3 + 1] := 0;
end;
end;
end;

procedure GetYChannel(SBmp, DBmp: tBitmap); //获得Y通道
var
p: pByteArray;
x, y: integer;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
p[x * 3] := 0;
end;
end;
end;

procedure RGBAdjust(SBmp, DBmp: tBitmap); //RGB颜色调整
var
x, y, ScanlineBytes: integer;
p: pByteArray;
begin
//加载位图
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
for y := 0 to DBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to DBmp.Width - 1 do begin
//红色分量增加
begin
if p[x * 3 + 2] < 245 then begin
p[x * 3 + 2] := p[x * 3 + 2] + 30;
end;
end;
//红色分量减少
begin
if p[x * 3 + 2] > 10 then begin
p[x * 3 + 2] := p[x * 3 + 2] - 10;
end;
end;
end;
{ //绿色分量增加
begin
if p[x * 3 + 1] < 245 then
begin
p[x * 3 + 1] := p[x * 3 + 1] + 10;
end;
end;
//绿色分量减小
begin
if p[x * 3 + 1] > 10 then
begin
p[x * 3 + 1] := p[x * 3 + 1] - 10;
end;
end; }
//蓝色分量增加
{begin
if p[x * 3] < 245 then
begin
p[x * 3] := p[x * 3] + 20;
end;
end;
//蓝色分量减小
begin
if p[x * 3] > 10 then
begin
p[x * 3] := p[x * 3] - 10;
end;
end; }
//指针递增
end;
end;

procedure PaintRainbow(Dc: hDc; x, y, Width, Height: integer;
bVertical, WrapToRed: BOOL);
var
i: integer;
ColorChunk: integer;
OldBrush: hBrush;
OldPen: hPen;
R: integer;
G: integer;
B: integer;
Chunks: integer;
ChunksMinus1: integer;
pt: TPoint;
begin
// OffsetViewportOrgEx(Dc, x, y, pt);

if WrapToRed = False then
Chunks := 5
else
Chunks := 6;
ChunksMinus1 := Chunks - 1;
if bVertical = False then
ColorChunk := Width div Chunks
else
ColorChunk := Height div Chunks;

{Red To Yellow}
R := 255;
B := 0;
for i := 0 to ColorChunk do begin
G := (255 div ColorChunk) * i;
OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));
if bVertical = False then
PatBlt(Dc, i, 0, 1, Height, PatCopy)
else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;

{Yellow To Green}
G := 255;
B := 0;
for i := ColorChunk to (ColorChunk * 2) do begin
R := 255 - (255 div ColorChunk) * (i - ColorChunk);
OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));
if bVertical = False then
PatBlt(Dc, i, 0, 1, Height, PatCopy)
else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;

{Green To Cyan}
R := 0;
G := 255;
for i := (ColorChunk * 2) to (ColorChunk * 3) do begin
B := (255 div ColorChunk) * (i - ColorChunk * 2);
OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));
if bVertical = False then
PatBlt(Dc, i, 0, 1, Height, PatCopy)
else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;

{Cyan To Blue}
R := 0;
B := 255;
for i := (ColorChunk * 3) to (ColorChunk * 4) do begin
G := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));
if bVertical = False then
PatBlt(Dc, i, 0, 1, Height, PatCopy)
else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;

{Blue To Magenta}
G := 0;
B := 255;
for i := (ColorChunk * 4) to (ColorChunk * 5) do begin
R := (255 div ColorChunk) * (i - ColorChunk * 4);
OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));
if bVertical = False then
PatBlt(Dc, i, 0, 1, Height, PatCopy)
else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush))
end;

if WrapToRed <> False then begin
{Magenta To Red}
R := 255;
G := 0;
for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin
B := 255 - ((255 div ColorChunk) * (i - ColorChunk * 5));
OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));
if bVertical = False then
PatBlt(Dc, i, 0, 1, Height, PatCopy)
else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
end;

{Fill Remainder}
if (Width - (ColorChunk * Chunks) - 1) > 0 then begin
if WrapToRed <> False then begin
R := 255;
G := 0;
B := 0;
end
else begin
R := 255;
G := 0;
B := 255;
end;
OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));
if bVertical = False then
PatBlt(Dc, ColorChunk * Chunks, 0, Width - (ColorChunk * Chunks), Height,
PatCopy)
else
PatBlt(Dc, 0, ColorChunk * Chunks, Width, Height - (ColorChunk * Chunks),
PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
OffsetViewportOrgEx(Dc, pt.x, pt.y, pt);
end;

procedure RbsGradientFill(canvas: TCanvas; grdType: TGradientFillType; fromCol:
TColor;
toCol: TColor; ARect: TRect);
var
FromR, FromG, FromB: integer;
DiffR, DiffG, DiffB: integer;

i: integer;
bm: tBitmap;
ColorRect: TRect;
R, G, B: Byte;

//for elliptical
Pw, Ph: Real;
x0, y0, x1, y1, x2, y2, x3, y3: Real;
points: array[0..3] of TPoint;
haf: integer;

begin
//set bitmap
bm := tBitmap.Create;
bm.Width := ARect.right;
bm.Height := ARect.bottom;

//calc colors
FromR := fromCol and $000000FF; //Strip out separate RGB values
FromG := (fromCol shr 8) and $000000FF;
FromB := (fromCol shr 16) and $000000FF;
DiffR := (toCol and $000000FF) - FromR; //Find the difference
DiffG := ((toCol shr 8) and $000000FF) - FromG;
DiffB := ((toCol shr 16) and $000000FF) - FromB;

//draw gradient
case grdType of
rgsHorizontal: begin
ColorRect.top := 0; //Set rectangle top
ColorRect.bottom := bm.Height;
for i := 0 to 255 do begin //Make lines (rectangles) of color
ColorRect.left := MulDiv(i, bm.Width, 256);
//Find left for this color
ColorRect.right := MulDiv(i + 1, bm.Width, 256); //Find Right
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);
bm.canvas.Brush.Color := RGB(R, G, B);
//Plug colors into brush
bm.canvas.FillRect(ColorRect); //Draw on Bitmap
end;

end;
rgsVertical: begin
ColorRect.left := 0; //Set rectangle left&right
ColorRect.right := bm.Width;
for i := 0 to 255 do begin //Make lines (rectangles) of color
ColorRect.top := MulDiv(i, bm.Height, 256);
//Find top for this color
ColorRect.bottom := MulDiv(i + 1, bm.Height, 256);
//Find Bottom
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);
bm.canvas.Brush.Color := RGB(R, G, B);
//Plug colors into brush
bm.canvas.FillRect(ColorRect); //Draw on Bitmap
end;

end;
rgsElliptic: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
x1 := 0 - (bm.Width / 4);
x2 := bm.Width + (bm.Width / 4) + 4;
y1 := 0 - (bm.Height / 4);
y2 := bm.Height + (bm.Height / 4) + 4;
Pw := ((bm.Width / 4) + (bm.Width / 2)) / 155;
Ph := ((bm.Height / 4) + (bm.Height / 2)) / 155;
for i := 0 to 155 do begin //Make ellipses of color
x1 := x1 + Pw;
x2 := x2 - Pw;
y1 := y1 + Ph;
y2 := y2 - Ph;
R := FromR + MulDiv(i, DiffR, 155); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 155);
B := FromB + MulDiv(i, DiffB, 155);
bm.canvas.Brush.Color := R or (G shl 8) or (B shl 16);
//Plug colors into brush
bm.canvas.Ellipse(Trunc(x1), Trunc(y1), Trunc(x2),
Trunc(y2));
end;
end;

rgsRectangle: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
x1 := 0;
x2 := bm.Width + 2;
y1 := 0;
y2 := bm.Height + 2;
Pw := (bm.Width / 2) / 255;
Ph := (bm.Height / 2) / 255;
for i := 0 to 255 do begin //Make rectangles of color
x1 := x1 + Pw;
x2 := x2 - Pw;
y1 := y1 + Ph;
y2 := y2 - Ph;
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);
bm.canvas.Brush.Color := RGB(R, G, B);
//Plug colors into brush
bm.canvas.FillRect(rect(Trunc(x1), Trunc(y1), Trunc(x2),
Trunc(y2)));
end;
end;

rgsVerticalCenter: begin
haf := bm.Height div 2;
ColorRect.left := 0;
ColorRect.right := bm.Width;
for i := 0 to haf do begin
ColorRect.top := MulDiv(i, haf, haf);
ColorRect.bottom := MulDiv(i + 1, haf, haf);
R := FromR + MulDiv(i, DiffR, haf);
G := FromG + MulDiv(i, DiffG, haf);
B := FromB + MulDiv(i, DiffB, haf);
bm.canvas.Brush.Color := RGB(R, G, B);
bm.canvas.FillRect(ColorRect);
ColorRect.top := bm.Height - (MulDiv(i, haf, haf));
ColorRect.bottom := bm.Height - (MulDiv(i + 1, haf, haf));
bm.canvas.FillRect(ColorRect);
end;

end;
rgsHorizontalCenter: begin
haf := bm.Width div 2;
ColorRect.top := 0;
ColorRect.bottom := bm.Height;
for i := 0 to haf do begin
ColorRect.left := MulDiv(i, haf, haf);
ColorRect.right := MulDiv(i + 1, haf, haf);
R := FromR + MulDiv(i, DiffR, haf);
G := FromG + MulDiv(i, DiffG, haf);
B := FromB + MulDiv(i, DiffB, haf);
bm.canvas.Brush.Color := RGB(R, G, B);
bm.canvas.FillRect(ColorRect);
ColorRect.left := bm.Width - (MulDiv(i, haf, haf));
ColorRect.right := bm.Width - (MulDiv(i + 1, haf, haf));
bm.canvas.FillRect(ColorRect);
end;
end;
rgsNWSE: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
Pw := (bm.Width + bm.Height) / 255;
for i := 0 to 254 do begin //Make trapeziums of color
x0 := i * Pw;
if (x0 < bm.Width) then
y0 := 0
else begin
y0 := x0 - bm.Width;
x0 := bm.Width - 1;
end;
x1 := (i + 1) * Pw;
if (x1 < bm.Width) then begin
y1 := 0;
end
else begin
y1 := x1 - bm.Width;
x1 := bm.Width - 1;
end;
y2 := i * Pw;
if (y2 < bm.Height) then
x2 := 0
else begin
x2 := y2 - bm.Height;
y2 := bm.Height - 1;
end;
y3 := (i + 1) * Pw;
if (y3 < bm.Height) then
x3 := 0
else begin
x3 := y3 - bm.Height;
y3 := bm.Height - 1;
end;
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);
bm.canvas.Brush.Color := RGB(R, G, B);
//Plug colors into brush
points[0] := point(Trunc(x0), Trunc(y0));
points[1] := point(Trunc(x1), Trunc(y1));
points[3] := point(Trunc(x2), Trunc(y2));
points[2] := point(Trunc(x3), Trunc(y3));
bm.canvas.polygon(points);
end;
end;

rgsNWSW: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
Pw := (bm.Width + bm.Height) / 255;
for i := 0 to 254 do begin //Make trapeziums of color
y0 := i * Pw;
if (y0 < bm.Height) then
x0 := bm.Width - 1
else begin
x0 := bm.Width - 1 - (y0 - bm.Height);
y0 := bm.Height - 1;
end;
y1 := (i + 1) * Pw;
if (y1 < bm.Height) then
x1 := bm.Width - 1
else begin
x1 := bm.Width - 1;
end;
x2 := bm.Width - 1 - (i * Pw);
if (x2 > 0) then
y2 := 0
else begin
y2 := -x2;
x2 := 0;
end;
x3 := bm.Width - 1 - ((i + 1) * Pw);
if (x3 > 0) then
y3 := 0
else begin
y3 := -x3;
x3 := 0;
end;
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);
bm.canvas.Brush.Color := RGB(R, G, B);
//Plug colors into brush
points[0] := point(Trunc(x0), Trunc(y0));
points[1] := point(Trunc(x1), Trunc(y1));
points[3] := point(Trunc(x2), Trunc(y2));
points[2] := point(Trunc(x3), Trunc(y3));
bm.canvas.polygon(points);
end;
end;

rgsSENW: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
Pw := (bm.Width + bm.Height) / 255;
for i := 0 to 254 do begin //Make trapeziums of color
y0 := bm.Height - 1 - (i * Pw);
if (y0 > 0) then
x0 := bm.Width - 1
else begin
x0 := bm.Width - 1 + y0;
y0 := 0;
end;
y1 := bm.Height - 1 - ((i + 1) * Pw);
if (y1 > 0) then
x1 := bm.Width - 1
else begin
x1 := bm.Width - 1 + y1;
y1 := 0;
end;
x2 := bm.Width - 1 - (i * Pw);
if (x2 > 0) then
y2 := bm.Height - 1
else begin
y2 := bm.Height - 1 + x2;
x2 := 0;
end;
x3 := bm.Width - 1 - ((i + 1) * Pw);
if (x3 > 0) then
y3 := bm.Height - 1
else begin
y3 := bm.Height - 1 + x3;
x3 := 0;
end;
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);
bm.canvas.Brush.Color := RGB(R, G, B);
//Plug colors into brush
points[0] := point(Trunc(x0), Trunc(y0));
points[1] := point(Trunc(x1), Trunc(y1));
points[3] := point(Trunc(x2), Trunc(y2));
points[2] := point(Trunc(x3), Trunc(y3));
bm.canvas.polygon(points);
end;
end;

rgsSWNE: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
Pw := (bm.Width + bm.Height) / 255;
for i := 0 to 254 do begin //Make trapeziums of color
y0 := bm.Height - 1 - (i * Pw);
if (y0 > 0) then
x0 := 0
else begin
x0 := -y0;
y0 := 0;
end;
y1 := bm.Height - 1 - ((i + 1) * Pw);
if (y1 > 0) then
x1 := 0
else begin
x1 := -y1;
y1 := 0;
end;
x2 := (i * Pw);
if (x2 < bm.Width) then
y2 := bm.Height - 1
else begin
y2 := bm.Height - 1 - (x2 - bm.Width);
x2 := bm.Width - 1;
end;
x3 := (i + 1) * Pw;
if (x3 < bm.Width) then
y3 := bm.Height - 1
else begin
y3 := bm.Height - 1 - (x3 - bm.Width);
x3 := bm.Width - 1;
end;
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);
bm.canvas.Brush.Color := RGB(R, G, B);
//Plug colors into brush
points[0] := point(Trunc(x0), Trunc(y0));
points[1] := point(Trunc(x1), Trunc(y1));
points[3] := point(Trunc(x2), Trunc(y2));
points[2] := point(Trunc(x3), Trunc(y3));
bm.canvas.polygon(points);
end;
end;

rgsSweet: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
for i := 0 to 255 do begin
x1 := MulDiv(i, bm.Width, 255);
x2 := MulDiv(i + 1, bm.Width, 255);
y1 := MulDiv(i, bm.Height, 255);
y2 := MulDiv(i + 1, bm.Height, 255);

R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);

bm.canvas.Brush.Color := RGB(R, G, B);

points[0] := point(bm.Width div 2, bm.Height div 2);
points[1] := point(0, Trunc(y1));
points[2] := point(0, Trunc(y2));
points[3] := points[2];
bm.canvas.polygon(points);

points[0] := point(bm.Width div 2, bm.Height div 2);
points[1] := point(bm.Width, bm.Height - Trunc(y1));
points[2] := point(bm.Width, bm.Height - Trunc(y2));
points[3] := points[2];
bm.canvas.polygon(points);

points[0] := point(bm.Width div 2, bm.Height div 2);
points[1] := point(Trunc(x1), 0);
points[2] := point(Trunc(x2), 0);
points[3] := points[2];
bm.canvas.polygon(points);

points[0] := point(bm.Width div 2, bm.Height div 2);
points[1] := point(bm.Width - Trunc(x1), bm.Height);
points[2] := point(bm.Width - Trunc(x2), bm.Height);
points[3] := points[2];
bm.canvas.polygon(points);
end;
end;

rgsStrange: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
for i := 0 to 255 do begin
x1 := MulDiv(i, bm.Width, 255);
y1 := MulDiv(i, bm.Height, 255);

R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);

bm.canvas.Brush.Color := RGB(R, G, B);

points[0] := point(Trunc(x1), Trunc(y1));
points[1] := point(0, bm.Height - Trunc(y1));
points[2] := point(bm.Width, bm.Height);
points[3] := point(bm.Width, 0);
bm.canvas.polygon(points);
end;
end;

rgsNero: begin
bm.canvas.Pen.Style := psClear;
bm.canvas.Pen.Mode := pmCopy;
for i := 0 to 255 do begin
x1 := MulDiv(i, bm.Width div 2, 255);
y1 := MulDiv(i, bm.Height div 2, 255);

R := FromR + MulDiv(i, DiffR, 255); //Find the RGB values
G := FromG + MulDiv(i, DiffG, 255);
B := FromB + MulDiv(i, DiffB, 255);

bm.canvas.Brush.Color := RGB(R, G, B);

points[0] := point(Trunc(x1), Trunc(y1));
points[1] := point(0, bm.Height);
points[2] := point(bm.Width - Trunc(x1), bm.Height -
Trunc(y1));
points[3] := point(bm.Width, 0);
bm.canvas.polygon(points);
end;

end;
end;
bitblt(canvas.Handle, 0, 0, bm.Width, bm.Height, bm.canvas.Handle, 0, 0,
srccopy);
bm.Free;
end;

procedure GraySharpLine(SBmp, DBmp: tBitmap);
var
p: PRGBTripleArray;
x, y, ScanlineBytes: integer;
//扫描线之间得间距
Gray: Byte;
begin
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
//位图加载
p := DBmp.ScanLine[0];
//这里是scanline的优化算法 ，scanline只需执行2次
ScanlineBytes := integer(DBmp.ScanLine[1]) - integer(p);
//ScanlineBytes是一个负值
for y := 0 to DBmp.Height - 1 do begin
//注意防止边界溢出
for x := 0 to DBmp.Width - 1 do begin
Gray := Byte((p[x].rgbtRed * 55 + p[x].rgbtGreen * 151
+ p[x].rgbtBlue * 28) shr 8);
//求出灰度信息
if Gray < 80 then begin
Gray := Gray div 2 + 20;
//这里自定义线性变化
end
else if (Gray < 160) and (Gray > 80) then begin
Gray := Gray + 30;
//不同的灰度分布进行不同的调整
end
else begin
Gray := Gray - 30;
end;
p[x].rgbtRed := Gray;
//红色分量得赋值
p[x].rgbtGreen := Gray;
//绿色分量得赋值
p[x].rgbtBlue := Gray;
//蓝色分量得赋值
end;
inc(integer(p), ScanlineBytes);
//其实是减小操作
end;
end;

procedure GraySharpNotLine(SBmp, DBmp: tBitmap);
var
p: PRGBTripleArray;
//定义一个pRGBTripleArray类型
x, y, ScanlineBytes: integer;
//扫描线间距
BMP: tBitmap;
//位图对像
Gray: integer;
//灰度
begin
SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
//加载位图
p := DBmp.ScanLine[0];
//这里是scanline的优化算法 ，scanline只需执行2次
ScanlineBytes := integer(DBmp.ScanLine[1]) - integer(p);
//ScanlineBytes是一个负值
for y := 0 to DBmp.Height - 1 do begin
//注意边界
for x := 0 to DBmp.Width - 1 do begin
Gray := ((p[x].rgbtRed * 55 + p[x].rgbtGreen * 151
+ p[x].rgbtBlue * 28) shr 8);
//避免浮点数运算
if Gray < 80 then begin
Gray := Round(log10(power(8, Gray)));
end
//指数，对数混合运算
else if (Gray < 160) and (Gray > 80) then begin
Gray := Round(log10(power(8, Gray))) + 20;
//自定义的混合运算
end
else begin
Gray := Round(log10(power(8, Gray))) - 10;
end;
p[x].rgbtRed := Gray;
//红色分量得赋值
p[x].rgbtGreen := Gray;
//绿色分量得赋值
p[x].rgbtBlue := Gray;
//蓝色分量得赋值
end;
inc(integer(p), ScanlineBytes);
//其实是减小操作
end;
end;

procedure GrayStrech(SBmp, DBmp: tBitmap);

procedure GetParam(SBmp: tBitmap);
var
p: pByteArray;
// PbyteArray类型
x, y, i, j: integer;
BMP: tBitmap;
Gray: Byte;
ScanlineBytes: integer;
//扫描线间距
begin
BMP := tBitmap.Create;
//创建实例
BMP.Assign(SBmp);
BMP.PixelFormat := pf24Bit;
//24bit位图
p := BMP.ScanLine[0];
//首行扫描线信息
for i := 0 to 255 do begin
Grayclass[i] := 0;
//初始化数组为0
end;
ScanlineBytes := integer(BMP.ScanLine[1]) - integer(BMP.ScanLine[0]);
for y := 0 to BMP.Height - 1 do begin
//注意边界,不能越界
for x := 0 to BMP.Width - 1 do begin
Gray := Round(p[x * 3 + 2] * 0.3 + p[x * 3 + 1] * 0.59 + p[x
* 3]
* 0.11);
//求取灰度值
for i := 0 to 255 do begin
if Gray = i then begin
Grayclass[i] := Grayclass[i] + 1;
//每级灰度象素点数
end;
end;
end;
inc(integer(p), ScanlineBytes);
//指针增加,增加得其实是一个负值
end;
BMP.Free;
//释放资源
for i := 0 to 255 do begin
if Grayclass[i] <> 0 then begin
OriginalRangeLeft := i;
break;
//获取最大灰度级
end;
end;
for j := 255 downto 0 do begin
if Grayclass[j] <> 0 then begin
OriginalRangeRight := j;
break;
//获取最小灰度级
end;
end;
end;

var
p: pByteArray;
x, y: integer;
BMP: tBitmap;
Gray: Byte;
ScanlineBytes: integer;
ScaleFactor: Real;
begin
GetParam(SBmp);

SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
p := DBmp.ScanLine[0];
ScaleFactor := 255 / (OriginalRangeRight - OriginalRangeLeft);
//拉伸比例
ScanlineBytes := integer(DBmp.ScanLine[1]) - integer(DBmp.ScanLine[0]);
//扫描线间距
for y := 0 to DBmp.Height - 1 do begin
for x := 0 to DBmp.Width - 1 do begin
Gray := Round(p[x * 3 + 2] * 0.3 + p[x * 3 + 1] * 0.59 + p[x
* 3] * 0.11);
Gray := Round(ScaleFactor * (Gray - OriginalRangeLeft));
//进行灰度拉伸
p[x * 3 + 2] := Gray;
p[x * 3 + 1] := Gray;
p[x * 3] := Gray;
//重新赋值
end;
inc(integer(p), ScanlineBytes);
end;
end;

procedure SetSharp(SBmp, DBmp: tBitmap); //图像锐化
var
bmp1: tBitmap;
p1, p2, p3, p4: pByteArray;
//定义四个pbytearray类型变量
i, j, z: integer;
y: array[0..8] of integer;
begin
y[0] := 0; y[1] := -1; y[2] := 0;
y[3] := -1; y[4] := 5; y[5] := -1;
y[6] := 0; y[5] := -1; y[8] := 0;
//卷积矩阵
z := 1;
//卷积核

SBmp.PixelFormat := pf24Bit;
DBmp.Assign(SBmp);
bmp1 := tBitmap.Create;
bmp1.Assign(SBmp);

//24为格式便于处理
for j := 1 to DBmp.Height - 2 do begin
p1 := DBmp.ScanLine[j];
//第一条扫描线
p2 := bmp1.ScanLine[j - 1];
//第二条扫描线，为了防止数据变化，在备用位图上操作
p3 := bmp1.ScanLine[j];
p4 := bmp1.ScanLine[j + 1];
//第三条扫描线
//三条相邻的扫描线
for i := 1 to DBmp.Width - 2 do begin
//进行卷积操作获取新的象素值
p1[3 * i + 2] := Min(255, Max(0, ((y[0] * p2[3 * (i - 1) + 2]
+ y[1] * p2[3 * i + 2] + y[2] * p2[3 * (i + 1) + 2] + y[3]
* p3[3 * (i - 1) + 2] + y[4] * p3[3 * i + 2] + y[5]
* p3[3 * (i + 1) + 2] + y[6]
* p4[3
* (i - 1) + 2] + y[5] * p4[3 * i + 2] + y[8] * p4[3 * (i
+
1) + 2]))
div
z));
//重新算出红色分量
p1[3 * i + 1] := Min(255, Max(0, ((y[0] * p2[3 * (i - 1) + 1]
+
y[1] * p2[3 * i + 1] + y[2] * p2[3 * (i + 1) + 1] + y[3]
* p3[3
* (i - 1)
+ 1] + y[4] * p3[3 * i + 1] + y[5] * p3[3 * (i + 1) +
1] +
y[6]
* p4[3
* (i - 1) + 1] + y[5] * p4[3 * i + 1] + y[8] * p4[3 * (i
+
1) + 1]))
div
z));
//重新算出蓝色分量
p1[3 * i] := Min(255, Max(0, ((y[0] * p2[3 * (i - 1)] + y[1]
*
p2[3 * i] + y[2] * p2[3 * (i + 1)] + y[3] * p3[3 * (i -
1)] +
y[4] * p3[3
* i] + y[5] * p3[3 * (i + 1)] + y[6] * p4[3 * (i - 1)] +
y[5]
* p4[3 * i]
+ y[8] * p4[3 * (i + 1)])) div z));
//重新算出绿色分量
end;
end;
bmp1.Free;
end;

procedure SetSmooth(SBmp, DBmp: tBitmap); //图像平滑
var
bmp1: tBitmap;
p1, p2, p3, p4: pByteArray;
i, j, z: integer;
y: array[0..8] of integer;
begin
y[0] := 1;
y[1] := 2;
y[2] := 1;
y[3] := 2;
y[4] := 4;
y[5] := 2;
y[6] := 1;
y[7] := 2;
y[8] := 1;
z := 16;

bmp1 := tBitmap.Create;
DBmp.Assign(SBmp);
DBmp.PixelFormat := pf24Bit;
DBmp.Width := SBmp.Width;
DBmp.Height := SBmp.Height;
bmp1.Assign(DBmp);
bmp1.PixelFormat := pf24Bit;
for j := 1 to DBmp.Height - 2 do begin
p1 := DBmp.ScanLine[j];
p2 := bmp1.ScanLine[j - 1];
p3 := bmp1.ScanLine[j];
p4 := bmp1.ScanLine[j + 1];
for i := 1 to DBmp.Width - 2 do begin
p1[3 * i + 2] := Min(255, Max(0, ((y[0] * p2[3 * (i - 1) + 2]
+ y[1] * p2[3 * i + 2] + y[2] * p2[3 * (i + 1) + 2] + y[3]
* p3[3 * (i - 1) + 2] + y[4] * p3[3 * i + 2] + y[5] * p3[3 * (i + 1) +
2] +
y[6]
* p4[3
* (i - 1) + 2] + y[7] * p4[3 * i + 2] + y[8] * p4[3 * (i
+
1) + 2]))
div
z));
p1[3 * i + 1] := Min(255, Max(0, ((y[0] * p2[3 * (i - 1) + 1]
+
y[1] * p2[3 * i + 1] + y[2] * p2[3 * (i + 1) + 1] + y[3]
* p3[3
* (i - 1)
+ 1] + y[4] * p3[3 * i + 1] + y[5] * p3[3 * (i + 1) +
1] +
y[6]
* p4[3
* (i - 1) + 1] + y[7] * p4[3 * i + 1] + y[8] * p4[3 * (i
+
1) + 1]))
div
z));
p1[3 * i] := Min(255, Max(0, ((y[0] * p2[3 * (i - 1)] + y[1]
*
p2[3 * i] + y[2] * p2[3 * (i + 1)] + y[3] * p3[3 * (i -
1)] +
y[4] * p3[3
* i] + y[5] * p3[3 * (i + 1)] + y[6] * p4[3 * (i - 1)] +
y[7]
* p4[3 * i]
+ y[8] * p4[3 * (i + 1)])) div z));
end;
end;
bmp1.Free;
end;

procedure FakeColorSharp(SBmp, DBmp: tBitmap); //伪彩色增强
var
BMP: tBitmap;
//位图对象
Gray, maxgray: integer;
i, j: integer;
p1, p2: pByteArray;
img: array of array of integer;
const
ColorTable: array[0..15] of integer = ($00000000, $00550000, $00005500,
$00000055, $003F3F3F, $00550055, $00FF0000, $00005555, $0000FF00, $000000FF,
$00808080, $00FFFF00, $0000FFFF, $00FFFFFF, $00555500, $00FF00FF);
//16种颜色得颜色对照表
begin
//创建位图实例
DBmp.Assign(SBmp);
DBmp.PixelFormat := pf24Bit;
//设为24位
SetLength(img, DBmp.Height, DBmp.Width);
//设置动二维态数组得维数
for i := 0 to DBmp.Height - 1 do begin
p1 := DBmp.ScanLine[i];
//每一行扫描线
for j := 0 to DBmp.Width - 1 do begin
//算出该象素的灰度
img[i][j] := Round(0.3 * p1[3 * j + 2] + 0.59 *
p1[3 * j + 1] + 0.11 * p1[3 * j]);
end;
end;
maxgray := img[0][0];
//初始化maxGray
for i := 0 to High(img) do begin
for j := 0 to High(img[0]) do begin
if maxgray < img[i][j] then begin
maxgray := img[i][j];
//算出最大灰度值
end;
end;
end;
//转为16级灰度
for i := 0 to DBmp.Height - 1 do begin
p2 := DBmp.ScanLine[i];
for j := 0 to DBmp.Width - 1 do begin
Gray := 16 * img[i][j] div maxgray;
//灰度级的转化
p2[3 * j + 2] := GetRValue(ColorTable[Gray]);
p2[3 * j + 1] := GetGValue(ColorTable[Gray]);
p2[3 * j] := GetBValue(ColorTable[Gray]);
//对象素点重新进行赋值
end;
end;
end;

procedure MidFilter(SBmp, DBmp: tBitmap); //中值滤波
var
bmp1: tBitmap;
p1, p2, p3, p4: pByteArray;
i, j: integer;
RvalueArray, GvalueArray, BvalueArray: array[0..8] of integer;
begin
//创建两个位图实例
bmp1 := tBitmap.Create;
//加在位图
DBmp.Assign(SBmp);
//设置位图的象素格式
DBmp.PixelFormat := pf24Bit;
//位图的大小
DBmp.Width := SBmp.Width;
DBmp.Height := SBmp.Height;
//加载备份的位图
bmp1.Assign(SBmp);
bmp1.PixelFormat := pf24Bit;
for j := 1 to DBmp.Height - 2 do begin
//三条扫描线
p1 := DBmp.ScanLine[j];
p2 := bmp1.ScanLine[j - 1];
p3 := bmp1.ScanLine[j];
p4 := bmp1.ScanLine[j + 1];
for i := 1 to DBmp.Width - 2 do begin
//对存储9个R分量的数组进行赋值
RvalueArray[0] := p2[3 * (i - 1) + 2];
RvalueArray[1] := p2[3 * i + 2];
RvalueArray[2] := p2[3 * (i + 1) + 2];
RvalueArray[3] := p3[3 * (i - 1) + 2];
RvalueArray[4] := p3[3 * i + 2];
RvalueArray[5] := p3[3 * (i + 1) + 2];
RvalueArray[6] := p4[3 * (i - 1) + 2];
RvalueArray[7] := p4[3 * i + 2];
RvalueArray[8] := p4[3 * (i + 1) + 2];
//调用排序过程
SelectionSort(RvalueArray);
//获取R分量的中间值
p1[3 * i + 2] := RvalueArray[4];
//对存储9个G分量的数组进行赋值
GvalueArray[0] := p2[3 * (i - 1) + 1];
GvalueArray[1] := p2[3 * i + 1];
GvalueArray[2] := p2[3 * (i + 1) + 1];
GvalueArray[3] := p3[3 * (i - 1) + 1];
GvalueArray[4] := p3[3 * i + 1];
GvalueArray[5] := p3[3 * (i + 1) + 1];
GvalueArray[6] := p4[3 * (i - 1) + 1];
GvalueArray[7] := p4[3 * i + 1];
GvalueArray[8] := p4[3 * (i + 1) + 1];
//调用选择排序
SelectionSort(RvalueArray);
//获取G分量的中间值
p1[3 * i + 1] := RvalueArray[4];
//对存储9个B分量的数组进行赋值
BvalueArray[0] := p2[3 * (i - 1)];
BvalueArray[1] := p2[3 * i];
BvalueArray[2] := p2[3 * (i + 1)];
BvalueArray[3] := p3[3 * (i - 1)];
BvalueArray[4] := p3[3 * i];
BvalueArray[5] := p3[3 * (i + 1)];
BvalueArray[6] := p4[3 * (i - 1)];
BvalueArray[7] := p4[3 * i];
BvalueArray[8] := p4[3 * (i + 1)];
//调用选择排序过程
SelectionSort(RvalueArray);
//获取G分量的中间值
p1[3 * i] := RvalueArray[4];
end;
end;
bmp1.Free;
end;

procedure PictureTwoValue(SBmp, DBmp: tBitmap); //二值化
var
x, y: integer;
p: pByteArray;
Gray: Byte;
begin
DBmp.PixelFormat := SBmp.PixelFormat;
DBmp.Assign(SBmp);
for y := 0 to SBmp.Height - 1 do begin
p := DBmp.ScanLine[y];
for x := 0 to SBmp.Width - 1 do begin
Gray := Round(0.299 * p[3 * x + 2] + 0.587 * p[3 * x + 1] + 0.11
* p[3 * x]);
// 灰化的计算公式
if (Gray > 128) then
Gray := 255
else
Gray := 0;
// 128为阙值
p[3 * x + 2] := Gray;
p[3 * x + 1] := Gray;
p[3 * x] := Gray;
end;
end;
end;

function BitmapErose(SBmp, DBmp: tBitmap; Horic: Boolean): Boolean; //腐蚀
var
x, y: integer;
p, q, R, O: pByteArray;
begin
//动态创建位图
DBmp.Assign(SBmp);
// Horic标志是水平方向还是竖直方向腐蚀
if (Horic) then begin
for y := 1 to DBmp.Height - 2 do begin
O := SBmp.ScanLine[y];
p := DBmp.ScanLine[y - 1];
q := DBmp.ScanLine[y];
R := DBmp.ScanLine[y + 1];
for x := 1 to DBmp.Width - 2 do begin
if ((O[3 * x] = 0) and (O[3 * x + 1] = 0) and (O[3 * x + 2]
= 0)) then begin
// 判断黑点左右邻居是否有白色点,有则腐蚀,置该点为白色
// 白色点则保持不变
if (((q[3 * (x - 1)] = 255) and (q[3 * (x - 1) + 1] =
255) and (q[3 * (x - 1) + 2] = 255)) or ((q[3 * (x
+
1)] = 255) and (q[3 * (x + 1) + 1] = 255) and
(q[3 * (x + 1) + 2] = 255)) or ((p[3 * x] = 0) and
(p[3 * x + 1] = 255) and (p[3 * x + 2] = 255))
or ((R[3 * x] = 255) and (R[3 * x + 1] = 255) and
(R[3
* x + 2] = 255))) then begin
O[3 * x] := 255;
O[3 * x + 1] := 255;
O[3 * x + 2] := 255;
//// 将满足条件的黑色点置为白色
end;
end;
end;
end;
end
else begin
for y := 1 to DBmp.Height - 2 do begin
O := SBmp.ScanLine[y];
// P := newbmp.ScanLine[Y - 1];
q := DBmp.ScanLine[y];
// R := newbmp.ScanLine[Y + 1];
for x := 1 to DBmp.Width - 2 do begin
// 判断一个黑点上下邻居是否有白点,有则腐蚀,置黑点为白色
// 白色点就保持不变
if ((O[3 * x] = 0) and (O[3 * x + 1] = 0) and (O[3 * x + 2]
= 0)) then begin
if (((q[3 * (x - 1)] = 255) and (q[3 * (x - 1) + 1] =
255) and (q[3 * (x - 1) + 2] = 255)) or ((q[3 * (x
+
1)] = 255) and (q[3 * (x + 1) + 1] = 255) and
(q[3 * (x + 1) + 2] = 255))) then begin
O[3 * x] := 255;
O[3 * x + 1] := 255;
O[3 * x + 2] := 255;
// 将满足条件的黑色点置为白色
end;
end;
end;
end;
end;
Result := True;
end;

function BitmapDilate(SBmp,DBmp: TBitmap; Hori: Boolean): Boolean;
var
X, Y: integer;
O, P, Q, R: pByteArray;
newbmp: TBitmap;
begin
DBmp.Assign(SBmp);
Hori := True;
if (Hori) then
begin
for Y := 1 to DBmp.Height - 2 do
begin
O := SBmp.ScanLine[Y];
P := DBmp.ScanLine[Y - 1];
Q := DBmp.ScanLine[Y];
R := DBmp.ScanLine[Y + 1];
for X := 1 to DBmp.Width - 2 do
begin
if ((O[3 * X] = 255) and (O[3 * X + 1] = 255) and (O[3 * X
+ 2] = 255)) then
begin
if (((Q[3 * (X - 1)] = 0) and (Q[3 * (X - 1) + 1] = 0)
and (Q[3 * (X - 1) + 2] = 0)) or ((Q[3 * (X + 1)]= 0)
and (Q[3 * (X + 1) + 1] = 0) and
(Q[3 * (X + 1) + 2] = 0)) or ((P[3 * X] = 0) and
(P[3 * X + 1] = 0) and (P[3 * X + 2] = 0))
or ((R[3 * X] = 0) and (R[3 * X + 1] = 0) and
(R[3 * X + 2] = 0))) then
begin
O[3 * X] := 0;
O[3 * X + 1] := 0;
O[3 * X + 2] := 0;
end;

end;
end;
end;
end
else
for Y := 1 to DBmp.Height - 2 do
begin
O := SBmp.ScanLine[Y];
Q := DBmp.ScanLine[Y];
for X := 1 to DBmp.Width - 2 do
begin
if ((O[3 * X] = 255) and (O[3 * X + 1] = 255) and (O[3 * X
+ 2] = 255)) then
begin
if (((Q[3 * (X - 1)] = 0) and (Q[3 * (X - 1) + 1] = 0)
and (Q[3 * (X - 1) + 2] = 0)) or ((Q[3 * (X + 1)]= 0)
and (Q[3 * (X + 1) + 1] = 0) and
(Q[3 * (X + 1) + 2] = 0))) then
O[3 * X] := 0;
O[3 * X + 1] := 0;
O[3 * X + 2] := 0;
end;
end;
end;
result := True;
end;

procedure GetLunkuo(SBmp,DBmp: TBitmap); //轮廓提取
var
b0: Tbitmap;
i, j: Integer;
p1, p2, p3, p4: pbyteArray;
begin
b0:= Tbitmap.Create;
b0.Assign(SBmp);
DBmp.Assign(SBmp);
DBmp.PixelFormat := pf24bit;
b0.PixelFormat := pf24bit;
for i := 1 to b0.Height - 2 do
begin
p1 := b0.ScanLine[i - 1];
p2 := b0.ScanLine[i];
p3 := b0.ScanLine[i + 1];
p4 := DBmp.ScanLine[i];
for j := 1 to b0.Width - 2 do
begin
if (p2[3 * j + 2] = 0) and (p2[3 * j + 1] = 0) and (p2[3 * j] = 0) then
begin
if ((p2[3 * (j - 1) + 2] = 0) and (p2[3 * (j - 1) + 1] = 0) and
(p2[3 * (j - 1)] = 0)) and
((p2[3 * (j + 1) + 2] = 0) and (p2[3 * (j + 1) + 1] = 0) and
(p2[3 * (j + 1)] = 0)) and
((p1[3 * (j + 1) + 2] = 0) and (p1[3 * (j + 1) + 1] = 0) and
(p1[3 * (j + 1)] = 0)) and
((p1[3 * (j) + 2] = 0) and (p1[3 * (j) + 1] = 0) and (p1[3 * (j)]
= 0)) and
((p1[3 * (j - 1) + 2] = 0) and (p1[3 * (j - 1) + 1] = 0) and
(p1[3 * (j - 1)] = 0)) and
((p3[3 * (j - 1) + 2] = 0) and (p3[3 * (j - 1) + 1] = 0) and
(p3[3 * (j - 1)] = 0)) and
((p3[3 * (j) + 2] = 0) and (p3[3 * (j) + 1] = 0) and (p3[3 * (j)]
= 0)) and
((p3[3 * (j + 1) + 2] = 0) and (p3[3 * (j + 1) + 1] = 0) and
(p3[3 * (j + 1)] = 0)) then
begin
p4[3 * j + 2] := 255;
p4[3 * j + 1] := 255;
p4[3 * j] := 255;
end;
end;
end;
end;
b0.Free;
end;

function Xihua(SBmp,DBmp: TBitmap): Boolean; //细化
var
X, Y: integer;
O, T, C, B: pRGBArray;
nb: array[1..3, 1..3] of integer;
c1, c2, c3, c4: boolean;
ncount: integer;
begin
// Create bmp
DBmp.Assign(SBmp);
// 获取bitmap 赋给bmp
for Y := 1 to DBmp.Height - 2 do
begin
O := DBmp.ScanLine[Y];
T := SBmp.ScanLine[Y - 1];
C := SBmp.ScanLine[Y];
B := SBmp.ScanLine[Y + 1];
for X := 1 to DBmp.Width - 2 do
begin
c1 := false;
c2 := false;
c3 := false;
c4 := false;
// 设立四个条件的初始值
nb[1, 1] := T[X - 1].rgbtRed div 255;
nb[1, 2] := T[X].rgbtRed div 255;
nb[1, 3] := T[X + 1].rgbtRed div 255;
nb[2, 1] := C[X - 1].rgbtRed div 255;
nb[2, 2] := C[X].rgbtRed div 255;
nb[2, 3] := C[X + 1].rgbtRed div 255;
nb[3, 1] := B[X - 1].rgbtRed div 255;
nb[3, 2] := B[X].rgbtRed div 255;
nb[3, 3] := B[X + 1].rgbtRed div 255;
//将[x,y]周围的八个象素点和它自己0-1化
nCount := nb[1, 1] + nb[1, 2] + nb[1, 3]
+ nb[2, 1] + nb[2, 3]
+ nb[3, 1] + nb[3, 2] + nb[3, 3];
// 获得ncount的值
if (ncount >= 2) and (ncount <= 6) then
c1 := True;
//condition1
ncount := 0;
if (nb[1, 1] = 0) and (nb[1, 2] = 1) then
inc(ncount);
if (nb[1, 2] = 0) and (nb[1, 3] = 1) then
inc(ncount);
if (nb[1, 3] = 0) and (nb[2, 3] = 1) then
inc(ncount);
if (nb[2, 3] = 0) and (nb[3, 3] = 1) then
inc(ncount);
if (nb[3, 3] = 0) and (nb[3, 2] = 1) then
inc(ncount);
if (nb[3, 2] = 0) and (nb[3, 1] = 1) then
inc(ncount);
if (nb[3, 1] = 0) and (nb[2, 1] = 1) then
inc(ncount);
if (nb[2, 1] = 0) and (nb[1, 1] = 1) then
inc(ncount);
if ncount = 1 then
c2 := true;
//condition2
if (nb[1, 2] * nb[3, 2] * nb[2, 3] = 0) then
c3 := true;
// condition3
if (nb[2, 1] * nb[2, 3] * nb[3, 2] = 0) then
c4 := true;
//condition4
if (c1 and c2 and c3 and c4) then
begin
O[X].rgbtRed := 255;
O[X].rgbtGreen := 255;
O[X].rgbtBlue := 255;
//设置O[X]为白色
end;
end;
end;
//释放bmp
Result := True;
// 返回值为boolean,True表示细化成功
end;

procedure SetSobel(SBmp,DBmp: TBitmap); //边沿检测
var
bmp1: Tbitmap;
// 临时位图
p1, p3, p2, p4: pByteArray;
i, j: integer;
r, g, b: Byte;
begin

//采用双缓冲模式
bmp1 :=TBitmap.Create;
//Create bmp1,bmp2
DBmp.Assign(SBmp);
DBmp.PixelFormat := pf24bit;
//设置位图格式
bmp1.Assign(DBmp);
bmp1.PixelFormat := pf24bit;
for j := 1 to DBmp.Height - 2 do
begin
p1 := DBmp.ScanLine[j];
p2 := bmp1.ScanLine[j - 1];
p3 := bmp1.ScanLine[j];
p4 := bmp1.ScanLine[j + 1];
for i := 1 to DBmp.Width - 2 do
begin
r := min(255, max(0, ((-p2[3 * (i - 1) + 2] - 2 * p2[3 * i +2] -
p2[3 * (i +
1) + 2] - 0 * p3[3 * (i - 1) + 2] + 0 * p3[3 * i + 2]
- 0 *
p3[3 * (i
+ 1)
+ 2] + p4[3 * (i - 1) + 2] + 2 * p4[3 * i + 2] + p4[3 * (i
+ 1)
+
2]))));
g := min(255, max(0, ((-p2[3 * (i - 1) + 1] - 2 * p2[3 * i +
1] -
p2[3 * (i
+
1) + 1] - 0 * p3[3 * (i - 1) + 1] + 0 * p3[3 * i + 1]
- 0 *
p3[3 * (i
+ 1)
+ 1] + p4[3 * (i - 1) + 1] + 2 * p4[3 * i + 1] + p4[3 * (i
+ 1)
+
1]))));
b := min(255, max(0, ((-p2[3 * (i - 1)] - 2 * p2[3 * i] - p2[3
*
(i + 1)]
- 0
* p3[3 * (i - 1)] + 0 * p3[3 * i] - 0 * p3[3 * (i + 1)] +
p4[3
* (i - 1)]
+ 2 * p4[3 * i + 2] + p4[3 * (i + 1)]))));
// 采用检测水平边缘的sobel算子[-1,-2,1,0,0,0,1,2,1]
p1[3 * i + 2] := min(255, max(0, ((-p2[3 * (i - 1) + 2] + 0 *
p2[3
* i + 2]
+
p2[3 * (i + 1) + 2] - 2 * p3[3 * (i - 1) + 2] + 0 * p3[3
* i +
2] + 2 *
p3[3 * (i
+ 1) + 2] - p4[3 * (i - 1) + 2] - 0 * p4[3 * i + 2] +
p4[3
* (i + 1) +
2]))));
p1[3 * i + 1] := min(255, max(0, ((-p2[3 * (i - 1) + 1] + 0 *
p2[3
* i + 1]
+
p2[3 * (i + 1) + 1] - 2 * p3[3 * (i - 1) + 1] + 0 * p3[3
* i +
1] + 2 *
p3[3 * (i
+ 1) + 1] - p4[3 * (i - 1) + 1] - 0 * p4[3 * i + 1] +
p4[3
* (i + 1) +
1]))));
p1[3 * i] := min(255, max(0, ((-p2[3 * (i - 1)] + 0 * p2[3 *
i] +
p2[3 * (i + 1)] - 2 * p3[3 * (i - 1)] + 0 * p3[3 * i] + 2
*
p3[3 * (i
+ 1)] - p4[3 * (i - 1)] - 0 * p4[3 * i] + p4[3 * (i +
1)]))));
//采用检测水平边缘的sobel算子[-1,0,1,-2,0,2,-1,0,1]
p1[3 * i + 2] := (max(r, p1[3 * i + 2]));
p1[3 * i + 1] := (max(g, p1[3 * i + 1]));
p1[3 * i] := (max(b, p1[3 * i]));
end;
end;
bmp1.Free;
end;

procedure SetPrewitte(SBmp,DBmp: TBitmap); //Prewitte边沿检测
var
bmp1: Tbitmap;
p1, p3, p2, p4: pbytearray;
i, j: integer;
r, g, b: integer;
begin
bmp1 := Tbitmap.Create;
DBmp.Assign(SBmp);
DBmp.PixelFormat := pf24bit;
bmp1.Assign(DBmp);
bmp1.PixelFormat := pf24bit;
for j := 1 to bmp1.Height - 2 do
begin
p1 := DBmp.ScanLine[j]; //采用sobal边缘算子 // -1 -1 -1
// 0 0 0
p2 := bmp1.ScanLine[j - 1]; // 1 1 1
p3 := bmp1.ScanLine[j]; //和算子 取较大的输出
p4 := bmp1.ScanLine[j + 1]; //1 0 -1
for i := 1 to DBmp.Width - 2 do {1 0 -1}
begin //1 0 -1
r := min(255, max(0, ((-p2[3 * (i - 1) + 2] - p2[3 * i + 2] -
p2[3* (i +
1) + 2] - 0 * p3[3 * (i - 1) + 2] + 0 * p3[3 * i + 2]
- 0 *
p3[3 * (i
+ 1)
+ 2] + p4[3 * (i - 1) + 2] + p4[3 * i + 2] + p4[3 * (i +
1) +
2]))));
g := min(255, max(0, ((-p2[3 * (i - 1) + 1] - p2[3 * i + 1] -
p2[3
* (i +
1) + 1] - 0 * p3[3 * (i - 1) + 1] + 0 * p3[3 * i + 1]
- 0 *
p3[3 * (i
+ 1)
+ 1] + p4[3 * (i - 1) + 1] + p4[3 * i + 1] + p4[3 * (i +
1) +
1]))));
b := min(255, max(0, ((-p2[3 * (i - 1)] - p2[3 * i] - p2[3 *
(i +
1)] - 0
* p3[3 * (i - 1)] + 0 * p3[3 * i] - 0 * p3[3 * (i + 1)] +p4[3
* (i - 1)]
+ p4[3 * i + 2] + p4[3 * (i + 1)]))));

begin
p1[3 * i + 2] := min(255, max(0, ((p2[3 * (i - 1) + 2] - 0
*
p2[3 * i +
2] - p2[3 * (i + 1) + 2] + p3[3 * (i - 1) + 2] + 0 *
p3[3 *
i + 2] -
p3[3
* (i + 1) + 2] + p4[3 * (i - 1) + 2] + 0 * p4[3 * i +
2] -
p4[3 * (i
+ 1)
+ 2]))));
p1[3 * i + 1] := min(255, max(0, ((p2[3 * (i - 1) + 1] - 0
*
p2[3 * i +
1] - p2[3 * (i + 1) + 1] + p3[3 * (i - 1) + 1] + 0 *
p3[3 *
i + 1] -
p3[3
* (i + 1) + 1] + p4[3 * (i - 1) + 1] + 0 * p4[3 * i +
1] -
p4[3 * (i
+ 1)
+ 1]))));
p1[3 * i] := min(255, max(0, ((p2[3 * (i - 1)] - 0 * p2[3
* i]
- p2[3 *
(i + 1)] + p3[3 * (i - 1)] + 0 * p3[3 * i] - p3[3 * (i
+ 1)]
+ p4[3 *
(i
- 1)] + 0 * p4[3 * i] - p4[3 * (i + 1)]))));
p1[3 * i + 2] := (max(r, p1[3 * i + 2]));
p1[3 * i + 1] := (max(g, p1[3 * i + 1]));
p1[3 * i] := (max(b, p1[3 * i]));
end;

end;
end;
Bmp1.Free;
end;

procedure HorizonProjection(SBmp,DBmp: TBitmap; Horic: Boolean); //竖直投影
var
X, Y, i, j: integer;
P, Q: pByteArray;
number: integer;
begin
// 动态创建TBitmap对象
DBmp.Width := SBmp.Width;
DBmp.Height := SBmp.Height;
//原位图的高度和宽度赋给新的位图
DBmp.Assign(SBmp);
// 拷贝位图到newbmp
if (Horic) then //Horic为真表示进行竖直投影
begin
for Y := 0 to SBmp.Height - 1 do
begin
P := DBmp.ScanLine[Y];
Q := SBmp.ScanLine[Y];
number := 0;
// 设置每一行扫描的初值
for X := 0 to SBmp.Width - 1 do
begin
if ((Q[3 * X + 2] = 255) and (Q[3 * X + 1] = 255) and (Q[3
* X] = 255)) then
number := number + 1;
// 统计每一行的白色点的数目，记录为number
end;
for i := 0 to number do
begin
P[3 * i] := 0;
P[3 * i + 1] := 0;
P[3 * i + 2] := 0;
end;
// 从左边开始,给一行number个像素点涂上黑色
for j := number to SBmp.Width - 1 do
begin
P[3 * j] := 255;
P[3 * j + 1] := 255;
P[3 * j + 2] := 255;
end;
// 其他点涂白色
end;
end;
end;

procedure Convolve(ray: array of integer; z: word; SBmp,DBmp: TBitmap); //Hough变换
var
O, T, C, B: pRGBArray; //scanlines
x, y: integer;
tBufr: TBitmap;
begin
tBufr := TBitmap.Create;
SBmp.PixelFormat :=pf24bit;
DBmp.Assign(SBmp);
// 创建临时位图象
tBufr.Assign(SBmp);
// 拷贝图象
for x := 1 to DBmp.Height - 2 do
begin
O := DBmp.ScanLine[x]; //New Target(Original)
T := tBufr.ScanLine[x - 1]; //Old x-1 (Top)
C := tBufr.ScanLine[x]; //old x (Center)
B := tBufr.ScanLine[x + 1]; //old x+1 (Buttom)
for y := 1 to (DBmp.Width - 2) do //Walk pixels
begin
O[y].rgbtRed := max(0, min(255, ((T[y - 1].rgbtRed * ray[0]) +
(T[y].rgbtRed * ray[1]) +
(T[y + 1].rgbtRed * ray[2]) + (C[y - 1].rgbtRed * ray[3]) +
(C[y].rgbtRed * ray[4]) +
(C[y + 1].rgbtRed * ray[5]) + (B[y - 1].rgbtRed * ray[6]) +
(B[y].rgbtRed * ray[7]) +
(B[y + 1].rgbtRed * ray[8])) div z));
O[y].rgbtBlue := max(0, min(255, ((T[y - 1].rgbtBlue * ray[0]) +
(T[y].rgbtBlue * ray[1]) +
(T[y + 1].rgbtBlue * ray[2]) + (C[y - 1].rgbtBlue * ray[3]) +
(C[y].rgbtBlue * ray[4]) +
(C[y + 1].rgbtBlue * ray[5]) + (B[y - 1].rgbtRed * ray[6]) +
(B[y].rgbtBlue * ray[7]) +
(B[y + 1].rgbtBlue * ray[8])) div z));
O[y].rgbtGreen := max(0, min(255, ((T[y - 1].rgbtGreen * ray[0])
+ (T[y].rgbtGreen * ray[1]) +
(T[y + 1].rgbtGreen * ray[2]) + (C[y - 1].rgbtGreen * ray[3])
+ (C[y].rgbtGreen * ray[4]) +
(C[y + 1].rgbtGreen * ray[5]) + (B[y - 1].rgbtGreen * ray[6])
+ (B[y].rgbtGreen * ray[7]) +
(B[y + 1].rgbtGreen * ray[8])) div z));
end;
end;
tBufr.Free;
// 释放位图
end;

function IsIPText(str:string):Boolean;
var
IdStack: TIdStack;
begin
IdStack := TIdStack.Create;
Result :=IdStack.IsIP(str);
IdStack.Free;
end;

procedure GetLinks(doc:IHTMLDocument2;var tsr:TStringList);
var
all:IHTMLElementCollection;
len,i:integer;
item: OleVariant;
begin
all :=doc.Get_Links;
len := all.length;
for i := 0 to len - 1 do
begin
item := all.item(i, varempty);
tsr.add(item.href);
end;
//调用如下
{var
doc: IHTMLDocument2;
tsr:TStringList;
begin
doc := WebBrowser1.Document as IHTMLDocument2;
tsr :=TStringList.Create;
GetLinks(doc,tsr);
mmo1.Lines.Assign(tsr);
tsr.Free;
end;}
end;

function ConnnectToInternet:Boolean;
begin
//判断是否联网
Result := InternetCheckConnection('http://www.yahoo.com/', 1, 0);
end;

function selectdir: string;
//如果取消取返回为空，否则返回选中的路径
var
Info: TBrowseInfo;
IDList: pItemIDList;
Buffer: PChar;
begin
result := '';
Buffer := StrAlloc(MAX_PATH);
with Info do
begin
hwndOwner := application.mainform.Handle; //目录对话框所属的窗口句柄
pidlRoot := nil; //起始位置，缺省为我的电脑
pszDisplayName := Buffer; //用于存放选择目录的指针
lpszTitle := '请选择路径:'; //对话框提示信息
//ulFlags := BIF_RETURNONLYFSDIRS or BIF_BROWSEINCLUDEFILES;
ulFlags := BIF_RETURNONLYFSDIRS;
//选择参数，此处表示显示目录和文件，如果只显示目录则将后一个去掉即可
lpfn := nil; //指定回调函数指针
lParam := 0; //传递给回调函数参数
IDList := SHBrowseForFolder(Info); //读取目录信息
end;
if IDList <> nil then
begin
SHGetPathFromIDList(IDList, Buffer); //将目录信息转化为路径字符串
result := strpas(Buffer);
end;
StrDispose(buffer);
end;

procedure CreateLink(ExePath,LinkName: WideString); //创建快捷方式
var
tmpObject: IUnknown;
tmpSLink: IShellLink;
tmpPFile: IPersistFile;
PIDL: PItemIDList;
StartupDirectory: array[0..MAX_PATH] of Char;
StartupFilename: string;
LinkFilename: WideString;
begin
StartupFilename := ExePath;
tmpObject := CreateComObject(CLSID_ShellLink); //创建建立快捷方式的外壳扩展
tmpSLink := tmpObject as IShellLink; //取得接口
tmpPFile := tmpObject as IPersistFile; //用来储存*.lnk文件的接口
tmpSLink.SetPath(pChar(StartupFilename)); //设定notepad.exe所在路径
tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename)));
//设定工作目录
SHGetSpecialFolderLocation(0,
CSIDL_DESKTOPDIRECTORY,
PIDL); //获得桌面的Itemidlist
SHGetPathFromIDList(PIDL,
StartupDirectory); //获得桌面路径
LinkFilename := StartupDirectory;
LinkFilename :=LinkFilename+'\'+LinkName+'.lnk';
tmpPFile.Save(pWChar(LinkFilename), FALSE); //保存*.lnk文件
end;

//列举串口
procedure EnumPorts( PortList: TStrings );
var
MaxPorts : integer;
hPort : THandle;
PortNumber : integer;
PortName : string;
begin
if PortList = nil then EXIT;
case Win32PlatForm of
VER_PLATFORM_WIN32_NT: MaxPorts := 256;
VER_PLATFORM_WIN32_WINDOWS: MaxPorts := 9;
end;
for PortNumber := 1 to MaxPorts do
begin
if PortNumber > 9 then
PortName := '\\.\COM' + IntToStr( PortNumber )
else
PortName := 'COM' + IntToStr( PortNumber );
hPort := CreateFile( PChar( PortName ),
GENERIC_READ or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
0,
0 );
if not ( hPort = INVALID_HANDLE_VALUE ) then
PortList.Add( PortName );
CloseHandle( hPort );
end;
end;

procedure CloseWindow(Flag:TShutReboot); //关闭计算机或重启
var
hToken:THandle;
tkp,tkDumb:TTokenPrivileges;
DumbInt:DWORD;
begin
if Win32Platform=VER_PLATFORM_WIN32_NT then
begin
FillChar(tkp,SizeOf(tkp),0);
if (OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,hToken)) then
begin
LookupPrivilegeValue(nil,'SeShutdownPrivilege',tkp.Privileges[0].Luid);
tkp.PrivilegeCount :=1;
tkp.Privileges[0].Attributes :=SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken,False,tkp,SizeOf(tkDumb),tkDumb,DumbInt);
end;
end;

case Flag of
Reboot: ExitWindowsEx(EWX_REBOOT,0);
Force: ExitWindowsEx(EWX_FORCE,0);
shutdown: ExitWindowsEx(EWX_SHUTDOWN,0);
Logoff: ExitWindowsEx(EWX_LOGOFF,0);
Poweroff: ExitWindowsEx(EWX_POWEROFF,0);
end;
end;

initialization
OleInitialize(nil);
finalization
OleUninitialize;

end.