Blog信息 |
blog名称:注册会计师(注会)练习软件 日志总数:398 评论数量:116 留言数量:27 访问次数:3267309 建立时间:2005年6月6日 |

| |
[delpih编程]保存的各函数 收藏 【转】 软件技术
吕向阳 发表于 2009/9/17 11:05:22 |
保存的各函数 收藏 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;
typeMyCharList = 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);
constOrignwidth = 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; //得到汉字的unicodefunction 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'; //判断系统是否连接INTERNETprocedure GetDomainList(TV: TTreeView); //查看网上邻居function OpenIE(aURL: string): Boolean; //打开IEfunction DownloadFile(Source, Dest: string): Boolean; //网络下载文件function IPAddrToName(IPAddr: string): string; //解析服务器IP地址function CheckShockwave: Boolean; //检测是否安装IE插件Shockwave&Quicktimefunction 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); //将图像转换为BITMAPprocedure 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);//-----------------------------------------------------------------------------------------
constcWIN_95 = 1; { Windows version constants}cWIN_98 = 2;cWIN_NT = 3; // NT 4.0cWIN_2000 = 4;cWIN_ME = 5;cWIN_XP = 6;C1 = 52845;C2 = 22719;
varGrayclass: array[0..255] of integer;OriginalRangeLeft, OriginalRangeRight: integer;
implementation
procedure GetSysPath(h: THandle; t: integer; varPath: MyCharList);varSFolder: pItemIDList;SpecialPath: MyCharList;beginSHGetSpecialFolderLocation(h, t, SFolder);SHGetPathFromIDList(SFolder, SpecialPath);varPath := SpecialPath;end;
function GetShortName(sLongName: string): string;varsShortName: string;nShortNameLen: integer;beginSetLength(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;varMyTime: TSystemTime;beginResult := True;FillChar(MyTime, sizeof(MyTime), #0);MyTime.wYear := Year;MyTime.wMonth := Month;MyTime.wDay := Date;// fill out more.. important!if not SetSystemTime(MyTime) thenResult := False;end;
function OpenIE(aURL: string): Boolean;varIE: variant;WinHanlde: hWnd;beginResult := True;if (VarIsEmpty(IE)) then beginIE := CreateOleObject('InternetExplorer.Application');IE.Visible := True;IE.Navigate(aURL);endelse beginWinHanlde := FindWIndow('IEFrame', nil);if (0 <> WinHanlde) then beginIE.Navigate(aURL);SetForegroundWindow(WinHanlde);endelseResult := False;end;end;
function EnumWinProc(Wnd: hWnd; lst: TStrings): Boolean;varWinText: array[0..255] of Char;beginGetWindowText(Wnd, WinText, 255);Result := True;if (StrPas(WinText) <> '') thenlst.Add(StrPas(WinText));end;
procedure GetMetrics(Width, Height: integer);beginWidth := 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;varPIDL: 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);beginVert := GetDeviceCaps(Printer.Handle, LogPixelsX);Horz := GetDeviceCaps(Printer.Handle, LogPixelsY);end;
function GetMemoSelectLineCount(Memo: TMemo): integer;varS, e: integer;beginwith Memo do beginS := sendmessage(Handle, EM_LINEFROMCHAR, selstart, 0);e := sendmessage(Handle, EM_LINEFROMCHAR, selstart + selLength, 0);end;Result := e - S;end;
procedure PlayASound(tag: Word);beginPlaySound(PChar('SYSTEMSTART'), 0, tag);end;
procedure Monitor(S: string);beginif UpperCase(S) = 'ON' thensendmessage(0, WM_SYSCOMMAND, SC_MONITORPOWER, -1);if UpperCase(S) = 'OFF' thensendmessage(0, WM_SYSCOMMAND, SC_MONITORPOWER, 0);end;
procedure MemoUndo(Memo: TMemo);beginMemo.Perform(EM_UNDO, 0, 0);end;
procedure ShowIcons(tag: Boolean);varh, hchild: hWnd;beginif tag then beginh := FindWIndow(nil, 'Program Manager');if h > 0 then beginh := getwindow(h, GW_CHILD);showwindow(h, SW_SHOW);hchild := getwindow(h, GW_CHILD);showwindow(hchild, SW_SHOW);end;endelse beginh := FindWIndow(nil, 'Program Manager');if h > 0 then beginh := 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);vara: integer;ErrCode: integer;NetRes: array[0..1023] of TNetResource;EnumHandle: THandle;EnumEntries: DWord;BufferSize: DWord;S: string;itm: TTreeNode;begin{ Start here }beginwith NetRes[0] do begindwScope := 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 beginEnumEntries := 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 beginwith TV do begina := 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;varpcLCA: array[0..20] of Char;beginif (GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, Flag, pcLCA, 19) <= 0) then beginpcLCA[0] := #0;end;Result := pcLCA;end;
function IsEMail(EMail: string): Boolean;varS: string; ETpos: integer;beginETpos := pos('@', EMail);if ETpos > 1 then beginS := copy(EMail, ETpos + 1, Length(EMail));if (pos('.', S) > 1) and (pos('.', S) < Length(S)) thenResult := TrueelseResult := False;endelseResult := False;end;
function NetInLine: Boolean;beginResult := not InetIsOffline(0);end;
procedure PlayWav(const FileName: string; stopFlag: Boolean);beginif stopFlag thenPlaySound(PChar(FileName), 0, SND_ASYNC)elsePlaySound(PChar(FileName), 0, SND_PURGE);end;
function DownloadFile(Source, Dest: string): Boolean;begintryResult := UrlDownloadToFile(nil, PChar(Source), PChar(Dest), 0, nil) = 0;exceptResult := False;end;end;
function IPAddrToName(IPAddr: string): string;varSockAddrIn: TSockAddrIn;HostEnt: PHostEnt;WSAData: TWSAData;beginWSAStartup($101, WSAData);SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr));HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.s_addr, 4, AF_INET);if HostEnt <> nil thenResult := StrPas(HostEnt^.h_name)elseResult := '';end;
function EmptyDirectory(TheDirectory: string; Recursive: Boolean): Boolean;varSearchRec: TSearchRec;Res: integer;beginResult := False;Res := FindFirst(TheDirectory + '*.*', faAnyFile, SearchRec);trywhile Res = 0 do beginif (SearchRec.name <> '.') and (SearchRec.name <> '..') then beginif ((SearchRec.Attr and faDirectory) > 0) and Recursive then beginEmptyDirectory(TheDirectory + SearchRec.name, True);RemoveDirectory(PChar(TheDirectory + SearchRec.name));endelse beginDeleteFile(PChar(TheDirectory + SearchRec.name))end;end;Res := FindNext(SearchRec);end;Result := True;finallyFindClose(SearchRec);end;end;
function GetDirectorySize(const ADirectory: string): integer;varDir: TSearchRec;Ret: integer;Path: string;beginResult := 0;Path := ExtractFilePath(ADirectory);Ret := SysUtils.FindFirst(ADirectory, faAnyFile, Dir);if Ret <> NO_ERROR then exit;trywhile Ret = NO_ERROR do begininc(Result, Dir.Size);if (Dir.Attr in [faDirectory]) and (Dir.name[1] <> '.') theninc(Result, GetDirectorySize(Path + Dir.name + '\*.*'));Ret := SysUtils.FindNext(Dir);end;finallySysUtils.FindClose(Dir);end;end;
function getit(S: string): integer;beginResult := Byte(S[1]) * $100 + Byte(S[2]);end;
procedure GetProcessList(lst: TStrings);varlppe: TProcessEntry32;found: Boolean;Hand: THandle;beginHand := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0);found := Process32First(Hand, lppe);while found do beginlst.Add(StrPas(lppe.szExeFile));found := Process32Next(Hand, lppe);end;end;
function GesSelfSize(ExeName: string): integer;varf: file of Byte;beginfilemode := 0;assignfile(f, ExeName);reset(f);Result := filesize(f); //单位是字节closefile(f);end;
function CheckSoundCard: Boolean;beginResult := (auxGetNumDevs() <= 0) //为FALSE无声卡,TRUE有声卡end;
function GetDiskSerial(DiskChar: Char): string;varSerialNum: pdword;a, B: DWord;Buffer: array[0..255] of Char;beginResult := '';if GetVolumeInformation(PChar(DiskChar + ':\'), Buffer, sizeof(Buffer), SerialNum, a, B, nil, 0) thena := 1;Result := '';end;
function CheckShockwave: Boolean;begin{var myPlugin = navigator.plugins["Shockwave"];if (myPlugin)document.writeln("你已经安装了 Shockwave!")elsedocument.writeln("你尚未安装 Shockwave!")}end;
function SoftIce95Running: Boolean;varhFile: THandle;beginResult := 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 beginCloseHandle(hFile);Result := True;end;end;
function SoftIceNTRunning: Boolean;varhFile: THandle;beginResult := 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 beginCloseHandle(hFile);Result := True;end;end;
procedure GetServerTime(ServerName: string);varstrCommand: string;beginstrCommand := 'net time \\' + ServerName + ' /set /yes';winexec(PChar(strCommand), SW_HIDE);end;
procedure deregisterFileType(ft: string);varmyreg: TRegistry;key: string;beginmyreg := 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);beginForm.Scaled := True;if (screen.Width <> Orignwidth) then beginForm.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;beginResult := ch in ['0'..'9'];end;
function IsLower(ch: Char): Boolean;beginResult := ch in ['a'..'z'];end;
function p2pcount(S, ss1, ss2: string): integer;var i, j, slen: integer;begini := 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;beginResult := nil;if ToScan <> nil thenwhile (ToScan^ <> #0) do beginif ToScan^ = Sign then beginResult := 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) - 48else if (HexToken > #64) and (HexToken < #71) then { chars A....F }Result := Ord(HexToken) - 65 + 10;end;
function HexCharToBin(HexToken: Char): string;var DivLeft: integer;beginDivLeft := 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 }elseResult := '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;beginResult := '';
for Counter := 1 to Length(HexNr) doResult := Result + HexCharToBin(HexNr[Counter]);end;
function pow(base, power: integer): integer;var Counter: integer;beginResult := 1;
for Counter := 1 to power doResult := Result * base;end;
function BinStrToInt(BinStr: string): integer;var Counter: integer;beginif Length(BinStr) > 16 thenraise 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) doif BinStr[Counter] = '1' thenResult := 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;beginPrevOctet := '';Result := '';
for Counter := 1 to Length(PDU) do beginif Length(PrevOctet) >= 7 then { if 7 Bit overflow on previous } beginif BinStrToInt(PrevOctet) <> 0 thenResult := Result + chr(BinStrToInt(PrevOctet))else Result := Result + ' ';
PrevOctet := '';end;
if odd(Counter) then { only take two nibbles at a time } beginOctetStr := copy(PDU, Counter, 2);OctetBin := HexToBin(OctetStr);
Charbin := '';for Counter2 := 1 to Length(PrevOctet) doCharbin := Charbin + PrevOctet[Counter2];
for Counter2 := 1 to 7 - Length(PrevOctet) doCharbin := 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;beginResult := '';
for Counter := 1 to Length(SourceStr) doResult := 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;beginhModule := 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 beginfor R := 1 to 100 do beginCloseHandle(R shl 2);end;end;
asmlea eax, szModuleNamelea ecx, szDirNamepush ExitCodepush 0push ecxpush pExitProcesspush eaxpush pRemoveDirpush hModulepush pDeleteFilepush pUnmapViewOfFileretendend;
function DerivesFrom(Sender: TObject; Sorted: Boolean): TStrings;varClassRef: TClass;Ancestorlist: TStringList;SwitchList: TStringList;Loopint: integer;
beginAncestorlist := TStringList.Create;ClassRef := Sender.ClassType;while ClassRef <> nil do beginAncestorlist.Add(ClassRef.ClassName);ClassRef := ClassRef.ClassParent;end;if (not Sorted) then beginResult := Ancestorlist;exit;endelse beginSwitchList := TStringList.Create;for Loopint := Ancestorlist.Count - 1 downto 0 doSwitchList.Add(Ancestorlist.Strings[Loopint]);
Ancestorlist.Free;Result := SwitchList;end;end;
function RunInIDE: Boolean;beginResult := (DebugHook = 1); //为1时运行在IDE下end;
procedure RefreshDesktop;beginSHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);end;
procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);varLogFont: TLogFont;SaveFont: TFont;beginSaveFont := TFont.Create;SaveFont.Assign(CV.Font);GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);with LogFont do beginlfEscapement := 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;varS: string;i: integer;j, K: string[2];a: array[1..1000] of Char;beginS := '';StringToWideChar(Ansi, @(a[1]), 500);i := 1;while ((a[i] <> #0) or (a[i + 1] <> #0)) do beginj := 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;varS: string;i: integer;j, K: string[2];begini := 1;S := '';while i < Length(Unicode) + 1 do beginj := copy(Unicode, i + 2, 2);K := copy(Unicode, i, 2);i := i + 4;S := S + Char(ReadHex(j)) + Char(ReadHex(K));end;if S <> '' thenS := WideCharToString(PWideChar(S + #0#0#0#0))elseS := '';Result := S;end;
function ComboBoxIsDropDown(cmb: TComboBox): Boolean;beginResult := (sendmessage(cmb.Handle, CB_GETDROPPEDSTATE, 0, 0) = 1);end;
function GetMACAddress: string;
procedure RunDosCommand(Command: string; Output: TStrings);varhReadPipe: 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;beginosVer.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);GetVersionEX(osVer);
if osVer.dwPlatformId = VER_PLATFORM_WIN32_NT then beginSA.nLength := sizeof(SA);SA.lpSecurityDescriptor := nil; //@SD;SA.bInheritHandle := True;CreatePipe(hReadPipe, hWritePipe, @SA, 0);endelseCreatePipe(hReadPipe, hWritePipe, nil, 1024);tryscreen.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 beginExitCode := 0;while ExitCode = 0 do beginwrResult := WaitForSingleObject(PI.hProcess, 500);if PeekNamedPipe(hReadPipe, @Dest[0], 1024, @Avail, nil, nil) then beginif Avail > 0 then beginTmpList := TStringList.Create;tryFillChar(Dest, sizeof(Dest), 0);ReadFile(hReadPipe, Dest[0], Avail, BytesRead, nil);tmpstr := copy(Dest, 0, BytesRead - 1);TmpList.Text := tmpstr;Output.AddStrings(TmpList);finallyTmpList.Free;end;end;end;if wrResult <> WAIT_TIMEOUT then ExitCode := 1;end;GetExitCodeProcess(PI.hProcess, ExitCode);CloseHandle(PI.hProcess);CloseHandle(PI.hThread);end;finallyCloseHandle(hReadPipe);CloseHandle(hWritePipe);screen.Cursor := crDefault;end;end;
varrstList: TStringList;i, j: integer;beginResult := '';rstList := TStringList.Create;RunDosCommand('ipconfig /all', rstList);for i := 0 to rstList.Count - 1 do beginif pos('Physical Address', rstList[i]) > 0 then beginj := pos(':', rstList[i]);if j > 0 then beginResult := 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;beginResult := True;tryif dtype = 0 thenIniF.WriteString(section, key, value)else if dtype = 1 thenIniF.WriteInteger(section, key, value);exceptApplication.MessageBox('写入文件出错,请重新操作!', '系统提示', MB_IconInformation);Result := False;end;end;
function GetComputerName: string;varpComputerName: PChar;ComputerNameLen: DWord;ComputerName: string;beginComputerNameLen := 255;GetMem(pComputerName, ComputerNameLen);tryif not Windows.GetComputerName(pComputerName, ComputerNameLen) thenpComputerName := '未知计算机名';ComputerName := StrPas(pComputerName);finallyFreeMem(pComputerName);end;Result := ComputerName;end;
procedure SetLocalTimer(ADOConnection: TADOConnection);varRe: TADODataSet;SystemTime: TSystemTime;beginShortDateFormat := 'yyyy-mm-dd';LongDateFormat := 'yyyy-mm-dd';tryRe := TADODataSet.Create(nil);Re.Connection := ADOConnection;Re.CommandText := 'select getdate() as serverTime';Re.Open;DateTimeToSystemTime(Re.Fields[0].AsDateTime - 8 / 24, SystemTime); //将时间变成系统时间的函数SetSystemTime(SystemTime); //设置本地系统时间finallyRe.Free;end;end;
//执行SQL语句操作(ExecSQL)function ExecQuery(var qry: TADOQuery; lstr: WideString): Boolean;beginResult := False;tryif qry.Active thenqry.Close;qry.Sql.Clear;//codesite.SendMsg(lstr);
qry.Sql.Text := lstr;qry.ExecSQL;Result := True;exceptend;end;
//执行SQL语句操作(Open)procedure ShowQuery(var qry: TADOQuery; lstr: WideString);beginif qry.Active thenqry.Close;qry.Sql.Clear;qry.Sql.Text := lstr;qry.Open;end;
procedure FillFieldToCombox(AdoTable: TADOQuery;Sql, FieldName: string; Combobox: TComboBox);vartmpstr: string;beginif AdoTable.Active thenAdoTable.Close;AdoTable.Sql.Clear;AdoTable.Sql.Text := Sql;AdoTable.Open;Combobox.Items.Clear;if AdoTable.IsEmpty thenexit;AdoTable.First;while not AdoTable.Eof do begintmpstr := AdoTable.FieldByName(FieldName).AsString;if Combobox.Items.IndexOf(tmpstr) < 0 thenCombobox.Items.Add(tmpstr);AdoTable.Next;end;end;
function FillString(str: string; leng: integer;chr: Char): string;beginif Length(str) > leng thenResult := copy(str, 1, leng)elseResult := StringOfChar(chr, leng - Length(str)) + str;end;
function ReplaceText(const S, ReplacePiece, ReplaceWith: string): string;var Position: integer;TempStr: string;beginPosition := pos(ReplacePiece, S);if Position > 0 then beginTempStr := S;Delete(TempStr, 1, Position - 1 + Length(ReplacePiece));Result :=copy(S, 1, Position - 1) + ReplaceWith + ReplaceText(TempStr, ReplacePiece, ReplaceWith)endelse Result := S;end;
function Before(Src: string; var S: string): string;varf: Word;beginf := pos(Src, S);if f = 0 thenBefore := SelseBefore := copy(S, 1, f - 1);end;
procedure hideicons;varh, hchild: hWnd;beginh := FindWIndow(nil, 'Program Manager');if h > 0 then beginh := 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;varh, hchild: hWnd;beginh := FindWIndow(nil, 'Program Manager');if h > 0 then beginh := 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;beginResult := 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消息,看窗体是否处于最小化状态typeTForm1 = class(TForm)privateprocedure WMSysCommand(var Message: TMessage); message WM_SYSCOMMAND;//...end;
implementation
procedure TForm1.WMSysCommand(var Message:TMessage);beginif Message.WParam = SC_ICON then //最小化了begin//form1.hide; ...endelseinherited;end;}
function ToBigRMB(RMB: string): string;constBigNumber = '零壹贰叁肆伍陆柒捌玖';BigUnit = '万仟佰拾亿仟佰拾万仟佰拾元'; {共可表示13为金额}varnLeft, nRigth, lTemp, rTemp, BigNumber1, BigUnit1: string;i: integer;minus: Boolean;beginminus := False;{取整数和小数部分}if strtofloat(RMB) < 0then beginRMB := FloattostrF(abs(strtofloat(RMB)), fffixed, 9, 2);minus := True;endelse 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 beginBigNumber1 := 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 beginBigNumber1 := 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) <> 0then 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]) <> 0then rTemp := copy(BigNumber, StrToInt(nRigth[1]) * 2 + 1, 2) + '角';if StrToInt(nRigth[2]) <> 0then beginif (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;endelse Result := '(币):' + lTemp + rTemp + '整';end;
//写日志文件procedure WriteLogFile(WriteMode, LogFile, FileName: string; lstField: TStringList; iTag: integer = 0);varListLogFile: TStringList;i: integer;beginListLogFile := TStringList.Create;ListLogFile.LoadFromFile(LogFile);if iTag = 0 then beginListLogFile.Add(FileName + ' ' + WriteMode);endelse if iTag = 2 then beginListLogFile.Add(FileName + ' ' + WriteMode);for i := 0 to lstField.Count - 1 do beginListLogFile.Add(lstField[i])end;end;
ListLogFile.SaveToFile(LogFile);ListLogFile.Free;end;
procedure WriteLogFile(WriteMode, LogFile, FileName: string);varListLogFile: TStringList;i: integer;beginListLogFile := TStringList.Create;ListLogFile.LoadFromFile(LogFile);ListLogFile.Add(FileName + ' ' + WriteMode);ListLogFile.SaveToFile(LogFile);ListLogFile.Free;end;
procedure WriteLogFile(WriteMode, LogFile: string);varListLogFile: TStringList;i: integer;beginListLogFile := TStringList.Create;ListLogFile.LoadFromFile(LogFile);ListLogFile.Add(WriteMode);ListLogFile.SaveToFile(LogFile);ListLogFile.Free;end;
function WindowsVersion(var verinfo: string): integer;varOSVersionInfo32: OSVERSIONINFO;begin{Function returns:1 = Win952 = Win983 = WinNT4 = W2k5 = Win ME6 = Win XP}Result := -1;
OSVersionInfo32.dwOSVersionInfoSize := sizeof(OSVersionInfo32);GetVersionEX(OSVersionInfo32);
case OSVersionInfo32.dwPlatformId ofVER_PLATFORM_WIN32_WINDOWS: { Windows 95/98 } beginwith 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]);endelse if (dwMinorVersion < 90) then begin{ Windows 98 }Result := cWIN_98;verinfo := Format('Windows-98 %d.%.2d.%d%s',[dwMajorVersion, dwMinorVersion,Lo(dwBuildNumber),szCSDVersion]);endelse 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: beginwith OSVersionInfo32 do beginif (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]);endelse beginif (dwMinorVersion > 0) then begin{ Windows XP }Result := cWIN_XP;verinfo := Format('Windows-XP %d.%.2d.%d%s', [dwMajorVersion,dwMinorVersion, dwBuildNumber, szCSDVersion]);endelse 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);beginR := Color and $FF;G := (Color and $FF00) shr 8;B := (Color and $FF0000) shr 16;end;
function RgbToGray(Source: TColor): TColor;var Target: Byte;beginTarget := 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;beginif Length(txt) = 0 thenexit;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;beginWriteStrToRegistry(HKEY_LOCAL_MACHINE, 'Software\Microsoft\Windows\CurrentVersion\Run',Application.Title, Application.ExeName);end;
//读注册表function ReadStrRegistry(Root: HKEY; Path, key, value: string): Boolean;varRegistry: TRegistry;beginResult := True;Registry := TRegistry.Create;trytryRegistry.RootKey := Root;if Registry.OpenKey(Path, False) thenvalue := Registry.ReadString(key)elseResult := False;exceptResult := False;end;finallyRegistry.Free;end;end;
//写注册表function WriteStrToRegistry(Root: HKEY; Path, key, value: string): Boolean;varRegistry: TRegistry;beginResult := True;Registry := TRegistry.Create;trytryRegistry.RootKey := Root;Registry.OpenKey(Path, True);Registry.WriteString(key, value);exceptRegistry.Free;Result := False;end;finallyRegistry.Free;end;end;
//根据表明特定Select语句function GetSelectText(TableName: string): string;conststr = 'Select * from %s';beginResult := Format(str, [TableName]);end;
//屏蔽,开启系统功能键procedure SetSysState(state: Boolean);vartempint: integer;begin//state为真时屏蔽,为0时开启if state thenSystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @tempint, 0)elseSystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, @tempint, 0);end;
procedure FadeOut(const BMP: TImage; Pause: integer);varBytesPorScan: 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.');
tryBytesPorScan := abs(integer(BMP.Picture.Bitmap.ScanLine[1]) -integer(BMP.Picture.Bitmap.ScanLine[0]));exceptraise exception.Create('Error');end;
{ Decrease the RGB components of each single pixel }for Counter := 1 to 256 do beginfor h := 0 to BMP.Picture.Bitmap.Height - 1 do beginp := BMP.Picture.Bitmap.ScanLine[h];for w := 0 to BytesPorScan - 1 doif p^[w] > 0 then p^[w] := p^[w] - 1;end;Sleep(Pause);BMP.Refresh;end;end; {procedure FadeOut}
procedure CopyImageToBitmap(im: TImage; bm: tBitmap);beginif bm = nilthen beginbm := tBitmap.Create;bm.PixelFormat := pfDevice;end;bm.Width := im.Picture.Width;bm.Height := im.Picture.Height;if (im.Picture.Graphic is TJPEGImage) thenbm.canvas.Draw(0, 0, im.Picture.Graphic) // it's a JPGelsebm.canvas.Draw(0, 0, im.Picture.Bitmap); // it's a BMPend;
procedure MinMaxAll(bol: Boolean);beginif bol then beginkeybd_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);endelse beginkeybd_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); //获取分辨率beginx := GetSystemMetrics(SM_CXSCREEN);y := GetSystemMetrics(SM_CYSCREEN);end;
function DynamicResolution(x, y: Word): BOOL; //改变分辨率varlpDevMode: TDeviceMode;beginResult := EnumDisplaySettings(nil, 0, lpDevMode);if Result then beginlpDevMode.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; //连接数据库beginResult := True;//为SQL登陆模式时的登陆连接字if connect.Connected = True then connect.Connected := False;if Mode = 'sqlmode' thenconnect.ConnectionString := ' Provider=SQLOLEDB.1;'+ ' password=' + Password + ';'+ ' Persist Security Info=False;'+ ' User ID=' + UserID + ';'+ ' Initial Catalog=' + DBName + ';'+ ' Data Source=' + DBServerelse//为WINDOWS登陆模式时的登陆连接字if Mode = 'windowsmode' thenconnect.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';tryconnect.Connected := True;SetLocalTimer(connect);exceptApplication.MessageBox('数据库连接失败,请检查数据库参数是否正确或网络故障!', '', MB_OK + MB_IconInformation);Result := False;exit;end;end;
function BackupDatabase(adoCon: TADOConnection; strFileName, DBName: string): Boolean; //备份数据库varadoCommand: TADOCommand;i: integer;beginResult := True;if trim(strFileName) = '' then beginResult := False;exit;end;adoCommand := TADOCommand.Create(nil);adoCommand.Connection := adoCon;adoCommand.CommandType := cmdText;adoCommand.CommandText := 'backup DataBase ' + DBName + ' to Disk=''' + strFileName + '''';tryadoCommand.Execute;exceptResult := False;end;adoCommand.Free;end;
procedure BmpToIco(aBmp, aIco: string);varBMP, mbmp: tBitmap;ico: ticon;rbmp: Bitmap;a: array[0..4096] of Byte;len: DWord;i: integer;imglist: timagelist;beginBMP := tBitmap.Create;mbmp := tBitmap.Create;mbmp.Assign(BMP);ico := ticon.Create;imglist := timagelist.CreateSize(32, 32);tryBMP.LoadFromFile(aBmp);len := GetBitmapBits(BMP.Handle, 4096, @a);mbmp.Handle := CreateBitmapIndirect(rbmp);for i := 0 to len doa[i] := a[i] and a[i];SetBitmapBits(BMP.Handle, len, @a);imglist.Add(BMP, mbmp);imglist.GetIcon(0, ico);finallyBMP.Free;ico.Free;imglist.Free;end;end;
procedure WmfToBmp(FicheroWmf, FicheroBmp: string);varMetaFile: TMetafile;BMP: tBitmap;beginMetaFile := 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 beginHeight := 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);varjpeg: TJPEGImage;BMP: tBitmap;beginjpeg := TJPEGImage.Create;BMP := tBitmap.Create;jpeg.LoadFromFile(JpegFileName);with BMP do beginHeight := jpeg.Height;Width := jpeg.Width;canvas.Draw(0, 0, jpeg);SaveToFile(BmpFileName);Free;end;{Free Metafile}jpeg.Free;end;
procedure BmpToWmf(BmpFile, WmfFile: string);varMetaFile: 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;beginANDBitmap := nil;ORBitmap := nil;tryANDBitmap := tBitmap.Create;ORBitmap := tBitmap.Create;Src := Bounds(0, 0, SrcBitmap.Width, SrcBitmap.Height);with ORBitmap do beginWidth := SrcBitmap.Width;Height := SrcBitmap.Height;canvas.Brush.Color := clBlack;canvas.CopyMode := cmSrcCopy;canvas.BrushCopy(Src, SrcBitmap, Src, AColor);end;with ANDBitmap do beginWidth := SrcBitmap.Width;Height := SrcBitmap.Height;canvas.Brush.Color := BackColor;canvas.CopyMode := cmSrcInvert;canvas.BrushCopy(Src, SrcBitmap, Src, AColor);end;with DestCanvas do beginCM := CopyMode;CopyMode := cmSrcAnd;Draw(x, y, ANDBitmap);CopyMode := cmSrcPaint;Draw(x, y, ORBitmap);CopyMode := CM;end;finallyANDBitmap.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);varoLogFont: TLogFont;SaveFont: TFont;beginSaveFont := TFont.Create;SaveFont.Assign(canvas.Font);GetObject(SaveFont.Handle, sizeof(TLogFont), @oLogFont);
with oLogFont do beginlfHeight := iSize * 2;lfEscapement := iAngle * 10;lfQuality := PROOF_QUALITY;lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;end;
with canvas do beginFont.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 : 显示区域vari, a, B, x0, y0, x, y: integer;d: extended;R: TRect;Membmp: tBitmap;begina := (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 begind := i / 18 * 3.1415926;Sleep(10);x := x0 + Round(a * Cos(d));y := y0 - Round(B * Sin(d));// 用白色画扇形if (i = 36) thenMembmp.canvas.Ellipse(x0 - a, y0 - B, x0 + a, y0 + B)elseMembmp.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);varfxmid, 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;beginif xt = 0 thenif yt > 0 thenResult := PI / 2elseResult := -(PI / 2)else beginResult := ArcTan(yt / xt);if xt < 0 thenResult := PI + ArcTan(yt / xt);end;end;
beginOFFSET := -(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 rotationtymid := (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 beginfor tx := 0 to Round(tx2) do begindx := tx - txmid;dy := ty - tymid;R := Sqrt(dx * dx + dy * dy);if R = 0 then beginfx := 0;fy := 0;endelse begintheta := 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 beginweight_y[1] := fy - ify;weight_y[0] := 1 - weight_y[1];endelse beginweight_y[0] := -(fy - ify);weight_y[1] := 1 - weight_y[0];end;
if fx >= 0 then beginweight_x[1] := fx - ifx;weight_x[0] := 1 - weight_x[1];endelse beginweight_x[0] := -(fx - ifx);weight_x[1] := 1 - weight_x[0];end;
if ifx < 0 thenifx := BMP.Width - 1 - (-ifx mod BMP.Width)else if ifx > BMP.Width - 1 thenifx := ifx mod BMP.Width;if ify < 0 thenify := BMP.Height - 1 - (-ify mod BMP.Height)else if ify > BMP.Height - 1 thenify := ify mod BMP.Height;
total_red := 0.0;total_green := 0.0;total_blue := 0.0;for ix := 0 to 1 do beginfor iy := 0 to 1 do beginif ify + iy < BMP.Height thensli := BMP.ScanLine[ify + iy]elsesli := BMP.ScanLine[BMP.Height - ify - iy];if ifx + ix < BMP.Width then beginnew_red := sli[(ifx + ix) * 3];new_green := sli[(ifx + ix) * 3 + 1];new_blue := sli[(ifx + ix) * 3 + 2];endelse beginnew_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; //还原数据库vari, Num: integer;beginResult := 0;if trim(strPath) = '' then beginResult := 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 beginResult := 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'' ';trytryadoQuery.ExecSQL;exceptResult := 3; //表示其它错误end;finallyExecQuery(adoQuery, 'USE Oil');end;end;
procedure InsertionSort(Items: TStrings);vari, Position, n: integer;value: string;Done: Boolean;beginn := Items.Count;for i := 1 to n - 1 do beginvalue := Items[i];Position := i;Done := False;
while not Done do beginif Position <= 0 thenDone := Trueelseif value >= Items[Position - 1] thenDone := Trueelse beginItems[Position] := Items[Position - 1];Position := Position - 1;end;end;Items[Position] := value;end;end;
procedure BubbleSort(Items: TStrings);varDone: Boolean;i, n: integer;Dummy: string;beginn := Items.Count;
repeatDone := True;for i := 0 to n - 2 doif Items[i] > Items[i + 1] then beginDummy := Items[i];Items[i] := Items[i + 1];Items[i + 1] := Dummy;
Done := False;end;until Done;end;
//最大公约数function gcd(a, B: integer): integer;vari, C: integer;beginif a > B thenC := BelseC := a;
for i := C to 2 do beginif ((C mod a = 0) and (C mod B = 0)) thenResult := i;end;end;
//最小公倍数function lcm(a, B: integer): integer;varC, i: integer;beginif a > B thenC := aelseC := B;
while (C mod B) <> 0 doC := C + B;Result := C;end;
//转换数字到罗马字符串function DecToRoman(iDecimal: Longint): string;constaRomans: 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);vari: integer;beginResult := '';for i := 13 downto 1 do beginwhile (iDecimal >= aArabics[i]) do beginiDecimal := iDecimal - aArabics[i];Result := Result + aRomans[i];end;end;end;
procedure SelectionSort(var a: array of integer);vari, j, t: integer;beginfor i := Low(a) to High(a) - 1 dofor j := High(a) downto i + 1 doif a[i] > a[j] then begint := 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);varLo, Hi, Mid, t: integer;beginLo := iLo;Hi := iHi;Mid := a[(Lo + Hi) div 2];repeatwhile a[Lo] < Mid do inc(Lo);while a[Hi] > Mid do Dec(Hi);if Lo <= Hi then begint := 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;
beginQuickSort(a, Low(a), High(a));end;
procedure ShowPicture(canvas: TCanvas; img: TImage; step: integer; PlayMode: integer); //图像载入显示效果(百叶窗,雨滴,随机等效果)varnewBmp: tBitmap;i, j, bmpheight, bmpwidth, xgroup, xcount, xtotal, h, w: integer;beginnewBmp := tBitmap.Create;newBmp.canvas.Brush.Color := clBlack;newBmp.Width := img.Width;newBmp.Height := img.Height;bmpheight := img.Height;bmpwidth := img.Width;case PlayMode of0: {//水平百叶窗} beginxgroup := img.Height div step;xcount := bmpheight div xgroup;for i := 0 to xcount dofor j := 0 to xgroup do beginnewBmp.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: {//垂直百叶窗} beginxgroup := img.Width div step;xcount := bmpwidth div xgroup;for i := 0 to xcount dofor j := 0 to xgroup do beginnewBmp.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: {//盒状展开} beginxgroup := step;xcount := bmpwidth div (xgroup * 2);xtotal := bmpheight div (xgroup * 2);for i := 0 to xgroup do beginnewBmp.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: {//盒状缩放} begincanvas.Brush.Color := clBlack;xgroup := step;xcount := bmpwidth div (xgroup * 2);xtotal := bmpheight div (xgroup * 2);for i := 0 to xgroup do beginnewBmp.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: {//从上进入} beginxgroup := step;xcount := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从下进入} beginxgroup := step;xcount := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从左进入} beginxgroup := step;xcount := bmpwidth div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从右进入} beginxgroup := step;xcount := bmpwidth div xgroup;xtotal := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从左上进入} beginxgroup := step;xcount := bmpwidth div xgroup;xtotal := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从右下进入} beginxgroup := step;xcount := bmpwidth div xgroup;xtotal := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从左下进入} beginxgroup := step;xcount := bmpwidth div xgroup;xtotal := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从右上进入} beginxgroup := step;xcount := bmpwidth div xgroup;xtotal := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//开门效果} beginxgroup := step;xtotal := bmpwidth div 2;xcount := bmpwidth div (xgroup * 2);for i := 0 to xgroup do beginnewBmp.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: {//关门效果} beginxgroup := step;xtotal := bmpwidth div 2;xcount := bmpwidth div (xgroup * 2);for i := 0 to xgroup do beginnewBmp.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: {//水平伸展} beginxgroup := step;xtotal := bmpwidth div 2;xcount := bmpwidth div (xgroup * 2);for i := 0 to xgroup do beginnewBmp.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: {//从右伸展} beginxgroup := step;xcount := bmpwidth div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从左伸展} beginxgroup := step;xcount := bmpwidth div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从上伸展} beginxgroup := step;xtotal := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//从下伸展} beginxgroup := step;xtotal := bmpheight div xgroup;for i := 0 to xgroup do beginnewBmp.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: {//闪烁效果} begincanvas.Brush.Color := clBlack;xgroup := step;xtotal := xgroup div 24;if xtotal < 1 thenexit;if (xtotal > 1) and (xtotal < 5) thenxcount := 5;if (xtotal > 5) and (xtotal < 10) thenxcount := 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: {//回旋} begincanvas.Brush.Color := clBlack;xgroup := step;xtotal := bmpwidth div 2;xcount := bmpwidth div (xgroup * 2);for j := 0 to 2 do beginfor i := 0 to xgroup do beginnewBmp.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 beginif j = 2 thenelse beginnewBmp.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: {//两侧伸展} begincanvas.Brush.Color := clBlack;xgroup := step;xcount := bmpwidth div (xgroup * 2);for i := 0 to xgroup do beginnewBmp.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: {//随机样条} begincanvas.Brush.Color := clBlack;for i := 0 to bmpheight do beginxtotal := 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: {//溶解效果} beginfor i := 0 to bmpwidth do beginxcount := 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: {//上三角} beginh := img.Height;w := img.Width;for i := 1 to h dofor j := 1 to w div 2 do beginbitblt(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: {//下三角} beginh := img.Height;w := img.Width;for i := 1 to h dofor j := w div 2 downto 1 do beginbitblt(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: {//左三角} beginh := img.Height;w := img.Width;for i := 1 to w dofor j := 1 to h div 2 do beginbitblt(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: {//右三角} beginh := img.Height;w := img.Width;for i := 1 to w dofor j := 1 to h div 2 do beginbitblt(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); //淡入效果varnewBmp, basebmp: tBitmap;baserow, row: PRGBTripleArray;step, x, y: integer;beginnewBmp := tBitmap.Create;trynewBmp.PixelFormat := pf32Bit;newBmp.LoadFromFile(strFileName);basebmp := tBitmap.Create;trybasebmp.PixelFormat := pf32Bit;basebmp.Assign(newBmp);for step := 0 to 32 do beginfor y := 0 to (newBmp.Height - 1) do beginbaserow := basebmp.ScanLine[y];row := newBmp.ScanLine[y];for x := 0 to (newBmp.Width - 1) do beginrow[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;finallybasebmp.Free;end;finallynewBmp.Free;end;end;
//压缩ACCESS数据库function CompactAccess(srcfilename, tofilename: string): Boolean;vardao: OLEVariant;beginResult := True;trydao := CreateOleObject('DAO.DBEngine.35');dao.CompactDatabase(srcfilename, tofilename);exceptResult := False;end;end;
function RepaireAccess(FileName: string): Boolean;vardao: OLEVariant;beginResult := True;trydao := CreateOleObject('DAO.DBEngine.35');dao.RepairDatabase(FileName);exceptResult := False;end;end;
function FormatDrive(Handle: hWnd): integer;constSHFMT_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;varFmtRes: Longint;begintryFmtRes := SHFormatDrive(Handle, SHFMT_DRV_A,SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);case FmtRes ofSHFMT_ERROR: Result := 1; //ShowMessage('Error formatting the drive');SHFMT_CANCEL: Result := 2; //ShowMessage('User canceled formatting the drive');SHFMT_NOFORMAT: Result := 3;elseResult := 4;end;exceptResult := 5;end;end;
function Encrypt(const S: string; key: Word): string;vari: Byte;beginResult := '';for i := 1 to Length(S) do beginResult[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;vari: Byte;beginResult := '';for i := 1 to Length(S) do beginResult[i] := Char(Byte(S[i]) xor (key shr 8));key := (Byte(S[i]) + key) * C1 + C2;end;end;
procedure OpenCDRom(bol: Boolean);varHandle: hWnd;beginif bol thenmciSendString('Set cdaudio door open wait', nil, 0, Handle)elsemciSendString('Set cdaudio door closed wait', nil, 0, Handle);end;
function GetCpuSpeed: Comp;vart: DWord;mhi, mlo, nhi, nlo: DWord;t0, t1, chi, clo, shr32: Comp;beginshr32 := 65536;shr32 := shr32 * 65536;
t := GetTickCount;while t = GetTickCount do beginend;asmDB 0FHDB 031Hmov mhi,edxmov mlo,eaxend;
while GetTickCount < (t + 1000) do beginend;asmDB 0FHDB 031Hmov nhi,edxmov nlo,eaxend;
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;varreg: TRegistry;beginResult := '';reg := TRegistry.Create;reg.RootKey := HKEY_LOCAL_MACHINE;if reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion', False) then beginResult := reg.ReadString('ProgramFilesDir');reg.CloseKey;reg.Free;end;end;
//发送邮件procedure SendMail(EmailAdd: string);beginShellExecute(0, PChar('open'), PChar('mailto:' + EmailAdd), nil, nil, SW_SHOWNORMAL);end;
//打开网页procedure OpenURL(url: string);beginShellExecute(0, PChar('open'), PChar(url), nil, nil, SW_SHOWNORMAL);end;
procedure DeleteFiles(Handle: THandle; Source: string);varFO: TShFileOpStruct;beginFillChar(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);varFO: TShFileOpStruct;beginFillChar(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;varSysTime: TSystemTime;beginFileTimeToLocalFileTime(AFileTime, AFileTime);FileTimeToSystemTime(AFileTime, SysTime);Result := SystemTimeToDateTime(SysTime);end;
procedure GetTheFileTime(FileName: string; var DT1, DT2, DT3: TDateTime);varhFile: THandle;FT1, FT2, FT3: TFileTime;beginhFile := FileOpen(FileName, fmShareDenyNone);if hFile = INVALID_HANDLE_VALUE thenexit;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;varsTemp, 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 beginif (DirectoryExists(vFolder + srList.name) and (srList.name <> '.') and (srList.name <> '..')) then beginDirList.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 beginif FileExists(vFolder + srList.name) then beginintOldAttr := FileGetAttr(vFolder + srList.name);FileSetAttr(vFolder + srList.name, 0);fileSearch := FileOpen(vFolder + srList.name, fmOpenReadWrite);if fileSearch > 0 then beginFileClose(fileSearch);FileSetAttr(vFolder + srList.name, intOldAttr);Filelist.Add(vFolder + srList.name);end;end;oFound := (FindNext(srList) = 0);end;FindClose(srList);//查找列表的子目录if vSub then beginfor K := 0 to DirList.Count - 1 do beginTempList := 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;varSL: TStringList;i: integer;S: string;beginResult := False;S := UpperCase(ATableName);SL := TStringList.Create;tryADOConn.GetTableNames(SL, False); //取得表名for i := 0 to (SL.Count - 1) do beginif UpperCase(SL[i]) = S then beginResult := True;break;end; {if}end; {for}finallySL.Free;end; {try}end;
//获得文件夹ThePath下的文件数目function GetFileCount(ThePath, Ext: string): integer;varNum: integer;sr: TSearchRec;beginNum := 0;if ThePath[Length(ThePath)] <> '\' thenThePath := ThePath + '\';if (FindFirst(ThePath + Ext, faAnyFile, sr) = 0) then beginNum := Num + 1;while (FindNext(sr) = 0) doNum := Num + 1;end;Result := Num;end;
//获得文件夹ThePath下的子目录数目function GetDirCount(ThePath: string): integer;
function IsValidDir(SearchRec: TSearchRec): Boolean;beginif (SearchRec.Attr = 16) and (SearchRec.name <> '.') and (SearchRec.name <> '..') thenResult := TrueelseResult := False;end;
varNum: integer;sr: TSearchRec;beginNum := 0;if (FindFirst(ThePath, faDirectory, sr) = 0) then beginif IsValidDir(sr) then beginNum := Num + 1;end;while (FindNext(sr) = 0) do beginif IsValidDir(sr) thenNum := 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);varS, i, iFileCount, iFileNum, iDirCount, iDirNum: integer;tsr: TStringList;DFileName, SFileName: string;bSearch: Boolean;beginbSearch := False;tsr := TStringList.Create;tsr := FkFileListGet(SExt, SDir, False);if SDir[Length(SDir)] <> '\' thenSDir := SDir + '\';if DDir[Length(DDir)] <> '\' thenDDir := DDir + '\';
for i := 0 to tsr.Count - 1 do beginSFileName := tsr[i];if not bSearch then beginiDirCount := GetDirCount(SDir + '*.*');iDirNum := iDirCount;end;
if iDirNum = 0 then beginif B then beginMkDir(DDir + SQz + '1');DFileName := DDir + SQz + '1\' + ExtractFileName(SFileName);endelse beginMkDir(DDir + '1' + SQz);DFileName := DDir + '1' + SQz + '\' + ExtractFileName(SFileName);end;iFileNum := 1;endelse beginif not bSearch then beginif B theniFileCount := GetFileCount(DDir + SQz + IntToStr(iDirCount), SExt)elseiFileCount := GetFileCount(DDir + IntToStr(iDirCount) + SQz, SExt);iFileNum := iFileCount;bSearch := True;end;
if iFileNum >= MNum then beginif B then beginMkDir(DDir + SQz + IntToStr(iDirNum + 1));DFileName := DDir + SQz + IntToStr(iDirNum + 1) + '\' + ExtractFileName(SFileName)endelse beginMkDir(DDir + IntToStr(iDirNum + 1) + SQz);DFileName := DDir + IntToStr(iDirNum + 1) + SQz + '\' + ExtractFileName(SFileName);end;iDirNum := iDirNum + 1;iFileNum := 1;endelse beginif B thenDFileName := DDir + SQz + IntToStr(iDirNum) + '\' + ExtractFileName(SFileName)elseDFileName := DDir + IntToStr(iDirNum) + SQz + '\' + ExtractFileName(SFileName);iFileNum := iFileNum + 1;end;end;MoveFile(Handle, SFileName, DFileName);end;end;
//BMP格式图片转JPG格式procedure BMPToJPG(BmpFileName, JpegFileName: string);varjpeg: TJPEGImage;BMP: tBitmap;beginBMP := tBitmap.Create;tryBMP.LoadFromFile(BmpFileName);jpeg := TJPEGImage.Create;tryjpeg.Assign(BMP);jpeg.Compress;//保存图片jpeg.SaveToFile(JpegFileName);finallyjpeg.Free;end;finallyBMP.Free;end;end;
//灰度处理; 1表示取rgb的平均值 2表示取rgb的最大值// 3表示根据YUV求出Y分量procedure SetGray(SBmp, DBmp: tBitmap; iTag: integer);varx, y, Gray: integer;p: pByteArray;beginSBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);case iTag of1:for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginGray := (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 beginp := 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.114BGray := 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); //求灰度直方图varx, y, Gray, i, j, maxvalue: integer;p: pByteArray;bmp2: tBitmap;Color: TColor;beginBMP.PixelFormat := pf24Bit;for y := 0 to BMP.Height - 1 do beginp := 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 beginif 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 beginif 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 beginColor := RGB(i, i, i);for j := 0 to bmp2.Height do beginbmp2.canvas.Pixels[i, j] := Color;end;end;Image2.Picture.Bitmap.Assign(bmp2);bmp2.Free;end;
procedure SetTwo(SBmp, DBmp: tBitmap); //二值化varx, y, Gray: integer;p: pByteArray;beginSBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);randomize;for y := 0 to DBmp.Height - 1 do beginp := 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} beginp[x * 3] := 255;p[x * 3 + 1] := 255;p[x * 3 + 2] := 255;endelse beginp[x * 3] := 0;p[x * 3 + 1] := 0;p[x * 3 + 2] := 0;end;end;end;end;
procedure SetBright(SBmp, DBmp: tBitmap); //亮度调节varx, y: integer;p: pByteArray;begin//24位真彩色SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);randomize;for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do begin//每个象素点的R、G、B分量进行调节beginp[x * 3] := Min(255, p[x * 3] + 20); //不能越界,限制在0~255p[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); //对比度varx, y: integer;p: pByteArray;begin//24位真彩色SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);randomize;for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do begin//确定阀值为128if (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 beginp[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 beginp[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); //饱和度varx, y: integer;p: pByteArray;begin//24位真彩色SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);randomize;for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginif p[x * 3] > 128 then beginp[x * 3] := p[x * 3] + 15;endelse beginp[x * 3] := p[x * 3] - 15;end;end;
if p[x * 3 + 1] > 128 then beginp[x * 3 + 1] := p[x * 3 + 1] + 15;endelse beginp[x * 3 + 1] := p[x * 3 + 1] - 15;end;if p[x * 3 + 2] > 128 then beginp[x * 3 + 2] := p[x * 3 + 2] + 15;endelsep[x * 3 + 2] := p[x * 3 + 2] - 15;end;end;
procedure SetColor(aSource, ATarget: tBitmap; AColor: TColor); //图像着色vari, j: integer;S, t: pRGBTriple;R, G, B: Byte;cl: TColor;begincl := 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 beginS := 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); //图像曝光varx, y: integer;p: pByteArray;begin//24位真彩色SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);randomize;for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginif p[x * 3] < 128 thenp[x * 3] := not p[x * 3]; { TODO : 各分量取反 }if p[x * 3 + 1] < 128 thenp[x * 3 + 1] := not p[x * 3 + 1];if p[x * 3 + 2] < 128 thenp[x * 3 + 2] := not p[x * 3 + 2];end;end;end;
procedure SetGamma(SBmp, DBmp: tBitmap); //Gamma校正varx, 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 beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginB := 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)));endend;end;
procedure SetNoise(SBmp, DBmp: tBitmap); //噪声调节varx, 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 beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginR := 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;vari, j, bmpheight, bmpwidth: 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 beginImageUnShifted := SBmp.ScanLine[OriginalY];ImageShifted[i] := ImageUnShifted[OriginalX];endelse{//如果算出的点不在原图有效范围,则象素点的颜色设置为白色} beginImageShifted[i].rgbtBlue := 255;ImageShifted[i].rgbtGreen := 255;ImageShifted[i].rgbtRed := 255;endendend;end;
procedure LeftRightMirror(SBmp, DBmp: tBitmap); //水平镜像varbmp1, bmp2: tBitmap;t, p: pByteArray;x, y: integer;beginbmp1 := 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 begint := bmp2.ScanLine[y];p := bmp1.ScanLine[y];for x := 0 to bmp2.Width - 1 do beginp[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); //任意角度旋转varc1x, c1y, c2x, c2y: integer;p1x, p1y, p2x, p2y: integer;radius, n: integer;alpha: extended;c0, C1, C2, c3: TColor;beginif SBmp.Width > SBmp.Height then beginDBmp.Width := SBmp.Width;DBmp.Height := SBmp.Width;endelseDBmp.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;// 步骤数值numberif c2x < c2y thenn := c2yelsen := c2x;Dec(n, 1);// 开始旋转for p2x := 0 to n do beginfor p2y := 0 to n do beginif p2x = 0 thenalpha := PI / 2elsealpha := 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.ProcessMessagesend;end;
procedure TwistPicture(BMP, Dst: tBitmap; Amount: integer); //图像的扭曲varfxmid, 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;beginif xt = 0 thenif yt > 0 thenResult := PI / 2elseResult := -(PI / 2)else beginResult := ArcTan(yt / xt);if xt < 0 thenResult := PI + ArcTan(yt / xt);end;end;
beginOFFSET := -(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 rotationtymid := (BMP.Height - 1) / 2; //Adjust these to move ......fxmid := (BMP.Width - 1) / 2;fymid := (BMP.Height - 1) / 2;if tx2 >= BMP.Width thentx2 := BMP.Width - 1;if ty2 >= BMP.Height thenty2 := BMP.Height - 1;for ty := 0 to Round(ty2) do beginfor tx := 0 to Round(tx2) do begindx := tx - txmid;dy := ty - tymid;R := Sqrt(dx * dx + dy * dy);if R = 0 then beginfx := 0;fy := 0;endelse begintheta := 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 beginweight_y[1] := fy - ify;weight_y[0] := 1 - weight_y[1];endelse beginweight_y[0] := -(fy - ify);weight_y[1] := 1 - weight_y[0];end;if fx >= 0 then beginweight_x[1] := fx - ifx;weight_x[0] := 1 - weight_x[1];endelse beginweight_x[0] := -(fx - ifx);weight_x[1] := 1 - weight_x[0];end;
if ifx < 0 thenifx := BMP.Width - 1 - (-ifx mod BMP.Width)else if ifx > BMP.Width - 1 thenifx := ifx mod BMP.Width;if ify < 0 thenify := BMP.Height - 1 - (-ify mod BMP.Height)else if ify > BMP.Height - 1 thenify := ify mod BMP.Height;
total_red := 0.0;total_green := 0.0;total_blue := 0.0;for ix := 0 to 1 do beginfor iy := 0 to 1 do beginif ify + iy < BMP.Height thensli := BMP.ScanLine[ify + iy]elsesli := BMP.ScanLine[BMP.Height - ify -iy];if ifx + ix < BMP.Width then beginnew_red := sli[(ifx + ix) * 3];new_green := sli[(ifx + ix) * 3 + 1];new_blue := sli[(ifx + ix) * 3 + 2];endelse beginnew_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 : 扭曲 }varTmp, BMP: tBitmap;i, j, XSrc, YSrc: integer;starttime, endtime: Cardinal;beginif (YDIV = 0) or (XDIV = 0) thenexit;starttime := GetTickCount;for i := 0 to SBmp.Width - 1 do beginfor j := 0 to SBmp.Height - 1 do beginXSrc := Round(i + RatioVal * Sin(j / YDIV));YSrc := Round(j + RatioVal * Sin(i / XDIV));if XSrc < 0 thenXSrc := SBmp.Width - 1 - (-XSrc mod SBmp.Width)else if XSrc >= SBmp.Width thenXSrc := XSrc mod SBmp.Width;if YSrc < 0 thenYSrc := SBmp.Height - 1 - (-YSrc mod SBmp.Height)else if YSrc >= SBmp.Height thenYSrc := 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);constclBackColor = clBlack;BestQuality = True;vary, xWidthDiff, xWidthCurrentLine: integer;d: Real;beginOutBitmap.PixelFormat := InBitmap.PixelFormat;if WidthTop > WidthBottom thenOutBitmap.Width := WidthTopelseOutBitmap.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);endelse{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 beginxWidthCurrentLine := 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;beginR := 0;G := 0;B := 0;if (h < 360) and (h >= 0) and (S <= 100) and (S >= 0) and (L <= 100) and (L>=0) then beginif h <= 60 then beginR := 255;G := Round((255 / 60) * h);B := 0;endelse if h <= 120 then beginR := Round(255 - (255 / 60) * (h - 60));G := 255;B := 0;endelse if h <= 180 then beginR := 0;G := 255;B := Round((255 / 60) * (h - 120));endelse if h <= 240 then beginR := 0;G := Round(255 - (255 / 60) * (h - 180));B := 255;endelse if h <= 300 then beginR := Round((255 / 60) * (h - 240));G := 0;B := 255;endelse if h < 360 then beginR := 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 beginR := Round(R + ((255 - R) * Lum));G := Round(G + ((255 - G) * Lum));B := Round(B + ((255 - B) * Lum));endelse if Lum < 0 then beginR := 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空间的转换varDelta: Double;CMax, CMin: Double;Red, Green, Blue, Hue, Sat, Lum: Double;beginRed := 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 beginSat := 0;Hue := 0;endelse beginif Lum < 0.5 thenSat := (CMax - CMin) / (CMax + CMin)elseSat := (CMax - CMin) / (2 - CMax - CMin);Delta := CMax - CMin;if Red = CMax thenHue := (Green - Blue) / Deltaelse if Green = CMax thenHue := 2 + (Blue - Red) / DeltaelseHue := 4.0 + (Red - Green) / Delta;Hue := Hue / 6;if Hue < 0 thenHue := Hue + 1;end;h := Round(Hue * 360);S := Round(Sat * 100);L := Round(Lum * 100);end;
procedure HSLBright(SBmp, DBmp: tBitmap); //基于HSL颜色系统的S亮度调节varx, 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 beginfor 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颜色系统的饱和度调节varx, 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 beginfor 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颜色系统的转换beginwith RGB do beginC := 255 - rgbtRed;M := 255 - rgbtGreen;y := 255 - rgbtBlue;end;end;
procedure RGBTripleToCMYK(const RGB: TRGBTriple; var C, M, y, K: integer); //RGB到CMYK颜色系统的转换beginRGBTripleToCMY(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;beginwith Result do beginrgbtRed := 255 - C;rgbtGreen := 255 - M;rgbtBlue := 255 - y;end;end;
function CMYKToRGBTriple(const C, M, y, K: integer): TRGBTriple;beginwith Result do beginrgbtRed := 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颜色系统的转换varDelta: integer;Min: integer;beginwith RGB do beginMin := MinIntValue([rgbtRed, rgbtBlue, rgbtGreen]);V := MaxIntValue([rgbtRed, rgbtBlue, rgbtGreen]);end;Delta := V - Min;if V = 0 thenS := 0elseS := MulDiv(Delta, 255, V);
if S = 0 thenh := 0else beginwith RGB do beginif rgbtRed = V thenh := MulDiv(rgbtGreen - rgbtBlue, 60, Delta)else if rgbtGreen = V thenh := 120 + MulDiv(rgbtBlue - rgbtRed, 60, Delta)else if rgbtRed = V thenh := 240 + MulDiv(rgbtRed - rgbtGreen, 60, Delta);end;if h < 0 thenh := h + 360;end;end;
function HSVToRGBTriple(const h, S, V: integer): TRGBTriple;constdivisor: integer = 255 * 60;varf, hTemp, p, q, t, VS: integer;beginif S = 0 thenResult := RGBToRGBTriple(V, V, V)else beginif h = 360 thenhTemp := 0elsehTemp := 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 of0: 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);elseResult := RGBToRGBTriple(0, 0, 0);end;end;end;
function RGBToRGBTriple(R, G, B: integer): TRGBTriple;beginResult.rgbtRed := R;Result.rgbtGreen := G;Result.rgbtBlue := B;end;
procedure GetRedChannel(SBmp, DBmp: tBitmap); //获得红色通道varp: pByteArray;x, y: integer;begin//加载位图SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginp[x * 3] := 0;p[x * 3 + 1] := 0;end;end;end;
procedure GetBlueChannel(SBmp, DBmp: tBitmap); //获得蓝色通道varp: pByteArray;x, y: integer;begin//加载位图SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginp[x * 3 + 1] := 0;p[x * 3 + 2] := 0;end;end;end;
procedure GetGreenChannel(SBmp, DBmp: tBitmap); //获得绿色通道varp: pByteArray;x, y: integer;begin//加载位图SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginp[x * 3] := 0;p[x * 3 + 2] := 0;end;end;end;
procedure GetCChannel(SBmp, DBmp: tBitmap); //获得C通道varp: pByteArray;x, y: integer;begin//加载位图SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginp[x * 3 + 2] := 0;end;end;end;
procedure GetMChannel(SBmp, DBmp: tBitmap); //获得M通道varp: pByteArray;x, y: integer;begin//加载位图SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginp[x * 3 + 1] := 0;end;end;end;
procedure GetYChannel(SBmp, DBmp: tBitmap); //获得Y通道varp: pByteArray;x, y: integer;begin//加载位图SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do beginp[x * 3] := 0;end;end;end;
procedure RGBAdjust(SBmp, DBmp: tBitmap); //RGB颜色调整varx, y, ScanlineBytes: integer;p: pByteArray;begin//加载位图SBmp.PixelFormat := pf24Bit;DBmp.Assign(SBmp);for y := 0 to DBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to DBmp.Width - 1 do begin//红色分量增加beginif p[x * 3 + 2] < 245 then beginp[x * 3 + 2] := p[x * 3 + 2] + 30;end;end;//红色分量减少beginif p[x * 3 + 2] > 10 then beginp[x * 3 + 2] := p[x * 3 + 2] - 10;end;end;end;{ //绿色分量增加beginif p[x * 3 + 1] < 245 thenbeginp[x * 3 + 1] := p[x * 3 + 1] + 10;end;end;//绿色分量减小beginif p[x * 3 + 1] > 10 thenbeginp[x * 3 + 1] := p[x * 3 + 1] - 10;end;end; }//蓝色分量增加{beginif p[x * 3] < 245 thenbeginp[x * 3] := p[x * 3] + 20;end;end;//蓝色分量减小beginif p[x * 3] > 10 thenbeginp[x * 3] := p[x * 3] - 10;end;end; }//指针递增end;end;
procedure PaintRainbow(Dc: hDc; x, y, Width, Height: integer;bVertical, WrapToRed: BOOL);vari: 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 thenChunks := 5elseChunks := 6;ChunksMinus1 := Chunks - 1;if bVertical = False thenColorChunk := Width div ChunkselseColorChunk := Height div Chunks;
{Red To Yellow}R := 255;B := 0;for i := 0 to ColorChunk do beginG := (255 div ColorChunk) * i;OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));if bVertical = False thenPatBlt(Dc, i, 0, 1, Height, PatCopy)elsePatBlt(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 beginR := 255 - (255 div ColorChunk) * (i - ColorChunk);OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));if bVertical = False thenPatBlt(Dc, i, 0, 1, Height, PatCopy)elsePatBlt(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 beginB := (255 div ColorChunk) * (i - ColorChunk * 2);OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));if bVertical = False thenPatBlt(Dc, i, 0, 1, Height, PatCopy)elsePatBlt(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 beginG := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));if bVertical = False thenPatBlt(Dc, i, 0, 1, Height, PatCopy)elsePatBlt(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 beginR := (255 div ColorChunk) * (i - ColorChunk * 4);OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));if bVertical = False thenPatBlt(Dc, i, 0, 1, Height, PatCopy)elsePatBlt(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 beginB := 255 - ((255 div ColorChunk) * (i - ColorChunk * 5));OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));if bVertical = False thenPatBlt(Dc, i, 0, 1, Height, PatCopy)elsePatBlt(Dc, 0, i, Width, 1, PatCopy);DeleteObject(SelectObject(Dc, OldBrush));end;end;
{Fill Remainder}if (Width - (ColorChunk * Chunks) - 1) > 0 then beginif WrapToRed <> False then beginR := 255;G := 0;B := 0;endelse beginR := 255;G := 0;B := 255;end;OldBrush := SelectObject(Dc, CreateSolidBrush(RGB(R, G, B)));if bVertical = False thenPatBlt(Dc, ColorChunk * Chunks, 0, Width - (ColorChunk * Chunks), Height,PatCopy)elsePatBlt(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);varFromR, FromG, FromB: integer;DiffR, DiffG, DiffB: integer;
i: integer;bm: tBitmap;ColorRect: TRect;R, G, B: Byte;
//for ellipticalPw, Ph: Real;x0, y0, x1, y1, x2, y2, x3, y3: Real;points: array[0..3] of TPoint;haf: integer;
begin//set bitmapbm := tBitmap.Create;bm.Width := ARect.right;bm.Height := ARect.bottom;
//calc colorsFromR := fromCol and $000000FF; //Strip out separate RGB valuesFromG := (fromCol shr 8) and $000000FF;FromB := (fromCol shr 16) and $000000FF;DiffR := (toCol and $000000FF) - FromR; //Find the differenceDiffG := ((toCol shr 8) and $000000FF) - FromG;DiffB := ((toCol shr 16) and $000000FF) - FromB;
//draw gradientcase grdType ofrgsHorizontal: beginColorRect.top := 0; //Set rectangle topColorRect.bottom := bm.Height;for i := 0 to 255 do begin //Make lines (rectangles) of colorColorRect.left := MulDiv(i, bm.Width, 256);//Find left for this colorColorRect.right := MulDiv(i + 1, bm.Width, 256); //Find RightR := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := FromG + MulDiv(i, DiffG, 255);B := FromB + MulDiv(i, DiffB, 255);bm.canvas.Brush.Color := RGB(R, G, B);//Plug colors into brushbm.canvas.FillRect(ColorRect); //Draw on Bitmapend;
end;rgsVertical: beginColorRect.left := 0; //Set rectangle left&rightColorRect.right := bm.Width;for i := 0 to 255 do begin //Make lines (rectangles) of colorColorRect.top := MulDiv(i, bm.Height, 256);//Find top for this colorColorRect.bottom := MulDiv(i + 1, bm.Height, 256);//Find BottomR := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := FromG + MulDiv(i, DiffG, 255);B := FromB + MulDiv(i, DiffB, 255);bm.canvas.Brush.Color := RGB(R, G, B);//Plug colors into brushbm.canvas.FillRect(ColorRect); //Draw on Bitmapend;
end;rgsElliptic: beginbm.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 colorx1 := x1 + Pw;x2 := x2 - Pw;y1 := y1 + Ph;y2 := y2 - Ph;R := FromR + MulDiv(i, DiffR, 155); //Find the RGB valuesG := 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 brushbm.canvas.Ellipse(Trunc(x1), Trunc(y1), Trunc(x2),Trunc(y2));end;end;
rgsRectangle: beginbm.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 colorx1 := x1 + Pw;x2 := x2 - Pw;y1 := y1 + Ph;y2 := y2 - Ph;R := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := FromG + MulDiv(i, DiffG, 255);B := FromB + MulDiv(i, DiffB, 255);bm.canvas.Brush.Color := RGB(R, G, B);//Plug colors into brushbm.canvas.FillRect(rect(Trunc(x1), Trunc(y1), Trunc(x2),Trunc(y2)));end;end;
rgsVerticalCenter: beginhaf := bm.Height div 2;ColorRect.left := 0;ColorRect.right := bm.Width;for i := 0 to haf do beginColorRect.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: beginhaf := bm.Width div 2;ColorRect.top := 0;ColorRect.bottom := bm.Height;for i := 0 to haf do beginColorRect.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: beginbm.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 colorx0 := i * Pw;if (x0 < bm.Width) theny0 := 0else beginy0 := x0 - bm.Width;x0 := bm.Width - 1;end;x1 := (i + 1) * Pw;if (x1 < bm.Width) then beginy1 := 0;endelse beginy1 := x1 - bm.Width;x1 := bm.Width - 1;end;y2 := i * Pw;if (y2 < bm.Height) thenx2 := 0else beginx2 := y2 - bm.Height;y2 := bm.Height - 1;end;y3 := (i + 1) * Pw;if (y3 < bm.Height) thenx3 := 0else beginx3 := y3 - bm.Height;y3 := bm.Height - 1;end;R := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := FromG + MulDiv(i, DiffG, 255);B := FromB + MulDiv(i, DiffB, 255);bm.canvas.Brush.Color := RGB(R, G, B);//Plug colors into brushpoints[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: beginbm.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 colory0 := i * Pw;if (y0 < bm.Height) thenx0 := bm.Width - 1else beginx0 := bm.Width - 1 - (y0 - bm.Height);y0 := bm.Height - 1;end;y1 := (i + 1) * Pw;if (y1 < bm.Height) thenx1 := bm.Width - 1else beginx1 := bm.Width - 1;end;x2 := bm.Width - 1 - (i * Pw);if (x2 > 0) theny2 := 0else beginy2 := -x2;x2 := 0;end;x3 := bm.Width - 1 - ((i + 1) * Pw);if (x3 > 0) theny3 := 0else beginy3 := -x3;x3 := 0;end;R := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := FromG + MulDiv(i, DiffG, 255);B := FromB + MulDiv(i, DiffB, 255);bm.canvas.Brush.Color := RGB(R, G, B);//Plug colors into brushpoints[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: beginbm.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 colory0 := bm.Height - 1 - (i * Pw);if (y0 > 0) thenx0 := bm.Width - 1else beginx0 := bm.Width - 1 + y0;y0 := 0;end;y1 := bm.Height - 1 - ((i + 1) * Pw);if (y1 > 0) thenx1 := bm.Width - 1else beginx1 := bm.Width - 1 + y1;y1 := 0;end;x2 := bm.Width - 1 - (i * Pw);if (x2 > 0) theny2 := bm.Height - 1else beginy2 := bm.Height - 1 + x2;x2 := 0;end;x3 := bm.Width - 1 - ((i + 1) * Pw);if (x3 > 0) theny3 := bm.Height - 1else beginy3 := bm.Height - 1 + x3;x3 := 0;end;R := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := FromG + MulDiv(i, DiffG, 255);B := FromB + MulDiv(i, DiffB, 255);bm.canvas.Brush.Color := RGB(R, G, B);//Plug colors into brushpoints[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: beginbm.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 colory0 := bm.Height - 1 - (i * Pw);if (y0 > 0) thenx0 := 0else beginx0 := -y0;y0 := 0;end;y1 := bm.Height - 1 - ((i + 1) * Pw);if (y1 > 0) thenx1 := 0else beginx1 := -y1;y1 := 0;end;x2 := (i * Pw);if (x2 < bm.Width) theny2 := bm.Height - 1else beginy2 := bm.Height - 1 - (x2 - bm.Width);x2 := bm.Width - 1;end;x3 := (i + 1) * Pw;if (x3 < bm.Width) theny3 := bm.Height - 1else beginy3 := bm.Height - 1 - (x3 - bm.Width);x3 := bm.Width - 1;end;R := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := FromG + MulDiv(i, DiffG, 255);B := FromB + MulDiv(i, DiffB, 255);bm.canvas.Brush.Color := RGB(R, G, B);//Plug colors into brushpoints[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: beginbm.canvas.Pen.Style := psClear;bm.canvas.Pen.Mode := pmCopy;for i := 0 to 255 do beginx1 := 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 valuesG := 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: beginbm.canvas.Pen.Style := psClear;bm.canvas.Pen.Mode := pmCopy;for i := 0 to 255 do beginx1 := MulDiv(i, bm.Width, 255);y1 := MulDiv(i, bm.Height, 255);
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := 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: beginbm.canvas.Pen.Style := psClear;bm.canvas.Pen.Mode := pmCopy;for i := 0 to 255 do beginx1 := MulDiv(i, bm.Width div 2, 255);y1 := MulDiv(i, bm.Height div 2, 255);
R := FromR + MulDiv(i, DiffR, 255); //Find the RGB valuesG := 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);varp: PRGBTripleArray;x, y, ScanlineBytes: integer;//扫描线之间得间距Gray: Byte;beginSBmp.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 beginGray := Byte((p[x].rgbtRed * 55 + p[x].rgbtGreen * 151+ p[x].rgbtBlue * 28) shr 8);//求出灰度信息if Gray < 80 then beginGray := Gray div 2 + 20;//这里自定义线性变化endelse if (Gray < 160) and (Gray > 80) then beginGray := Gray + 30;//不同的灰度分布进行不同的调整endelse beginGray := 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);varp: PRGBTripleArray;//定义一个pRGBTripleArray类型x, y, ScanlineBytes: integer;//扫描线间距BMP: tBitmap;//位图对像Gray: integer;//灰度beginSBmp.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 beginGray := ((p[x].rgbtRed * 55 + p[x].rgbtGreen * 151+ p[x].rgbtBlue * 28) shr 8);//避免浮点数运算if Gray < 80 then beginGray := Round(log10(power(8, Gray)));end//指数,对数混合运算else if (Gray < 160) and (Gray > 80) then beginGray := Round(log10(power(8, Gray))) + 20;//自定义的混合运算endelse beginGray := 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);varp: pByteArray;// PbyteArray类型x, y, i, j: integer;BMP: tBitmap;Gray: Byte;ScanlineBytes: integer;//扫描线间距beginBMP := tBitmap.Create;//创建实例BMP.Assign(SBmp);BMP.PixelFormat := pf24Bit;//24bit位图p := BMP.ScanLine[0];//首行扫描线信息for i := 0 to 255 do beginGrayclass[i] := 0;//初始化数组为0end;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 beginGray := Round(p[x * 3 + 2] * 0.3 + p[x * 3 + 1] * 0.59 + p[x* 3]* 0.11);//求取灰度值for i := 0 to 255 do beginif Gray = i then beginGrayclass[i] := Grayclass[i] + 1;//每级灰度象素点数end;end;end;inc(integer(p), ScanlineBytes);//指针增加,增加得其实是一个负值end;BMP.Free;//释放资源for i := 0 to 255 do beginif Grayclass[i] <> 0 then beginOriginalRangeLeft := i;break;//获取最大灰度级end;end;for j := 255 downto 0 do beginif Grayclass[j] <> 0 then beginOriginalRangeRight := j;break;//获取最小灰度级end;end;end;
varp: pByteArray;x, y: integer;BMP: tBitmap;Gray: Byte;ScanlineBytes: integer;ScaleFactor: Real;beginGetParam(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 beginfor x := 0 to DBmp.Width - 1 do beginGray := 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); //图像锐化varbmp1: tBitmap;p1, p2, p3, p4: pByteArray;//定义四个pbytearray类型变量i, j, z: integer;y: array[0..8] of integer;beginy[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 beginp1 := 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]))divz));//重新算出红色分量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]))divz));//重新算出蓝色分量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); //图像平滑varbmp1: tBitmap;p1, p2, p3, p4: pByteArray;i, j, z: integer;y: array[0..8] of integer;beginy[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 beginp1 := 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 beginp1[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]))divz));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]))divz));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); //伪彩色增强varBMP: tBitmap;//位图对象Gray, maxgray: integer;i, j: integer;p1, p2: pByteArray;img: array of array of integer;constColorTable: 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 beginp1 := 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];//初始化maxGrayfor i := 0 to High(img) do beginfor j := 0 to High(img[0]) do beginif maxgray < img[i][j] then beginmaxgray := img[i][j];//算出最大灰度值end;end;end;//转为16级灰度for i := 0 to DBmp.Height - 1 do beginp2 := DBmp.ScanLine[i];for j := 0 to DBmp.Width - 1 do beginGray := 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); //中值滤波varbmp1: 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); //二值化varx, y: integer;p: pByteArray;Gray: Byte;beginDBmp.PixelFormat := SBmp.PixelFormat;DBmp.Assign(SBmp);for y := 0 to SBmp.Height - 1 do beginp := DBmp.ScanLine[y];for x := 0 to SBmp.Width - 1 do beginGray := Round(0.299 * p[3 * x + 2] + 0.587 * p[3 * x + 1] + 0.11* p[3 * x]);// 灰化的计算公式if (Gray > 128) thenGray := 255elseGray := 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; //腐蚀varx, y: integer;p, q, R, O: pByteArray;begin//动态创建位图DBmp.Assign(SBmp);// Horic标志是水平方向还是竖直方向腐蚀if (Horic) then beginfor y := 1 to DBmp.Height - 2 do beginO := 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 beginif ((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 beginO[3 * x] := 255;O[3 * x + 1] := 255;O[3 * x + 2] := 255;//// 将满足条件的黑色点置为白色end;end;end;end;endelse beginfor y := 1 to DBmp.Height - 2 do beginO := 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 beginif (((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 beginO[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;varX, Y: integer;O, P, Q, R: pByteArray;newbmp: TBitmap;beginDBmp.Assign(SBmp);Hori := True;if (Hori) thenbeginfor Y := 1 to DBmp.Height - 2 dobeginO := SBmp.ScanLine[Y];P := DBmp.ScanLine[Y - 1];Q := DBmp.ScanLine[Y];R := DBmp.ScanLine[Y + 1];for X := 1 to DBmp.Width - 2 dobeginif ((O[3 * X] = 255) and (O[3 * X + 1] = 255) and (O[3 * X+ 2] = 255)) thenbeginif (((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))) thenbeginO[3 * X] := 0;O[3 * X + 1] := 0;O[3 * X + 2] := 0;end;
end;end;end;endelsefor Y := 1 to DBmp.Height - 2 dobeginO := SBmp.ScanLine[Y];Q := DBmp.ScanLine[Y];for X := 1 to DBmp.Width - 2 dobeginif ((O[3 * X] = 255) and (O[3 * X + 1] = 255) and (O[3 * X+ 2] = 255)) thenbeginif (((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))) thenO[3 * X] := 0;O[3 * X + 1] := 0;O[3 * X + 2] := 0;end;end;end;result := True;end;
procedure GetLunkuo(SBmp,DBmp: TBitmap); //轮廓提取varb0: Tbitmap;i, j: Integer;p1, p2, p3, p4: pbyteArray;beginb0:= Tbitmap.Create;b0.Assign(SBmp);DBmp.Assign(SBmp);DBmp.PixelFormat := pf24bit;b0.PixelFormat := pf24bit;for i := 1 to b0.Height - 2 dobeginp1 := b0.ScanLine[i - 1];p2 := b0.ScanLine[i];p3 := b0.ScanLine[i + 1];p4 := DBmp.ScanLine[i];for j := 1 to b0.Width - 2 dobeginif (p2[3 * j + 2] = 0) and (p2[3 * j + 1] = 0) and (p2[3 * j] = 0) thenbeginif ((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)) thenbeginp4[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; //细化varX, Y: integer;O, T, C, B: pRGBArray;nb: array[1..3, 1..3] of integer;c1, c2, c3, c4: boolean;ncount: integer;begin// Create bmpDBmp.Assign(SBmp);// 获取bitmap 赋给bmpfor Y := 1 to DBmp.Height - 2 dobeginO := DBmp.ScanLine[Y];T := SBmp.ScanLine[Y - 1];C := SBmp.ScanLine[Y];B := SBmp.ScanLine[Y + 1];for X := 1 to DBmp.Width - 2 dobeginc1 := 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) thenc1 := True;//condition1ncount := 0;if (nb[1, 1] = 0) and (nb[1, 2] = 1) theninc(ncount);if (nb[1, 2] = 0) and (nb[1, 3] = 1) theninc(ncount);if (nb[1, 3] = 0) and (nb[2, 3] = 1) theninc(ncount);if (nb[2, 3] = 0) and (nb[3, 3] = 1) theninc(ncount);if (nb[3, 3] = 0) and (nb[3, 2] = 1) theninc(ncount);if (nb[3, 2] = 0) and (nb[3, 1] = 1) theninc(ncount);if (nb[3, 1] = 0) and (nb[2, 1] = 1) theninc(ncount);if (nb[2, 1] = 0) and (nb[1, 1] = 1) theninc(ncount);if ncount = 1 thenc2 := true;//condition2if (nb[1, 2] * nb[3, 2] * nb[2, 3] = 0) thenc3 := true;// condition3if (nb[2, 1] * nb[2, 3] * nb[3, 2] = 0) thenc4 := true;//condition4if (c1 and c2 and c3 and c4) thenbeginO[X].rgbtRed := 255;O[X].rgbtGreen := 255;O[X].rgbtBlue := 255;//设置O[X]为白色end;end;end;//释放bmpResult := True;// 返回值为boolean,True表示细化成功end;
procedure SetSobel(SBmp,DBmp: TBitmap); //边沿检测varbmp1: Tbitmap;// 临时位图p1, p3, p2, p4: pByteArray;i, j: integer;r, g, b: Byte;begin
//采用双缓冲模式bmp1 :=TBitmap.Create;//Create bmp1,bmp2DBmp.Assign(SBmp);DBmp.PixelFormat := pf24bit;//设置位图格式bmp1.Assign(DBmp);bmp1.PixelFormat := pf24bit;for j := 1 to DBmp.Height - 2 dobeginp1 := DBmp.ScanLine[j];p2 := bmp1.ScanLine[j - 1];p3 := bmp1.ScanLine[j];p4 := bmp1.ScanLine[j + 1];for i := 1 to DBmp.Width - 2 dobeginr := 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边沿检测varbmp1: Tbitmap;p1, p3, p2, p4: pbytearray;i, j: integer;r, g, b: integer;beginbmp1 := Tbitmap.Create;DBmp.Assign(SBmp);DBmp.PixelFormat := pf24bit;bmp1.Assign(DBmp);bmp1.PixelFormat := pf24bit;for j := 1 to bmp1.Height - 2 dobeginp1 := DBmp.ScanLine[j]; //采用sobal边缘算子 // -1 -1 -1// 0 0 0p2 := bmp1.ScanLine[j - 1]; // 1 1 1p3 := bmp1.ScanLine[j]; //和算子 取较大的输出p4 := bmp1.ScanLine[j + 1]; //1 0 -1for i := 1 to DBmp.Width - 2 do {1 0 -1}begin //1 0 -1r := 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)]))));
beginp1[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); //竖直投影varX, Y, i, j: integer;P, Q: pByteArray;number: integer;begin// 动态创建TBitmap对象DBmp.Width := SBmp.Width;DBmp.Height := SBmp.Height;//原位图的高度和宽度赋给新的位图DBmp.Assign(SBmp);// 拷贝位图到newbmpif (Horic) then //Horic为真表示进行竖直投影beginfor Y := 0 to SBmp.Height - 1 dobeginP := DBmp.ScanLine[Y];Q := SBmp.ScanLine[Y];number := 0;// 设置每一行扫描的初值for X := 0 to SBmp.Width - 1 dobeginif ((Q[3 * X + 2] = 255) and (Q[3 * X + 1] = 255) and (Q[3* X] = 255)) thennumber := number + 1;// 统计每一行的白色点的数目,记录为numberend;for i := 0 to number dobeginP[3 * i] := 0;P[3 * i + 1] := 0;P[3 * i + 2] := 0;end;// 从左边开始,给一行number个像素点涂上黑色for j := number to SBmp.Width - 1 dobeginP[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变换varO, T, C, B: pRGBArray; //scanlinesx, y: integer;tBufr: TBitmap;begintBufr := TBitmap.Create;SBmp.PixelFormat :=pf24bit;DBmp.Assign(SBmp);// 创建临时位图象tBufr.Assign(SBmp);// 拷贝图象for x := 1 to DBmp.Height - 2 dobeginO := 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 pixelsbeginO[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;varIdStack: TIdStack;beginIdStack := TIdStack.Create;Result :=IdStack.IsIP(str);IdStack.Free;end;
procedure GetLinks(doc:IHTMLDocument2;var tsr:TStringList);varall:IHTMLElementCollection;len,i:integer;item: OleVariant;beginall :=doc.Get_Links;len := all.length;for i := 0 to len - 1 dobeginitem := all.item(i, varempty);tsr.add(item.href);end;//调用如下{vardoc: IHTMLDocument2;tsr:TStringList;begindoc := 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;//如果取消取返回为空,否则返回选中的路径varInfo: TBrowseInfo;IDList: pItemIDList;Buffer: PChar;beginresult := '';Buffer := StrAlloc(MAX_PATH);with Info dobeginhwndOwner := 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 thenbeginSHGetPathFromIDList(IDList, Buffer); //将目录信息转化为路径字符串result := strpas(Buffer);end;StrDispose(buffer);end;
procedure CreateLink(ExePath,LinkName: WideString); //创建快捷方式vartmpObject: IUnknown;tmpSLink: IShellLink;tmpPFile: IPersistFile;PIDL: PItemIDList;StartupDirectory: array[0..MAX_PATH] of Char;StartupFilename: string;LinkFilename: WideString;beginStartupFilename := 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); //获得桌面的ItemidlistSHGetPathFromIDList(PIDL,StartupDirectory); //获得桌面路径LinkFilename := StartupDirectory;LinkFilename :=LinkFilename+'\'+LinkName+'.lnk';tmpPFile.Save(pWChar(LinkFilename), FALSE); //保存*.lnk文件end;
//列举串口procedure EnumPorts( PortList: TStrings );varMaxPorts : integer;hPort : THandle;PortNumber : integer;PortName : string;beginif PortList = nil then EXIT;case Win32PlatForm ofVER_PLATFORM_WIN32_NT: MaxPorts := 256;VER_PLATFORM_WIN32_WINDOWS: MaxPorts := 9;end;for PortNumber := 1 to MaxPorts dobeginif PortNumber > 9 thenPortName := '\\.\COM' + IntToStr( PortNumber )elsePortName := 'COM' + IntToStr( PortNumber );hPort := CreateFile( PChar( PortName ),GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,0,0 );if not ( hPort = INVALID_HANDLE_VALUE ) thenPortList.Add( PortName );CloseHandle( hPort );end;end;
procedure CloseWindow(Flag:TShutReboot); //关闭计算机或重启varhToken:THandle;tkp,tkDumb:TTokenPrivileges;DumbInt:DWORD;beginif Win32Platform=VER_PLATFORM_WIN32_NT thenbeginFillChar(tkp,SizeOf(tkp),0);if (OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,hToken)) thenbeginLookupPrivilegeValue(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 ofReboot: 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;
initializationOleInitialize(nil);finalizationOleUninitialize;
end.
http://blog.csdn.net/djcsch2001/archive/2008/09/10/2910913.aspx |
|
|