公开 myfunctions 单元，里面有很多有用的函数_functions.getclockangle-优快云博客

本文分享了一套Delphi编程中的实用技巧与自定义组件单元，包括界面绘制、字符串处理、文件操作等功能，提供了丰富的示例代码，适用于Delphi开发者提升编程效率。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

应部分网友要求，公开 myfunctions 单元，里面有很多有用的函数
unit myFunctions;
//---------- 说明--------------
// by 冯思锐最后修改2010-11-23
// QQ: fengsirui@sina.com
// 部分代码来自互联网，大部分为自己所写
// 博客：http://blog.sina.com.cn/fsr2009
// 有一个函数 DrawChorkSoft（背景水印）需要引用cnGraphics，cnPack里面的一个单元，开源的可以在网上下载。
interface

uses Windows, SysUtils, Graphics, StrUtils, Classes, DateUtils, Dialogs,
Controls, forms, messages, Registry, stdCtrls, ExtCtrls, Buttons,
Variants, TypInfo, ComCtrls, wininet, WinSock, shellApi, ComObj,ActiveX,
imgList, shlObj, cnGraphics, Menus, commCtrl, mmSystem;
Const
C1 = 52845;
C2 = 22719;
CM_CLOSEUP = WM_USER+0;
CM_FLASHWINDOW = WM_USER+1;
DEFAULT_DELIMITERS = ['^', #9, #10, #13];
CS_SHADOW = $00020000;
CM_VALIDATE = WM_USER+1;

const
TOOLTIPS_CLASS = 'tooltips_class32';
TTS_ALWAYSTIP = $01;
TTS_NOPREFIX = $02;
TTS_BALLOON = $40;
TTF_SUBCLASS = $0010;
TTF_TRANSPARENT = $0100;
TTF_CENTERTIP = $0002;
TTM_ADDTOOL = $0400 + 50;
TTM_SETTITLE = (WM_USER + 32);
TTM_WINDOWFROMPOINT = WM_USER + 16;
ICC_WIN95_CLASSES = $000000FF;

CCH_MAXNAME=255;
LNK_RUN_MIN=7;
LNK_RUN_MAX=3;
LNK_RUN_NORMAL=1;

type

TShapeStyle = (shsLeft, shsTop, shsRight, shsBottom);
TFindCallBack = procedure (const filename:string;const info:TSearchRec; var bQuit, bSub: boolean) of object;
TShapeStyles = set of TShapeStyle;
TpointPos = (ppTopCenter, ppBottomCenter, ppCenter);

LINK_FILE_INFO = record
FileName: array[0..MAX_PATH] of char;
WorkDirectory: array[0..MAX_PATH] of char;
IconLocation: array[0..MAX_PATH] of char;
IconIndex:integer;
Arguments: array[0..MAX_PATH] of char;
Description: array[0..CCH_MAXNAME] of char;
ItemIDList: PItemIDList;
RelativePath: array[0..255] of char;
ShowState: integer;
HotKey: word;
end;

TGradDir = (gdLeftRight, gdTopBottom);

TLinePos = (lnLeft, lnTop, lnRight, lnBottom);

TMyWriter = class(TWriter)
public
procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
end;

TMyReader = class(TReader)
public
procedure ReadProperty(Instance: TPersistent);
end;

function getAlphaColor(BackColor,ForeColor: TColor; alpha: integer): TColor;
function DarkColor(const Color: TColorRef; const Percent: Byte): TColorRef;
procedure GrayDrawimage(AImages: TCustomImageList; ACanvas: TCanvas;
Index, x, y: Integer; TransColor: TColor);
function RandomChar(str: string): char;
function indexofName(name: string; AR: array of string): integer;
function Confirm(Msg: string): Boolean;
function GetPopupRect(P: TPoint; R: TRect; H: Integer): TRect;
procedure RLalignDraw(R: Trect; Cvs: TCanvas; s : WideString);
procedure blendColor(ACanvas: TCanvas; ARect: TRect; FColor: TColor; Value: byte) overload;
procedure BlendCanvas(BCanvas,FCanvas: TCanvas; FRect: TRect;
Sx,Sy: integer; Value: byte);
procedure BlendBmp(bmp: TBitmap; clBlend: Tcolor; value: byte);
procedure blendDrawBmp(SCanvas: TCanvas; bmp: Tbitmap; Ax,Ay: integer;
TransColor: TColor; BValue: byte); overload;
procedure blendDrawBmp(SCanvas: TCanvas; bmp: Tbitmap; Ax,Ay: integer;
BValue: byte); overload;
procedure delay(times: integer);
function MouseIORect(R: TRect; pt: TPoint; var R1, R2: boolean): boolean;
procedure drawCheckMark(cvs: TCanvas; R: TRect; width: integer; color: TColor);
procedure disorganize(var AArray: Array of integer); overload;
procedure disorganize(var AStr: TStringList); overload;
procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer;
ShadowColor: TColor);
procedure BlendIcon(Canvas: TCanvas; const R: TRect;
ImageList: TCustomImageList; ImageIndex: Integer; Opacity: Byte);
procedure DimBitmap(ABitmap: TBitmap; Value: integer);
procedure GrayBitmap(ABitmap: TBitmap; Value: integer; tspColor: TColor);
procedure DrawDownArraw(ACanvas: TCanvas;ARect: TRect; Size: byte; Color: Tcolor);
procedure DrawUpArraw(ACanvas: TCanvas;ARect: TRect; Size: byte; Color: Tcolor);
procedure DrawTraMark(ACanvas: TCanvas; posBegin: TPoint; Size: byte; Color: Tcolor; Up: boolean);
function MouseHook(handle: HWnd; ShowModal: boolean): HHook;
procedure unHookMouseHook(AHook: HHook);
function PopupWindowMouseHook(Code: Integer; wParam: WParam; lParam: LParam): LRESULT; stdcall;
function RWStrFromReg(const key: string; name, value: string; Write: boolean): string;
//procedure ReadFromReg(const key: string; Names: array of variant; values: var array of variant);
procedure msHookshow(AControl: TWinControl; modal: boolean);
procedure msHookHide(handle: Hwnd);
procedure msHookDropDown(Sender, DropDownControl: TWinControl);
procedure DoBusy(Busy: Boolean);
//Add on 2003.8.19
procedure SavePropertyToStream(Stream: TStream; Instance: TPersistent; PropName: string);
procedure LoadPropertyFromStream(Stream: TStream; Instance: TPersistent);
function digitToChinese(value: Real; EndAtYuan: boolean): string;
function dupString(S: String; count: integer): string;
procedure InOutStr(var S: string; char: String);
procedure StringsSetCount(var sList: TStringList; NewCount: integer);
procedure Circle(cvs: TCanvas; Radius: integer; ptCenter: Tpoint);
procedure FillGradient(const DC: HDC; const ARect: TRect; StartColor,
EndColor: TColorRef; const Direction: TGradDir);
Function AvailableUrl(url:string):boolean;
Function InterNetConnected: boolean;
function Matchstrings(Source, pattern: string): Boolean; //字符匹配
function GetToken(const S: string; index: Integer; bTrail: Boolean = False; Delimiters: TSysCharSet = DEFAULT_DELIMITERS): string;
function GetLocalIP: String; //取的本机IP
function GetBroadCastIp: string;
function GetTaskBarHeight: integer; //取的任务栏的高度;
function GetTaskBarWnd: HWND;
function GetWindowText(HWnd: HWnd;GetPassWord: Boolean=False): string;
//取得文本且可以取得密码
function IsObjectActive(className : string):boolean;
procedure CopyBmpToClp(imList: TImageList; index: integer);
function TempPath: string;
function MakeTempFilename(pf: string; cn: integer; Doctype: string; NewPath: string = ''): string;
function safeTmpFile(s: string; DocType: string; AllowExist: boolean = true): string;
function IsFileInUse(fName : string ) : boolean;
Function Cjt_AddtoFile(SourceFile,TargetFile:string): Boolean;
Function Cjt_DetachFromFile(SourceFile, TargetFile :string): Boolean;
function GetVersion(FileName: string): string;
procedure FillTubeGradientRect(DC: HDC; const ARect: TRect; AColor1, AColor2: TColor;
AHorizontal: Boolean);
function DeleteCRLF(s: string): string;
function Encrypt(const S: String; Key: Word): String;
function Decrypt(const S: String; Key: Word): String;
function DenCrypt(Str : string; Key : string = ''): string;
function qtLike(s: string): string;
function GetFileExtIconIndex(FileExt: string): integer;
function GetSpecFoldIconIndex(mFolder: integer): integer;
function GetFileExtTypeName(FileExt: string): string;
function getSysImageHwnd(Small: boolean): THandle;
function RotatePoint(const baseP, P: TPoint; angle: integer): TPoint;
function RegisterOleFile (strOleFileName : STRING; OleAction : Byte ) : BOOLEAN;
function WarpDeliStrings(DeliText: string; colCount: integer): wideString;
function percentToFloat(value: string): double;
function MapGlobalData(const MapName: string; Size: Integer; var Ptr: Pointer): THandle;
procedure ReleaseGlobalData(Handle: THandle; var Ptr: Pointer);
function IsGlobalDataExistent(const MapName: string): Boolean;
function killDll(DllName: string): boolean;
function GetProcessId(pgName: string): LongInt;
function getMainThreadId(pgName: string): longInt;
function FitRect(R: TRect; FitW, FitH: integer): TRect;
function FullFitRect(R: TRect; Fitw, FitH: integer): TRect;
procedure ZoomFitDrawBmp(srcCanvas: Tcanvas; dsBmp: Tbitmap);
procedure RotateBmp(Bitmap: TBitmap; Angle: integer);

procedure SpiegelnHorizontal (Bitmap:TBitmap);
procedure SpiegelnVertikal (Bitmap:TBitmap);
procedure Drehen90Grad (Bitmap:TBitmap);
procedure Drehen270Grad (Bitmap:TBitmap);
procedure Drehen180Grad (Bitmap:TBitmap);
function Rotate90(Bitmap:TBitmap): TBitmap;
procedure DrawDisabledImage(Canvas: TCanvas; x, y, value: integer;
ImageList: TCustomImageList; ImageIndex: Integer); overload;
procedure DrawDisabledImage(Canvas: TCanvas; const R: TRect;
ImageList: TCustomImageList; ImageIndex: Integer; Light: Boolean); overload;
procedure line(ACanvas: TCanvas; R: TRect; lnpos: TLinePos);
procedure DotLineX(Acanvas: TCanvas; y, x1, x2: integer);
procedure DotLiney(Acanvas: TCanvas; x, y1, y2: integer);
//procedure CombineBuffer(const Source1; const Source2; var Dest: pchar);
procedure CombineBuffer(const Source1; const Source2; count1, count2: integer;
var Dest: pchar);
function CreateLinkFile(const info: LINK_FILE_INFO;
const DestFileName: string=''):boolean;
function CellRect(R: TRect; Index, Cols, Rows: integer): TRect;
function mouseToCell(R: TRect; Cols, Rows, x, y: integer): integer;
function GetSpecialFolderDir(mFolder: Integer): string;
procedure AddSubTree(DestTree: TTreeView; SourceNode, DestNode: TTreeNode; AddState: Boolean);
procedure CombineTreeView(Desc, Source: TTreeView);
function RectWidth(R: TRect): integer;
function RectHeight(R: TRect): integer;
function FileSizeToStr(size: integer): string;
function getFileSize(fileName: string): integer;
procedure ClearMemory;
procedure ShowTip(hd, Text: string; position: TPoint; Icon: integer = 1; HideDelay: integer = 0);
procedure ShowTip2(hd, Text: string; position: TPoint; Icon: integer);
procedure HideTip;
procedure HideTip2;
procedure LineRect(R: TRect; canvas: TCanvas; Style: TShapeStyles);
function ZoomRect(R: TRect; pencent: word): TRect;
function SortByTag(Ctrl1, Ctrl2: Pointer): integer;
procedure AngleTextOut(Canvas: TCanvas; const X, Y, Angle: Integer;
const Text: string);
procedure SectorTextOut(Canvas: TCanvas; const X, Y, Angle, Radius: Integer;
const Text: string);
procedure drawTick(cvs: TCanvas; AR: TRect);
procedure Draw5pStar(cvs: Tcanvas; R, Angle, x, y: integer; color: TColor = clRed);
procedure DrawChork(cvs: TCanvas; Angle, FontSize, size, x, y: integer;
text: string; color: TColor = clRed);
procedure DrawChorkEx(cvs: TCanvas; Angle, FontSize, Rw, Rs, Rt, x, y: integer;
text: string; FrameSize: integer; color: TColor = clRed);
procedure DrawChorkSoft(cvs: TCanvas; Angle, FontSize, size, x, y: integer;
text: string; color: TColor = clRed);
function ExtractFileNameNoExt(Filename: string): string;
function ExtractFileExtNoDot(Filename: string): string;
procedure ExtractFileParts(const FileName: string; var name, ext: string);
function RPos(const C: Char; const S: string): Integer;
function CopyMenuItem(SourceItem: TMenuItem): TmenuItem;
procedure sysImageToClipboard(index: integer; Small: boolean);
function FileNameWithoutExt(fname: string): string;
procedure deleteBracketString(var s: string);
// 获取汉字的拼音首字符,这个函数将用在GetPYIndexStr 中.
function GetPYIndexChar(strChinese: string; bUpCase: Boolean = True): char;
// 获取多个汉字的拼音首字符组成的字符串.
function GetPYIndexStr(strChinese: string; bUpCase: Boolean = True): string;
{说明：
TFindCallBack为回调函数，FindFile函数找到一个匹配的文件之后就会调用这个函数。
TFindCallBack的第一个参数找到的文件名，你在回调函数中可以根据文件名进行操作。
TFindCallBack的第二个参数为找到的文件的记录信息，是一个TSearchRec结构。
TFindCallBack的第三、四个参数分别为决定是否终止文件的查找，临时决定是否查找某个子目录！
FindFile的参数：
第一个决定是否退出查找，应该初始化为false；
第二个为要查找路径；
第三个为文件名，可以包含Windows所支持的任何通配符的格式；默认所有的文件
第四个为回调函数，默认为空
第五个决定是否查找子目录，默认为查找子目录
第六个决定是否在查找文件的时候处理其他的消息，默认为处理其他的消息
若有意见和建议请E_Mail：Kingron@163.net
}
procedure FindFile(var quit: boolean; const path: String; const filename: string='*.*';
proc: TFindCallBack = nil; bSub: boolean=true; const bMsg: boolean = true);
function GetDrives: string;
procedure SmashFile(FileName: string);
procedure Quitexe(FileName: string);
procedure getExeList(var sl: Tstrings);
function getNotifyWnd: Hwnd;
function getTrayClockHandle: hwnd;
function GetLocalHostName: string;
function SecToMin(Sec: integer): string;
function GetRotateRect(w, h: Integer; DstCenter: TPoint; Angle: Double): TRect;
procedure CIELabToRGB(L, a, b: double; var R1, G1, B1: integer);
//播放Mp3
function playMp3(fileName: string; Ahandle: Thandle): integer; overload;
function playMp3(fileName: string; var DeviceId: MCIDEVICEID; var OpenParms: TMCI_Open_Parms;
Ahandle: Thandle): integer; overload;

procedure ClosePlay;
function NotColor(C: TColor): TColor;
function BitmapToIcon(Bitmap: TBitmap): TIcon;
function ScreenPointForCtrl(AControl: TControl; pointPos: TpointPos): TPoint;
function AControlInPControl(AControl: TControl; PWinCtrl: TwinControl): boolean;

var
PopHandle: HWND;
SenderHandle: HWND;
HookHandle: HHook;
HHint : THandle;
Hhint2 : THandle;

mciOpenParms : TMCI_Open_Parms;
m_MCIDeviceID: MCIDEVICEID;

implementation

uses ClipBrd, tlhelp32, math;

{ TMyWriter }
procedure TMyWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
begin
inherited WriteProperty(Instance, PropInfo);
end;

{ TMyReader }
procedure TMyReader.ReadProperty(Instance: TPersistent);
begin
inherited ReadProperty(Instance);
end;

function getAlphaColor(BackColor,ForeColor: TColor; alpha: integer): TColor; //经典之作 2009-9-1评价
var
R,G,B: integer;
begin
backColor:=TColor(backColor);
backColor:=colortoRGB(backColor);
ForeColor:=colortoRGB(ForeColor);
R:=(getRValue(backColor)*(255-alpha)+getRvalue(ForeColor)*alpha) div 255;
G:=(getGValue(backColor)*(255-alpha)+getGvalue(ForeColor)*alpha) div 255;
B:=(getBValue(backColor)*(255-alpha)+getBvalue(ForeColor)*alpha) div 255;
if R>255 then R:=255;
if R<0 then R:=0;
if G>255 then G:=255;
if G<0 then R:=0;
if B>255 then B:=255;
if B<0 then B:=0;
result:=RGB(R,G,B);
end;

function DarkColor(const Color: TColorRef; const Percent: Byte): TColorRef;
var
R, G, B: Integer;
begin
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
R := R - Percent;
G := G - Percent;
B := B - Percent;
if R < 0 then R := 0;
if G < 0 then G := 0;
if B < 0 then B := 0;
Result := RGB(R, G, B);
end;

procedure GrayDrawimage(AImages: TCustomImageList; ACanvas: TCanvas;
Index, x, y: Integer; TransColor: TColor);
var
B: TBitMap;
begin
B:=TBitmap.Create;
try
B.Width:=AImages.Width;
B.Height:=AImages.Height;
B.Canvas.Brush.Color:=TransColor;
B.Canvas.FillRect(Rect(0, 0, b.Width, b.Height));
AImages.Draw(B.Canvas, 0, 0, Index);
GrayBitmap(B, 40, TransColor);
B.Transparent:=true;
Acanvas.Draw(x, y, B);
finally
B.Free;
end;
end;

function RandomChar(str: string): char;
begin
if str<>'' then Result :=str[Random(length(str))+1];
end;

function indexofName(name: string; AR: array of string): integer;
var
i: integer;
begin
result:=-1;
for i:=low(ar) to high(ar) do
if Ar[i]=name then
begin
result:=i;
break;
end;
end;

function Confirm(Msg: string): Boolean;
begin
beep;
result:=messageBox(getActiveWindow,pchar(msg), Pchar('确认'),
MB_YESNO or MB_ICONQUESTION)=IDYES;
end;

procedure RLalignDraw(R: Trect; Cvs: TCanvas; s : wideString);
var
i, y: integer;
space: integer;
tmpS : string;
begin
inc(R.Left,6);
dec(R.Right,6);
with cvs do begin
brush.Style:=bsClear;
if (textwidth(s)>(R.Right-R.Left)) or (length(S)<2) then begin
tmpS:=S;
drawText(handle,pchar(tmps),length(tmps),R, DT_END_ELLIPSIS
or DT_SINGLELINE or DT_VCENTER)
end else begin
if (length(S)-1)<1 then exit;
space:=((R.Right-R.Left)-textWidth('我')) div (length(S)-1);
y:=((R.Bottom-R.Top)-textHeight('我')) div 2;
for i:=1 to length(s) do cvs.TextOut((i-1)*space+R.Left,y+R.Top,S[i]);
end;
end;
end;

//这个是我在2003年3月28日写的，比较难理解，但速度比前面的快7-8倍
procedure blendColor(ACanvas: TCanvas; ARect: TRect; FColor: TColor; Value: byte);
var
w, h : integer;
bmp: TbitMap;
begin
bmp:=TbitMap.Create;
with ARect do
begin
h:=Bottom-Top;
w:=Right-Left;
end;
try
with bmp do begin
height:=h;
Width:=w;
Canvas.CopyRect(Rect(0,0,w,h),ACanvas, Arect);
BlendBmp(bmp,FColor,value);
ACanvas.Draw(ARect.Top,ARect.Left,bmp);
end;
finally
bmp.Free;
end;
end;

procedure BlendCanvas(BCanvas,FCanvas: TCanvas; FRect: TRect;
Sx,Sy: integer; Value: byte);
var
x, y: integer;
begin
for x:=FRect.Left+Sx to FRect.Right+Sx do
for y:=FRect.Top+Sy to FRect.Bottom+Sy do
BCanvas.Pixels[x,y]:=getAlphaColor(BCanvas.Pixels[x,y],
FCanvas.Pixels[x-FRect.Left-Sx,y-FRect.Top-Sy],value);
end;

procedure BlendBmp(bmp: TBitmap; clBlend: Tcolor; value: byte);
var
Pixel: PRGBTriple;
w, h: Integer;
x, y: Integer;
clR,clG,clB: TColor;
begin
Bmp.PixelFormat := pf24Bit;
w := bmp.Width;
h := bmp.Height;
clR:=getRValue(clBlend);
clG:=getGValue(clBlend);
clB:=getBValue(clBlend);
for y := 0 to h - 1 do begin
Pixel := bmp.ScanLine[y];
for x := 0 to w - 1 do begin
pixel^.rgbtRed:=(pixel^.rgbtRed*(255-value)+clR * value) div 255;
pixel^.rgbtGreen:=(pixel^.rgbtGreen*(255-value)+clG * value) div 255;
pixel^.rgbtBlue:=(pixel^.rgbtBlue*(255-value)+clB * value) div 255;
Inc(Pixel);
end;
end;
end;

procedure blendDrawBmp(SCanvas: TCanvas; bmp: Tbitmap; Ax,Ay: integer;
TransColor: TColor; BValue: byte);
var
bkBmp: TBitmap;
bkPix: PRGBTriple;
bmpPix: PRGBTriple;
x, y: integer;
begin
bkbmp:=TBitMap.create;
try
bkBmp.Height:=bmp.Height;
bkbmp.Width:=bmp.Width;
bmp.PixelFormat:=pf24Bit;
bkBmp.PixelFormat:=pf24bit;
bkbmp.Canvas.CopyRect(Rect(0,0,bmp.Width,bmp.Height),SCanvas,Rect(Ax,Ay,Ax+bmp.Width,Ay+bmp.Height));
for y:=0 to bmp.Height-1 do
begin
bkPix:=bkBmp.ScanLine[y];
bmppix:=bmp.ScanLine[y];
for x:=0 to bmp.Width-1 do
begin
if Rgb(bmpPix^.rgbtRed, bmpPix^.rgbtGreen, bmpPix^.rgbtBlue)<>TransColor then
begin
bkPix^.rgbtRed:=(bkPix^.rgbtRed*(255-Bvalue)+bmpPix^.rgbtRed * Bvalue) div 255;
bkPix^.rgbtGreen:=(bkPix^.rgbtGreen*(255-Bvalue)+bmpPix^.rgbtGreen * Bvalue) div 255;
bkPix^.rgbtBlue:=(bkPix^.rgbtBlue*(255-Bvalue)+bmpPix^.rgbtBlue * Bvalue) div 255;
end;
Inc(bkPix);
inc(bmpPix);
end;
end;
Scanvas.Draw(Ax,Ay,bkBmp);
finally
bkbmp.free;
end;
end;

procedure blendDrawBmp(SCanvas: TCanvas; bmp: Tbitmap; Ax,Ay: integer; BValue: byte);
var
bkBmp: TBitmap;
bkPix: PRGBTriple;
bmpPix: PRGBTriple;
x, y: integer;
begin
bkbmp:=TBitMap.create;
try
bkBmp.Height:=bmp.Height;
bkbmp.Width:=bmp.Width;
bmp.PixelFormat:=pf24Bit;
bkBmp.PixelFormat:=pf24bit;
bkbmp.Canvas.CopyRect(Rect(0,0,bmp.Width,bmp.Height),SCanvas,Rect(Ax,Ay,Ax+bmp.Width,Ay+bmp.Height));
for y:=0 to bmp.Height-1 do
begin
bkPix:=bkBmp.ScanLine[y];
bmppix:=bmp.ScanLine[y];
for x:=0 to bmp.Width-1 do
begin
bkPix^.rgbtRed:=(bkPix^.rgbtRed*(255-Bvalue)+bmpPix^.rgbtRed * Bvalue) div 255;
bkPix^.rgbtGreen:=(bkPix^.rgbtGreen*(255-Bvalue)+bmpPix^.rgbtGreen * Bvalue) div 255;
bkPix^.rgbtBlue:=(bkPix^.rgbtBlue*(255-Bvalue)+bmpPix^.rgbtBlue * Bvalue) div 255;
Inc(bkPix);
inc(bmpPix);
end;
end;
Scanvas.Draw(Ax,Ay,bkBmp);
finally
bkbmp.free;
end;
end;

procedure delay(times: integer);
var
beginTime: integer;
begin
begintime:=getTickCount;
repeat
application.ProcessMessages;
until getTickcount-begintime>times;
end;

function GetPopupRect(P: TPoint; R: TRect; H: Integer): TRect;
begin
Result := Rect(P.X, P.Y + H, P.X + (R.Right - R.Left), P.Y + H + (R.Bottom - R.Top));
if Result.Bottom > Screen.Height then begin
Result.Top := P.Y - (R.Bottom - R.Top);
Result.Bottom := P.Y;
end;
if Result.Top < 0 then
if P.Y > (Screen.Height - H - P.Y) then Result.Top := 0
else begin
Result.Top := P.Y + H;
Result.Bottom := Screen.Height;
end;
if Result.Right > Screen.Width then OffsetRect(Result, Screen.Width - Result.Right, 0);
if Result.Left < 0 then OffsetRect(Result, - Result.Left, 0);
end;

function MouseIORect(R: TRect; pt: TPoint; var R1, R2: boolean): boolean;
begin
R1:=ptInRect(R,pt);
if R2<>R1 then begin
R2:=R1;
result:=True;
end else Result:=false;
end;

procedure drawCheckMark(cvs: TCanvas; R: TRect; width: integer; Color: TColor);
var
R1: TRect;
Qx4: integer;
Qy4: integer;
begin
R1:=R;
offsetRect(R1,4,1);
with cvs do begin
pen.Color:=color;
pen.Width:=width;
Qx4:=(R1.Right-R1.Left) div 4;
Qy4:=(R1.Bottom-R1.Top) div 4+1;
moveto(R1.Left,R.Bottom-Qy4);
lineto(R1.Left+Qx4+1,R1.Bottom);
lineto(R1.Right,R1.Top+Qy4+1);
pen.Width:=1;
moveto(R1.Left,R.Bottom-Qy4);
lineto(R1.Left-2,R.Bottom-Qy4+3);
end;

end;

procedure disorganize(var AArray: Array of integer);
var
i,k: integer;
tmp: integer;
begin
for i:=low(AArray) to High(AArray) do begin
k:=random(High(AArray))-Low(AArray);
tmp:=AArray[k];
AArray[k]:=AArray[i];
AArray[i]:=tmp;
end;
end;

procedure disorganize(var AStr: TStringList); overload;
var
i,k: integer;
tmp: String;
begin
for i:=0 to AStr.Count-1 do begin
k:=Random(AStr.Count);
tmp:=AStr[k];
AStr[k]:=AStr[i];
AStr[i]:=tmp;
end;
end;

procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer;
ShadowColor: TColor);
var
BX, BY: integer;
TransparentColor: TColor;
begin
shadowColor:=getAlphaColor(ACanvas.Pixels[1,1],clBlack,84);
TransparentColor := B.Canvas.Pixels[0, B.Height - 1];
for BY := 0 to B.Height - 1 do
for BX := 0 to B.Width - 1 do
begin
if B.Canvas.Pixels[BX, BY] <> TransparentColor then
ACanvas.Pixels[X + BX, Y + BY] := ShadowColor;
end;
end;

procedure DimBitmap(ABitmap: TBitmap; Value: integer);
var
Pixel: PRGBTriple;
w, h: Integer;
x, y, c1, c2: Integer;
begin
ABitmap.PixelFormat := pf24Bit;
w := ABitmap.Width;
h := ABitmap.Height;

c1 := Value * 255;
c2 := 100 - Value;
for y := 0 to h - 1 do
begin
Pixel := ABitmap.ScanLine[y];
for x := 0 to w - 1 do
begin
Pixel^.rgbtRed := ((c2 * Pixel^.rgbtRed) + c1) div 100;
Pixel^.rgbtGreen := ((c2 * Pixel^.rgbtGreen) + c1) div 100;
Pixel^.rgbtBlue := ((c2 * Pixel^.rgbtBlue) + c1) div 100;
Inc(Pixel);
end;
end;
end;

procedure BlendIcon(Canvas: TCanvas; const R: TRect;
ImageList: TCustomImageList; ImageIndex: Integer; Opacity: Byte);
const
CWeirdColor = $00203241;
var
StockBitmap1: TBitMap;
StockBitmap2: TBitMap;
ImageWidth, ImageHeight: Integer;
I, J: Integer;
Src, Dst: ^Cardinal;
S, C, CBRB, CBG: Cardinal;
Wt1, Wt2: Cardinal;
begin
Wt2 := Opacity;
Wt1 := 255 - Wt2;
ImageWidth := R.Right - R.Left;
ImageHeight := R.Bottom - R.Top;
with ImageList do
begin
if Width < ImageWidth then ImageWidth := Width;
if Height < ImageHeight then ImageHeight := Height;
end;
StockBitmap1:=TBitMap.Create;
StockBitmap2:=TBitMap.Create;
try
StockBitmap1.Width := ImageWidth;
StockBitmap1.Height := ImageHeight;
StockBitmap2.Width := ImageWidth;
StockBitmap2.Height := ImageHeight;

BitBlt(StockBitmap1.Canvas.Handle, 0, 0, ImageWidth, ImageHeight,
Canvas.Handle, R.Left, R.Top, SRCCOPY);
BitBlt(StockBitmap2.Canvas.Handle, 0, 0, ImageWidth, ImageHeight,
StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY);
ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex, True);

for J := 0 to ImageHeight - 1 do
begin
Src := StockBitmap2.ScanLine[J];
Dst := StockBitmap1.ScanLine[J];
for I := 0 to ImageWidth - 1 do
begin
S := Src^;
if S <> Dst^ then
begin
CBRB := (Dst^ and $00FF00FF) * Wt1;
CBG := (Dst^ and $0000FF00) * Wt1;
C := ((S and $FF00FF) * Wt2 + CBRB) and $FF00FF00 + ((S and $00FF00) * Wt2 + CBG) and $00FF0000;
Dst^ := C shr 8;
end;
Inc(Src);
Inc(Dst);
end;
end;
BitBlt(Canvas.Handle, R.Left, R.Top, ImageWidth, ImageHeight,
StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY);
finally
StockBitmap1.Free;
StockBitmap1.Free;
end;
end;

procedure GrayBitmap(ABitmap: TBitmap; Value: integer; tspColor: TColor);
var
Pixel: PRGBTriple;
w, h: Integer;
x, y: Integer;
avg: integer;
begin
ABitmap.PixelFormat := pf24Bit;
w := ABitmap.Width;
h := ABitmap.Height;
for y := 0 to h - 1 do
begin
Pixel := ABitmap.ScanLine[y];
for x := 0 to w - 1 do
begin
if RGB(Pixel^.rgbtRed, Pixel^.rgbtGreen, Pixel^.rgbtBlue)<>tspColor then
begin
avg := ((Pixel^.rgbtRed + Pixel^.rgbtGreen + Pixel^.rgbtBlue) div 3)
+ Value;
if avg > 240 then avg := 240;
Pixel^.rgbtRed := avg;
Pixel^.rgbtGreen := avg;
Pixel^.rgbtBlue := avg;
end;
Inc(Pixel);
end;
end;
end;

procedure DrawUpArraw(ACanvas: TCanvas;ARect: TRect; Size: byte; Color: Tcolor);
var
oldBsColor: TColor;
PL, PR, PT: Tpoint;
Rw, Rh: integer;
begin
oldBsColor:=ACanvas.Brush.Color;
Rw:=ARect.Right-Arect.Left;
Rh:=ARect.Bottom-ARect.Top;
PT:=point(ARect.Left + Rw div 2, ARect.Top+(Rh-size) div 2);
PL:=point(ARect.Left + Rw div 2 - Size, ARect.Top+(Rh+size) div 2);
PR:=point(ARect.Left + Rw div 2 + Size, ARect.Top+(Rh+size) div 2);
with ACanvas do begin
pen.Color:=color;
Brush.Color:=color;
Polygon([PL,PR,PT]);
Brush.Color:=OldBsColor;
end;
end;

procedure DrawTraMark(ACanvas: TCanvas; posBegin: TPoint; Size: byte; Color: Tcolor; Up: boolean);
var
oldBsColor: TColor;
PL, PR, PT: Tpoint;
begin
oldBsColor:=ACanvas.Brush.Color;
if up then
begin
pt:=point(posBegin.X+size, posBegin.Y);
pl:=point(posBegin.X, posBegin.Y+size);
end else
begin
pt:=point(posBegin.X-size, posBegin.Y);
pl:=point(posBegin.X, posBegin.Y-size);
end;
with ACanvas do begin
pen.Color:=color;
Brush.Color:=color;
// brush.Style:=bsSolid;
Polygon([posBegin, PL, PT]);
Brush.Color:=OldBsColor;
end;
end;

procedure DrawDownArraw(ACanvas: TCanvas;ARect: TRect; Size: byte; Color: Tcolor);
var
oldBsColor: TColor;
PL, PR, PB: Tpoint;
Rw, Rh: integer;
begin
oldBsColor:=ACanvas.Brush.Color;
Rw:=ARect.Right-Arect.Left;
Rh:=ARect.Bottom-ARect.Top;
PL:=point(ARect.Left + Rw div 2 - Size, ARect.Top+(Rh-size) div 2);
PR:=point(ARect.Left + Rw div 2 + Size, ARect.Top+(Rh-size) div 2);
PB:=point(ARect.Left + Rw div 2, ARect.Top+(Rh-size) div 2 + Size);
with ACanvas do begin
pen.Color:=color;
Brush.Color:=color;
Polygon([PL,PR,PB]);
Brush.Color:=OldBsColor;
end;
end;

function MouseHook(handle: HWnd; ShowModal: boolean): HHook;
begin
PopHandle:=Handle;
HookHandle := SetWindowsHookEx(WH_MOUSE, PopupWindowMouseHook, 0, GetCurrentThreadId);
Result:=HookHandle;
end;

procedure unHookMouseHook(AHook: HHook);
begin
UnhookWindowsHookEx(AHook);
HookHandle := 0;
end;

//钩子函数，用来做些PopUp的窗口的隐藏
function PopupWindowMouseHook(Code: Integer; wParam: WParam; lParam: LParam): LRESULT; stdcall;
var
R: TRect;
sR: TRect;
begin
if (Code >= 0) and
((wParam = WM_LBUTTONDOWN) or (wParam = WM_RBUTTONDOWN) or (wParam = WM_MBUTTONDOWN) or
(wParam = WM_NCLBUTTONDOWN) or (wParam = WM_NCRBUTTONDOWN) or (wParam = WM_NCMBUTTONDOWN) or
(wParam = WM_NCLBUTTONUP) or (wParam = WM_NCRBUTTONUP) or (wParam = WM_NCMBUTTONUP) or
(wParam = WM_LBUTTONDBLCLK) or (wParam = WM_RBUTTONDBLCLK) or (wParam = WM_MBUTTONDBLCLK) or
(wParam = WM_NCLBUTTONDBLCLK) or (wParam = WM_NCRBUTTONDBLCLK) or (wParam = WM_NCMBUTTONDBLCLK)) then
begin
GetWindowRect(PopHandle, R);
GetWindowRect(senderHandle, sR);
if not PtInRect(R, PMouseHookStruct(lParam)^.pt) {and not PtInRect(sR, PMouseHookStruct(lParam)^.pt)} then
begin
if GetCapture = PopHandle then ReleaseCapture;
if IsWindowVisible(PopHandle) then
begin
sendmessage(senderHandle, CM_CLOSEUP, 0, 0);
SetWindowPos(PopHandle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_HIDEWINDOW or SWP_NOACTIVATE);
SendMessage(senderHandle, CM_CLOSEUP, 0, 0); // rui Move to here 2010-7-12
UnhookWindowsHookEx(HookHandle);
HookHandle := 0;
end;
Result := 1;
if PtInRect(sR, PMouseHookStruct(lParam)^.pt) then Exit;
end
end;
Result := CallNextHookEx(HookHandle, Code, wParam, lParam);
end;

procedure msHookshow(AControl: TWinControl; modal: boolean);
begin
with AControl do begin
SetWindowPos(Handle, 0, Left, Top, 0, 0,
SWP_NOZORDER or SWP_NOSIZE or SWP_NOACTIVATE);
SetWindowPos(Handle, HWND_TOP, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_FRAMECHANGED);
HookHandle:=MouseHook(handle, modal);
end;
end;

procedure msHookDropDown(Sender, DropDownControl: TWinControl);
begin
Senderhandle:=Sender.Handle;
with DropDownControl do
begin
SetWindowPos(Handle, 0, Left, Top, 0, 0,
SWP_NOZORDER or SWP_NOSIZE or SWP_NOACTIVATE);
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_FRAMECHANGED);
HookHandle:=MouseHook(handle, False);
end;
end;

procedure msHookHide(handle: Hwnd);
begin
if IsWindowVisible(Handle) then
begin
SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_HIDEWINDOW or SWP_NOACTIVATE);
unHookMouseHook(HookHandle);
end;
end;

// 注册表简化操作 by：冯思锐于2003.5.21 for NetChat first
function RWStrFromReg(const key: string; name, value: string; Write: boolean): string;
var
Reg: TRegistry;
begin
Result:='';
Reg:=TRegistry.Create;
with Reg do begin
Reg.RootKey:=HKEY_CURRENT_USER;
try
if write then begin
if Reg.OpenKey(key,true) then Reg.WriteString(name,value);
end
else
if Reg.OpenKey(key,false) then result:=Reg.ReadString(name);
finally
free;
end;
end;
end;

procedure DoBusy(Busy: Boolean);
begin
if Busy then
begin
{if Times = 1 then }Screen.Cursor := crHourGlass;
end else
begin
{if Times = 0 then} Screen.Cursor := crDefault;
end;
end;

procedure SavePropertyToStream(Stream: TStream; Instance: TPersistent; PropName: string);
begin
with TMyWriter.Create(Stream, 4096) do
try
WriteListBegin;
WriteProperty(Instance, GetPropInfo(Instance.ClassInfo, PropName));
WriteListEnd;
finally
Free;
end;
end;

procedure LoadPropertyFromStream(Stream: TStream; Instance: TPersistent);
begin
with TMyReader.Create(Stream, 4096) do
try
ReadListBegin;
while not EndOfList do ReadProperty(Instance);
ReadListEnd;
finally
Free;
end;
end;

function digitToChinese(value: Real; EndAtYuan: boolean): string;
const
Cs: WideString = '零壹贰叁肆伍陆柒捌玖';
Ds: wideString = '分角元拾佰仟万拾佰仟亿拾';
Es: wideString = '元拾佰仟万拾佰仟亿拾';
var
i: integer;
m: string;
begin
if not EndAtYuan then
begin
m:=inttostr(round(value*100));
for i:=1 to length(m) do
result:=result+Cs[strtoint(m[i])+1]+Ds[length(m)-i+1];
end
else
begin
m:=inttostr(round(value));
for i:=1 to length(m) do
result:=result+Cs[strtoint(m[i])+1]+Es[length(m)-i+1];
end;
end;

function dupString(S: String; count: integer): string;
var
i : integer;
begin
Result:='';
for i:=1 to count do Result:=Result+S
end;

procedure InOutStr(var S: string; char: String);
begin
if pos(char,S)<>0 then delete(S, pos(char,S),length(char))
else S:=S+char;
end;

procedure StringsSetCount(var sList: TStringList; NewCount: integer);
var
pCap: ^integer;
pCount: ^integer;
pStart: pointer;
begin
pStart := pointer(@sList.Sorted);
pCap:=pointer(integer(pStart)-sizeof(pointer));
pCount:=pointer(integer(pCap)-sizeof(integer));
pcount^:=NewCount;
sList.Capacity:=sList.Count;
end;

procedure Circle(cvs: TCanvas; Radius: integer; ptCenter: Tpoint);
var
R: TRect;
begin
R:=Rect(ptCenter,ptCenter);
inflateRect(R,Radius,Radius);
cvs.Ellipse(R);
end;

procedure FillGradient(const DC: HDC; const ARect: TRect; StartColor,
EndColor: TColorRef; const Direction: TGradDir);
var
rc1, rc2, gc1, gc2,
bc1, bc2, Counter: Integer;
Brush: HBrush;
begin
rc1 := GetRValue(StartColor);
gc1 := GetGValue(StartColor);
bc1 := GetBValue(StartColor);
rc2 := GetRValue(EndColor);
gc2 := GetGValue(EndColor);
bc2 := GetBValue(EndColor);

if Direction = gdTopBottom then
for Counter := ARect.Top to ARect.Bottom do
begin
Brush := CreateSolidBrush(
RGB((rc1 + (((rc2 - rc1) * (ARect.Top + Counter)) div ARect.Bottom)),
(gc1 + (((gc2 - gc1) * (ARect.Top + Counter)) div ARect.Bottom)),
(bc1 + (((bc2 - bc1) * (ARect.Top + Counter)) div ARect.Bottom))));
FillRect(DC, Rect(0, ARect.Top, ARect.Right, ARect.Bottom - Counter + 1), Brush);
DeleteObject(Brush);
end
else
for Counter := ARect.Left to ARect.Right do
begin
Brush := CreateSolidBrush(
RGB((rc1 + (((rc2 - rc1) * (ARect.Left + Counter)) div ARect.Right)),
(gc1 + (((gc2 - gc1) * (ARect.Left + Counter)) div ARect.Right)),
(bc1 + (((bc2 - bc1) * (ARect.Left + Counter)) div ARect.Right))));
FillRect(DC, Rect(ARect.Left, ARect.Top, ARect.Right - Counter +1, ARect.Bottom), Brush);
DeleteObject(Brush);
end;
end;

Function AvailableUrl(url:string):boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex,dwcodelen :dword;
dwcode:array[1..20] of char;
res : pchar;
begin
if pos('http://',lowercase(url))=0 then url := 'http://'+url;
Result := false;
hSession := InternetOpen('InetURL:/1.0',INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
if assigned(hsession) then
begin
hFile:=nil;
hfile := InternetOpenUrl(hsession, pchar(url),nil,0,INTERNET_FLAG_RELOAD,0);
result:=hfile<>nil;
if assigned(hfile) then InternetCloseHandle(hfile);
InternetCloseHandle(hsession);
end;
end;

Function InterNetConnected: boolean;
begin
result:=false;
Result:=AvailableUrl('http://www.baidu.com/');
end;

function Matchstrings(Source, pattern: string): Boolean;
var
pSource : array[0..255] of Char;
pPattern : array[0..255] of Char;
function MatchPattern(element, pattern: PChar): Boolean;
function IsPatternWild(pattern: PChar): Boolean;
var
t : Integer;
begin
Result := StrScan(pattern, '*') <> nil;
if not Result then Result := StrScan(pattern, '?') <> nil;
end;
begin
if StrComp(pattern, '*') = 0 then
Result := True
else
if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
Result := False
else
if element^ = Chr(0) then
Result := True
else
begin
case pattern^ of
'*': if MatchPattern(element, @pattern[1]) then
Result := True
else
Result := MatchPattern(@element[1], pattern);
'?': Result := MatchPattern(@element[1], @pattern[1]);
else
if element^ = pattern^ then
Result := MatchPattern(@element[1], @pattern[1])
else
Result := False;
end;
end;
end;
begin
StrPCopy(pSource, Source);
StrPCopy(pPattern, pattern);
Result := MatchPattern(pSource, pPattern);
end;

function GetToken(const S: string; index: Integer; bTrail: Boolean = False; Delimiters: TSysCharSet = DEFAULT_DELIMITERS): string;
var
I, W, head, tail: Integer;
bInWord : Boolean;
begin
I := 1;
W := 0;
bInWord := False;
head := 1;
tail := Length(S);
while (I <= Length(S)) and (W <= index) do
begin
if S[I] in Delimiters then
begin
if (W = index) and bInWord then tail := I - 1;
bInWord := False;
end else
begin
if not bInWord then
begin
bInWord := True;
Inc(W);
if W = index then head := I;
end;
end;

Inc(I);
end;

if bTrail then tail := Length(S);
if W >= index then Result := Copy(S, head, tail - head + 1)
else Result := '';
end;

function GetLocalIP: String;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe : PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of Ansichar;
I : Integer;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
try
Result:='';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do
begin
result:=StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
finally
WSACleanup;
end;
end;

function GetBroadCastIp: string;
var
i,j,iHead:Integer;
sHead,s:String;
ai:array [1..3] of integer;
LocalIP: string;
begin
{1~126.255.255.255 (A类网广播地址）
128~191.XXX.255.255 (B类网广播地址）
192~254.XXX.XXX.255 (C类网广播地址）}
LocalIP:=GetLocalIP;
j:=1;
for i:=0 to Length(LocalIP) do
begin
if LocalIP[i]='.' then
begin
ai[j]:=i;
Inc(j);
end;
if j>3 then break;
end;
sHead:=Copy(LocalIp,1,ai[1]-1);
iHead:=StrToInt(sHead);
if iHead<128 then //A类网
begin
Result:=sHead+'.255.255.255';
end
else
begin
if iHead<192 then //B类网
begin
s:=Copy(LocalIP,1,ai[2]-1);
Result:=s+'.255.255';
end
else //C类网
begin
s:=Copy(LocalIP,1,ai[3]-1);
Result:=s+'.255';
end;
end;
end;

function GetTaskBarHeight: integer;
var
abd: TAppBarData;
begin
abd.cbSize:=sizeof(abd);
SHAppBarMessage(ABM_GETTASKBARPOS,abd);
Result:=abd.rc.Bottom-abd.rc.Top;
end;

function GetTaskBarWnd: HWND;
begin
result:=FindWindow('Shell_TrayWnd', nil);
end;

function GetWindowText(HWnd: HWnd;GetPassWord: Boolean=False): string;
//取得文本且可以取得密码
var
iPwdChar : Integer;
iPwdLast : Integer;
psText : array[0..255] of char;
i : Integer;
begin
iPwdChar:=SendMessage(HWnd,EM_GETPASSWORDCHAR,0,0);
if (iPwdChar<>0) and GetPassWord then
begin
iPwdLast := 0;
i := 0;
while iPwdLast=0 do
begin
PostMessage(HWnd,EM_SETPASSWORDCHAR,0,0);
Application.ProcessMessages;
Inc(i);
iPwdLast:=SendMessage(HWnd,EM_GETPASSWORDCHAR,0,0);
if i>100 then break;
end ;
SendMessage(HWnd,WM_GETTEXT,255,Longint(@psText));
Result:=psText;
SendMessage(HWnd,EM_SETPASSWORDCHAR,iPwdChar,0);
end else begin
SendMessage(HWnd,WM_GETTEXT,255,Longint(@psText));
Result:=psText;
end;
end;

function IsObjectActive(className : string):boolean;
var
ClassID: TCLSID;
Unknown: IUnknown;
begin
try
ClassID := ProgIDToClassID(ClassName);
result := GetActiveObject(ClassID, nil, Unknown) = S_OK;
except
// raise;
result := false;
end;
end;

procedure CopyBmpToClp(imList: TImageList; index: integer);
var
bmp: Tbitmap;
begin
with TClipboard.Create do
begin
bmp:=Tbitmap.Create;
try
bmp.Height:=imList.Height;
bmp.Width:=imlist.Width;
imlist.Draw(bmp.Canvas,0,0,Index);
assign(bmp);
finally
bmp.Free;
free;
end;
end;
end;

function TempPath: string;
var
i: integer;
begin
SetLength(Result, MAX_PATH);
i := GetTempPath(Length(Result), PChar(Result));
SetLength(Result, i);
end;

function safeTmpFile(s: string; DocType: string; AllowExist: boolean = true): string;
var
i: integer;
begin
for i:=0 to 255 do
begin
result:=MakeTempFilename(s, i, DocType, 'ERPII');
if (not AllowExist) then
begin
if not FileExists(Result) then break
end
else if not IsFileInUse(result) then break;
end;
end;

function MakeTempFilename(pf: string; cn: integer; Doctype: string; NewPath: string = ''): string;
var
s: string;
begin
if NewPath<>'' then
begin
s:=temppath+NewPath+'\';
if not DirectoryExists(s) then createDir(s);
end
else
s:=temppath;
if cn=0 then
result:=s+pf+'.'+doctype
else
result:=s+pf+inttostr(cn)+'.'+doctype
end;

function IsFileInUse(fName : string ) : boolean;
var
HFileRes : HFILE;
begin
Result := false;
if not FileExists(fName) then exit;
HFileRes:=CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,0, nil,
OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL, 0);
Result:=(HFileRes = INVALID_HANDLE_VALUE);
if not Result then CloseHandle(HFileRes);
end;

Function Cjt_AddtoFile(SourceFile, TargetFile:string): Boolean;
var
Target, Source: TFileStream;
MyFileSize: integer;
begin
try
Source:=TFileStream.Create(SourceFile,fmOpenRead or fmShareDenyWrite);
Target:=TFileStream.Create(TargetFile,fmOpenWrite or fmShareExclusive);
try
Target.Seek(0,soFromEnd);//往尾部添加资源
Target.CopyFrom(Source,0);
//计算资源大小，并写入辅程尾部;
MyFileSize:=Source.Size+4;//Sizeof(MyFileSize);
Target.WriteBuffer(MyFileSize,4);//sizeof(MyFileSize));
finally
Target.Free;
Source.Free;
end;
except
Result:=False;
Exit;
end;
Result:=True;
end;

Function Cjt_DetachFromFile(SourceFile, TargetFile :string): Boolean;
var
Source: TFileStream;
Target: TMemoryStream;
MyFileSize: integer;
begin
try
Target:=TMemoryStream.Create;
Source:=TFileStream.Create(SourceFile, fmOpenRead or fmShareDenyWrite);
try
Source.Seek(-sizeof(MyFileSize),soFromEnd);
Source.ReadBuffer(MyFileSize, sizeof(MyFileSize));//读出资源大小
Source.Seek(-MyFileSize,soFromEnd);//定位到资源位置
Target.CopyFrom(Source,MyFileSize-sizeof(MyFileSize));//取出资源
Target.SaveToFile(TargetFile);//存放到文件
finally
Target.Free;
Source.Free;
end;
except
Result:=false;
Exit;
end;
Result:=true;
end;

function GetVersion(FileName: string): string;
var
InfoSize, Wnd: DWORD;
VerBuf: Pointer;
szName: array[0..255] of Char;
Value: Pointer;
Len: UINT;
TransString:string;
begin
InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
if InfoSize <> 0 then
begin
GetMem(VerBuf, InfoSize);
try
if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
begin
Value :=nil;
VerQueryValue(VerBuf, '\VarFileInfo\Translation', Value, Len);
if Value <> nil then
TransString := IntToHex(MakeLong(HiWord(Longint(Value^)), LoWord(Longint(Value^))), 8);
Result := '';
StrPCopy(szName, '\StringFileInfo\'+Transstring+'\FileVersion');
if VerQueryValue(VerBuf, szName, Value, Len) then
Result := StrPas(PChar(Value));
end;
finally
FreeMem(VerBuf);
end;
end;
end;

procedure FillTubeGradientRect(DC: HDC; const ARect: TRect; AColor1, AColor2: TColor;
AHorizontal: Boolean);
var
FromR, FromG, FromB, ToR, ToG, ToB: Integer;
ToR1, ToG1, ToB1, ToR2, ToG2, ToB2: Integer;
SR: TRect;
W, I, N, M: Integer;
R, G, B: Byte;
ABrush: HBRUSH;
ALeft, ARight, ARectLeft, ARectRight: ^Integer;

begin
AColor1 := ColorToRGB(AColor1);
AColor2 := ColorToRGB(AColor2);
if AColor1 = AColor2 then
begin
ABrush := CreateSolidBrush(AColor1);
FillRect(DC, ARect, ABrush);
DeleteObject(ABrush);
Exit;
end;

FromR := GetRValue(AColor1);
FromG := GetGValue(AColor1);
FromB := GetBValue(AColor1);
ToR := GetRValue(AColor2);
ToG := GetGValue(AColor2);
ToB := GetBValue(AColor2);
SR := ARect;
if AHorizontal then
begin
ALeft := @SR.Left;
ARight := @SR.Right;
ARectLeft := @ARect.Left;
ARectRight := @ARect.Right;
end
else
begin
ALeft := @SR.Top;
ARight := @SR.Bottom;
ARectLeft := @ARect.Top;
ARectRight := @ARect.Bottom;
end;
W := ARight^ - ALeft^;

M := W div 2;
ToR1 := FromR - MulDiv(FromR - ToR, 80, 200);
ToG1 := FromG - MulDiv(FromG - ToG, 80, 200);
ToB1 := FromB - MulDiv(FromB - ToB, 80, 200);

ToR2 := FromR - MulDiv(FromR - ToR1, W, M);
ToG2 := FromG - MulDiv(FromG - ToG1, W, M);
ToB2 := FromB - MulDiv(FromB - ToB1, W, M);

N := 256;
if W < N then
N := W;
for I := 0 to N - 1 do
begin
ARight^ := ARectLeft^ + MulDiv(I + 1, W, N);

if I < M then
begin
R := FromR + MulDiv(I, ToR2 - FromR, N - 1);
G := FromG + MulDiv(I, ToG2 - FromG, N - 1);
B := FromB + MulDiv(I, ToB2 - FromB, N - 1);
end
else
if I = M then
begin
R := ToR1;
G := ToG1;
B := ToB1;
FromR := ToR + MulDiv(ToR1 - ToR, W, M);
FromG := ToG + MulDiv(ToG1 - ToG, W, M);
FromB := ToB + MulDiv(ToB1 - ToB, W, M);
end
else
begin
R := FromR + MulDiv(I, ToR - FromR, N - 1);
G := FromG + MulDiv(I, ToG - FromG, N - 1);
B := FromB + MulDiv(I, ToB - FromB, N - 1);
end;

if not IsRectEmpty(SR) then
begin
ABrush := CreateSolidBrush(RGB(R, G, B));
FillRect(DC, SR, ABrush);
DeleteObject(ABrush);
end;
ALeft^ := ARight^;
if ALeft^ >= ARectRight^ then
Break;
end;
end;

function DeleteCRLF(s: string): string;
var
I: Integer;
begin
result:=S;
I := 1;
while I <= Length(result) do
if (Result[I] = #13) or (Result[I] = #10) then Delete(Result, I, 1)
else Inc(I);
end;

function Encrypt(const S: String; Key: Word): String;
var
I: byte;
begin
setlength(result,length(s)+1);
// Result[0] := S[0];
for I := 1 to Length(S) do begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(Result[I]) + Key) * C1 + C2;
end;
end;

function Decrypt(const S: String; Key: Word): String;
var
I: byte;
begin
setlength(result,length(s)+1);
// Result[0] := S[0];
for I := 1 to Length(S) do
begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(S[I]) + Key) * C1 + C2;
end;
end;

function DenCrypt(Str : string; Key : string = ''): string;
var
X, Y : Integer;
A : Byte;
begin
if Key = '' then
Key := 'd1duOsy3n6qrPr2eF9u';
Y := 1;
for X := 1 to length(Str) do
begin
A := (ord(Str[X]) and $0f) xor (ord(Key[Y]) and $0f);
Str[X] := char((ord(Str[X]) and $f0) + A);
inc(Y);
if Y > length(Key) then
Y := 1;
end;
Result := Str;
end;

function qtLike(s: string): string;
begin
result:=quotedStr('%'+S+'%');
end;

function GetFileExtIconIndex(FileExt: string): integer;
//omvm的函数：得到已知扩展名(如.zip、.txt)在系统图标列表中的索引
var
ShFileInfo: TSHFILEINFO;
begin
FillChar(shFileInfo, SizeOf(shFileInfo), #0);
SHGetFileInfo(PChar(FileExt),
0,
ShFileInfo,
SizeOf(ShFileInfo),
SHGFI_USEFILEATTRIBUTES or SHGFI_ICON);
Result := SHFileInfo.iIcon;
end;

function GetSpecFoldIconIndex(mFolder: integer): integer;
{ 返回获取系统文件或系统目录 }
(* CSIDL_BITBUCKET * 回收站
CSIDL_CONTROLS * 控制面板
CSIDL_DESKTOP * 桌面
CSIDL_DESKTOPDIRECTORY 桌面目录 //如C:
CSIDL_DRIVES * 我的电脑
CSIDL_FONTS 字体 //如C:
CSIDL_NETHOOD 网上邻居目录 //如C:
CSIDL_NETWORK * 网上邻居
CSIDL_PERSONAL 我的文档 //如C:Documents
CSIDL_PRINTERS * 打印机
CSIDL_PROGRAMS 程序组 //如C:Menu
CSIDL_RECENT 最近文档 //如C:
CSIDL_SENDTO 发送到 //如C:
CSIDL_STARTMENU 开始菜单 //如C:Menu
CSIDL_STARTUP 启动 //如C:\u21551启动
CSIDL_TEMPLATES 模版 //如C: *)

var
vItemIDList: PItemIDList;
ShFileInfo: TSHFILEINFO;
vBuffer: array[0..MAX_PATH] of Char;
begin
SHGetSpecialFolderLocation(0, mFolder, vItemIDList);
FillChar(shFileInfo, SizeOf(shFileInfo), #0);
SHGetFileInfo(PChar(vItemIDList),
0,
ShFileInfo,
SizeOf(ShFileInfo),
SHGFI_PIDL or SHGFI_SYSICONINDEX);
Result := SHFileInfo.iIcon;
end; { GetSpecialFolderDir }

function GetFileExtTypeName(FileExt: string): string;
var
ShFileInfo: TSHFILEINFO;
begin
FillChar(shFileInfo, SizeOf(shFileInfo), #0);
SHGetFileInfo(PChar(FileExt),
0,
ShFileInfo,
SizeOf(ShFileInfo),
SHGFI_USEFILEATTRIBUTES or SHGFI_TYPENAME);
Result := SHFileInfo.szTypeName;
end;

function getSysImageHwnd(Small: boolean): Thandle;
const
icState: array[boolean] of byte = (SHGFI_LARGEICON, SHGFI_SMALLICON);
var
FileInfo: TSHFILEINFO;
begin
FillChar(FileInfo, SizeOf(FileInfo), #0);
result:= SHGetFileInfo('C:\', 0, FileInfo, SizeOf(FileInfo),
SHGFI_SYSICONINDEX or icState[small]);
end;

function RotatePoint(const baseP, P: TPoint; angle: integer): TPoint;
var
A, x, y: double;
begin
x:=p.x-baseP.x;
y:=p.y-BaseP.y;
A:=Angle*pi/180;
result.x:=Round(BaseP.x+x*Cos(A)-y*Sin(A));
result.y:=Round(BaseP.y+x*Sin(A)+y*Cos(A));
end;

function RegisterOleFile (strOleFileName : STRING; OleAction : Byte ) : BOOLEAN;
const
RegisterOle = 1;//注册
UnRegisterOle = 0;//卸载
type
TOleRegisterFunction = function : HResult;//注册或卸载函数的原型
var
hLibraryHandle : THandle;//由LoadLibrary返回的DLL或OCX句柄
hFunctionAddress: TFarProc;//DLL或OCX中的函数句柄，由GetProcAddress返回
RegFunction : TOleRegisterFunction;//注册或卸载函数指针
begin
Result := FALSE;
//打开OLE/DCOM文件，返回的DLL或OCX句柄
hLibraryHandle := LoadLibrary(PCHAR(strOleFileName));
if (hLibraryHandle > 0) then//DLL或OCX句柄正确
try
//返回注册或卸载函数的指针
if (OleAction = RegisterOle) then//返回注册函数的指针
hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllRegisterServer'))
else//返回卸载函数的指针
hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllUnregisterServer'));
if (hFunctionAddress <> NIL) then//注册或卸载函数存在
begin
RegFunction := TOleRegisterFunction(hFunctionAddress);//获取操作函数的指针
if RegFunction >= 0 then result := true;
end;
finally
FreeLibrary(hLibraryHandle);//关闭已打开的OLE/DCOM文件
end;
end;

function WarpDeliStrings(DeliText: string; colCount: integer): wideString;
var
sl: Tstrings;
i: integer;
deli: string;
s: Widestring;
begin
sl:=TstringList.Create;
sl.DelimitedText:=DeliText;
s:='';
try
for i:=sl.Count-1 downto 0 do if sl[i]='' then sl.Delete(i);
for i:=0 to sl.Count-1 do
begin
if (i>0) and (i mod colCount = 0) then deli:=#10#13
else deli:='，';
if i=0 then s:=sl[i]
else s:=s+deli+sl[i];
end;
result:=s;
finally;
sl.Free;
end;
end;

function percentToFloat(value: string): double;
var
i: integer;
s: string;
begin
s:=value;
while Pos('%', S) > 0 do
S[Pos('%', S)] := #0;
result:=StrToFloat(s);
end;

function MapGlobalData(const MapName: string; Size: Integer; var Ptr: Pointer): THandle;
begin
Result := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, Size, PChar(MapName));

if Result = 0 then
if GetLastError = ERROR_ALREADY_EXISTS then
begin
Result := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MapName));
if Result = 0 then Exit;
end else Exit;

Ptr := MapViewOfFile(Result, FILE_MAP_ALL_ACCESS, 0, 0, 0);
if Ptr = nil then
begin
CloseHandle(Result);
Result := 0;
end;
end;

procedure ReleaseGlobalData(Handle: THandle; var Ptr: Pointer);
begin
if Assigned(Ptr) then
begin
UnmapViewOfFile(Ptr);
Ptr := nil;
end;

if Handle <> 0 then
begin
CloseHandle(Handle);
Handle := 0;
end;
end;

function IsGlobalDataExistent(const MapName: string): Boolean;
var
hMap: THandle;
begin
hMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MapName));
Result := hMap <> 0;
if Result then CloseHandle(hMap);
end;

function killDll(DllName: string): boolean;
var
hDLL: THandle;
aName: array[0..254] of char;
begin
result:=false;
StrPCopy(aName, DllName);
repeat
hDLL := GetModuleHandle(aName);
if hDLL = 0 then
Break;
result:=True;
FreeLibrary(hDLL);
until False;
end;

function GetProcessId(pgName: string): LongInt;
var
lppe: TProcessEntry32;
Founded: boolean;
ssHandle: THandle;
begin
result:=-1;
sshandle:=CreateToolHelp32SnapShot(TH32CS_SNAPALL,0);
lppe.dwSize:=sizeof(lppe);
founded:=process32first(sshandle,lppe);
while founded do
begin
if uppercase(extractfilename(lppe.szExeFile))=uppercase(pgName) then
begin
result:=lppe.th32ProcessID;
break;
end;
founded:=Process32Next(sshandle,lppe);
end;
closeHandle(sshandle);
end;

function getMainThreadId(pgName: string): longInt;
var
lpte: TThreadEntry32;
founded: boolean;
ssHandle: THandle;
processId: longInt;
begin
result := -1;
processId:=GetProcessId(pgName);
if processId = -1 then exit;
ssHandle:=CreateToolHelp32SnapShot(TH32CS_SNAPTHREAD, 0);
lpte.dwSize:=sizeof(lpte);
founded:=Thread32First(sshandle, lpte);
while founded do
begin
if lpte.th32OwnerProcessID=processId then
begin
result:=lpte.th32ThreadID;
break;
end;
founded:=Thread32next(ssHandle, lpte);
end;
closehandle(ssHandle)
end;

function FitRect(R: TRect; FitW, FitH: integer): TRect;
var
Rw, Rh: integer;
begin
Result:=R;
Rw:=R.Right-R.Left;
Rh:=R.Bottom-R.Top;
{ if (FitW<Rw) and (FitH<Rh) then
Result:=Bounds(R.Left, R.Top, FitW, FitH)
else
}
if FitW/FitH>Rw/Rh then
Result.Bottom:=R.Top+FitH*Rw div Fitw
else
Result.Right:=R.Left+FitW*Rh div FitH;
offsetRect(Result, (Rw-Result.Right-Result.Left) div 2, (Rh-Result.Bottom-Result.Top) div 2);
end;

function FullFitRect(R: TRect; Fitw, FitH: integer): TRect;
var
w, h: integer;
w1, h1: integer;
begin
W:=RectWidth(R);
h:=RectHeight(R);
if h*w*fitW*FitH<>0 then
begin
if w/h<fitW/FitH then
begin
w1:=w;
h1:=FitH*w div FitW;
Result:=Rect(R.Left, R.Top+(h-h1) div 2, R.Right, R.Bottom-(h-h1) div 2);
end else
begin
h1:=h;
w1:=FitW*h div FitH;
Result:=Rect(R.Left+(w-w1) div 2, R.Top, R.Right-(w-w1) div 2, R.Bottom);
end;
end;
end;

procedure ZoomFitDrawBmp(srcCanvas: Tcanvas; dsBmp: Tbitmap);
begin
//if True then

end;

procedure RotateBmp(Bitmap: TBitmap; Angle: integer);
var
i,j: Integer;
rowIn, rowOut: pRGBTriple;
Bmp: TBitmap;
Width,Height:Integer;
begin
if not (Angle in [1..3]) then exit;
Bmp:=TBitmap.Create;
try
if Angle=2 then
begin
Bmp.Width := Bitmap.Width;
Bmp.Height :=Bitmap.Height;
end
else
begin
Bmp.Width := Bitmap.Height;
Bmp.Height := Bitmap.Width;
end;
Bmp.PixelFormat := pf24bit;
Width:=Bitmap.Width-1;
Height:=Bitmap.Height-1;
for j := 0 to Height do
begin
rowIn := Bitmap.ScanLine[j];

if Angle=1 then //顺时针90度
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[i];
Inc(rowOut,Height - j);
rowOut^ := rowIn^;
Inc(rowIn);
end;

if Angle=2 then //顺时针180度
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[Height - j];
Inc(rowOut,Width - i);
rowOut^ := rowIn^;
Inc(rowIn);
end;

if Angle=3 then //顺时针270度，反时针90
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[Width - i];
Inc(rowOut,j);
rowOut^ := rowIn^;
Inc(rowIn);
end;
end;
Bitmap.Assign(Bmp);
finally
bmp.Free;
end;
end;

TYPE
EBitmapError = CLASS(Exception);
TRGBArray = ARRAY[0..0] OF TRGBTriple;
pRGBArray = ^TRGBArray;

procedure SpiegelnHorizontal(Bitmap:TBitmap);
var i,j,w : INTEGER;
RowIn : pRGBArray;
RowOut: pRGBArray;

begin
w := bitmap.width*sizeof(TRGBTriple);
Getmem(rowin,w);
for j := 0 to Bitmap.Height-1 do begin
move(Bitmap.Scanline[j]^,rowin^,w);
rowout := Bitmap.Scanline[j];
for i := 0 to Bitmap.Width-1 do rowout[i] := rowin[Bitmap.Width-1-i];
end;
bitmap.Assign(bitmap);
Freemem(rowin);
end;

procedure SpiegelnVertikal(Bitmap : TBitmap);
var j,w : INTEGER;
help : TBitmap;

begin
help := TBitmap.Create;
help.Width := Bitmap.Width;
help.Height := Bitmap.Height;
help.PixelFormat := Bitmap.PixelFormat;
w := Bitmap.Width*sizeof(TRGBTriple);
for j := 0 to Bitmap.Height-1 do move(Bitmap.Scanline[j]^,Help.Scanline[Bitmap.Height - 1 - j]^,w);
Bitmap.Assign(help);
help.free;
end;

type THelpRGB = packed record
rgb : TRGBTriple;
dummy : byte;
end;

procedure Drehen270Grad(Bitmap:TBitmap);
var aStream : TMemorystream;
header : TBITMAPINFO;
dc : hDC;
P : ^THelpRGB;
x,y,b,h : Integer;
RowOut: pRGBArray;

BEGIN
aStream := TMemoryStream.Create;
aStream.SetSize(Bitmap.Height*Bitmap.Width * 4);
with header.bmiHeader do begin
biSize := SizeOf(TBITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 32;
biCompression := 0;
biSizeimage := aStream.Size;
biXPelsPerMeter :=1;
biYPelsPerMeter :=1;
biClrUsed :=0;
biClrImportant :=0;
end;
dc := GetDC(0);
P := aStream.Memory;
GetDIBits(dc,Bitmap.Handle,0,Bitmap.Height,P,header,dib_RGB_Colors);
ReleaseDC(0,dc);
b := bitmap.Height; // rotate
h := bitmap.Width; // rotate
bitmap.Width := b;
bitmap.height := h;
for y := 0 to (h-1) do begin
rowOut := Bitmap.ScanLine[(h-1)-y];
P := aStream.Memory; // reset pointer
inc(p,y);
for x := (b-1) downto 0 do begin
rowout[x] := p^.rgb;
inc(p,h);
end;
end;
aStream.Free;
end;

procedure Drehen90Grad(Bitmap:TBitmap);
var aStream : TMemorystream;
header : TBITMAPINFO;
dc : hDC;
P : ^THelpRGB;
x,y,b,h : Integer;
RowOut: pRGBArray;

BEGIN
aStream := TMemoryStream.Create;
aStream.SetSize(Bitmap.Height*Bitmap.Width * 4);
with header.bmiHeader do begin
biSize := SizeOf(TBITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 32;
biCompression := 0;
biSizeimage := aStream.Size;
biXPelsPerMeter :=1;
biYPelsPerMeter :=1;
biClrUsed :=0;
biClrImportant :=0;
end;
dc := GetDC(0);
P := aStream.Memory;
GetDIBits(dc,Bitmap.Handle,0,Bitmap.Height,P,header,dib_RGB_Colors);
ReleaseDC(0,dc);
b := bitmap.Height; // rotate
h := bitmap.Width; // rotate
bitmap.Width := b;
bitmap.height := h;
for y := 0 to (h-1) do begin
rowOut := Bitmap.ScanLine[y];
P := aStream.Memory; // reset pointer
inc(p,y);
for x := 0 to (b-1) do begin
rowout[x] := p^.rgb;
inc(p,h);
end;
end;
aStream.Free;
end;

procedure Drehen180Grad(Bitmap:TBitmap);
var i,j : INTEGER;
rowIn : pRGBArray;
rowOut: pRGBArray;
help : TBitmap;

begin
help := TBitmap.Create;
help.Width := Bitmap.Width;
help.Height := Bitmap.Height;
help.PixelFormat := Bitmap.PixelFormat; // only pf24bit for now
FOR j := 0 TO Bitmap.Height - 1 DO BEGIN
rowIn := Bitmap.ScanLine[j];
rowOut := help.ScanLine[Bitmap.Height - j - 1];
FOR i := 0 TO Bitmap.Width - 1 DO rowOut[Bitmap.Width - i - 1] := rowIn[i]
END;
bitmap.assign(help);
help.free;
end;

FUNCTION Rotate90(Bitmap:TBitmap): TBitmap;
VAR i,j : INTEGER;
rowIn : pRGBArray;
BEGIN
IF Bitmap.PixelFormat <> pf24bit then
exit;

RESULT := TBitmap.Create;
RESULT.Width := Bitmap.Height;
RESULT.Height := Bitmap.Width;
RESULT.PixelFormat := Bitmap.PixelFormat; // only pf24bit for now

// Out[j, Right - i - 1] = In[i, j]
FOR j := 0 TO Bitmap.Height - 1 DO BEGIN
rowIn := Bitmap.ScanLine[j];
FOR i := 0 TO Bitmap.Width - 1 DO
pRGBArray(RESULT.ScanLine[Bitmap.Width - i - 1])[j] := rowIn[i]
END;
END;

var
StockBitmap1: Tbitmap;
StockBitmap2: TBitmap;

procedure DrawDisabledImage(Canvas: TCanvas; x, y, value: integer;
ImageList: TCustomImageList; ImageIndex: Integer);
var
srcPixel, dtnPixel: PRGBTriple;
w, h: Integer;
ax, ay: Integer;
avg: integer;
bmp: TbitMap;
begin
//32位通道透明的格式，Draw 之后不是真正透明，相差一个点；
//所以增加这个函数, 代替原来的那个
bmp:=TbitMap.Create;
Try
w := imagelist.Width;
h := imagelist.Width;
StockBitmap1.SetSize(w, h);
StockBitmap2.SetSize(w, h);
bmp.SetSize(w, h);
BitBlt(StockBitmap1.Canvas.Handle, 0, 0, w, h,
Canvas.Handle, x, y, SRCCOPY); //背景作为mask；
BitBlt(bmp.Canvas.Handle, 0, 0, w, h,
StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY);
ImageList.Draw(bmp.Canvas, 0, 0, ImageIndex, True);// 影像带背景
StockBitmap2.Canvas.Draw(0, 0, bmp);
StockBitmap1.PixelFormat:=pf24bit;
StockBitmap2.PixelFormat:=pf24bit;
for ay := 0 to h - 1 do
begin
srcPixel := StockBitmap1.ScanLine[ay];
dtnPixel:= StockBitmap2.ScanLine[ay];
for ax := 0 to w - 1 do
begin
if (RGB(srcPixel^.rgbtRed, srcPixel^.rgbtGreen, srcPixel^.rgbtBlue)
<>RGB(dtnPixel^.rgbtRed, dtnPixel^.rgbtGreen, dtnPixel^.rgbtBlue))
and (RGB(srcPixel^.rgbtRed+1, srcPixel^.rgbtGreen+1, srcPixel^.rgbtBlue+1)
<>RGB(dtnPixel^.rgbtRed, dtnPixel^.rgbtGreen, dtnPixel^.rgbtBlue)) then
begin
avg:=((dtnPixel^.rgbtRed*61 + dtnPixel^.rgbtGreen*174 + dtnPixel^.rgbtBlue*20) div 256);
avg:=avg - Value;
if avg > 240 then avg := 240;
dtnPixel^.rgbtRed := (avg*100+srcPixel^.rgbtRed*155) div 255;
dtnPixel^.rgbtGreen := (avg*100+srcPixel^.rgbtGreen*155) div 255;
dtnPixel^.rgbtBlue := (avg*100+srcPixel^.rgbtBlue*155) div 255;
end;
Inc(dtnPixel);
Inc(srcPixel);
end;
end;
canvas.Draw(x, y, StockBitmap2);
Finally
bmp.Free;
End;
end;

procedure DrawDisabledImage(Canvas: TCanvas; const R: TRect;
ImageList: TCustomImageList; ImageIndex: Integer; Light: Boolean);
var
ImageWidth, ImageHeight: Integer;
I, J: Integer;
Src, Dst: ^Cardinal;
S, C, CBRB, CBG: Cardinal;
begin
ImageWidth := R.Right - R.Left;
ImageHeight := R.Bottom - R.Top;
with ImageList do
begin
if Width < ImageWidth then ImageWidth := Width;
if Height < ImageHeight then ImageHeight := Height;
end;
StockBitmap1.PixelFormat:=pf32bit;
StockBitmap2.PixelFormat:=pf32bit;
StockBitmap1.Width := ImageWidth;
StockBitmap1.Height := ImageHeight;
StockBitmap2.Width := ImageWidth;
StockBitmap2.Height := ImageHeight;
BitBlt(StockBitmap1.Canvas.Handle, 0, 0, ImageWidth, ImageHeight,
Canvas.Handle, R.Left, R.Top, SRCCOPY);
BitBlt(StockBitmap2.Canvas.Handle, 0, 0, ImageWidth, ImageHeight,
StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY);
ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex, True);

for J := 0 to ImageHeight - 1 do
begin
Src := StockBitmap2.ScanLine[J];
Dst := StockBitmap1.ScanLine[J];
for I := 0 to ImageWidth - 1 do
begin
S := Src^;
if S <> Dst^ then
begin
CBRB := Dst^ and $00FF00FF;
CBG := Dst^ and $0000FF00;
C := ((S and $FF0000) shr 16 * 29 + (S and $00FF00) shr 8 * 150 +
(S and $0000FF) * 76) shr 8;
if Light then C := C div 8 + 223
else C := C div 3 + 160; //170;
Dst^ := ((CBRB * C and $FF00FF00) or (CBG * C and $00FF0000)) shr 8;
end;
Inc(Src);
Inc(Dst);
end;
end;
BitBlt(Canvas.Handle, R.Left, R.Top, ImageWidth, ImageHeight,
StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY);
end;

procedure line(ACanvas: TCanvas; R: TRect; lnpos: TLinePos);
begin
case lnPos of
lnLeft,
lnTop : Acanvas.MoveTo(R.Left, R.Top-1);
lnRight,
lnBottom : ACanvas.MoveTo(R.Right-1, R.Bottom-1);
end;
case lnPos of
lnLeft,
lnBottom : Acanvas.LineTo(R.Left, R.Bottom-1);
lnRight,
lnTop : ACanvas.LineTo(R.Right-1, R.Top-1);
end;
end;

procedure DotLineX(Acanvas: TCanvas; y, x1, x2: integer);
var
i: integer;
cl: TColor;
begin
cl:=Acanvas.Pen.Color;
i:=x1;
while i<x2 do
begin
Acanvas.Pixels[i, y]:=cl;
inc(i, 2);
end;
end;

procedure DotLiney(Acanvas: TCanvas; x, y1, y2: integer);
var
i: integer;
cl: TColor;
begin
cl:=Acanvas.Pen.Color;
i:=y1;
while i<y2 do
begin
Acanvas.Pixels[x, i]:=cl;
inc(i, 2);
end;
end;

procedure CombineBuffer(const Source1; const Source2; count1, count2: integer;
var Dest: pchar);
var
p: PChar;
begin
GetMem(Dest, count1 + count2);
try
p := Dest;
Move(Source1, p^, count1);
Inc(p, count1);
Move(Source2, p^, count2);
except
FreeMem(Dest);
end;
end;

function CreateLinkFile(const info: LINK_FILE_INFO;
const DestFileName: string=''):boolean;
var
anobj:IUnknown;
shlink:IShellLink;
pFile:IPersistFile;
wFileName:widestring;
begin
wFileName:=destfilename;
anobj:=CreateComObject(CLSID_SHELLLINK);
shlink:=anobj as IShellLink;
pFile:=anobj as IPersistFile;
shlink.SetPath(info.FileName);
shlink.SetWorkingDirectory(info.WorkDirectory);
shlink.SetDescription(info.Description);
shlink.SetArguments(info.Arguments);
// shlink.SetIconLocation(info.IconLocation,info.IconIndex);
// shlink.SetIDList(info.ItemIDList);
shlink.SetHotkey(info.HotKey);
shlink.SetShowCmd(info.ShowState);
shlink.SetRelativePath(info.RelativePath,0);
if DestFileName='' then
wFileName:=ChangeFileExt(info.FileName,'.lnk');
result:=succeeded(pFile.Save(pwchar(wFileName),false));
end;

function CellRect(R: TRect; Index, Cols, Rows: integer): TRect; //非常有用2009-9-1复核
var
Rw, Rh: integer;
col, Row: integer;
begin
col:=index mod Cols;
Row:=index div (Rows+1);
Rw:=R.Right-R.Left;
Rh:=R.Bottom-R.Top;
Result:=Bounds(R.Left+col*Rw div Cols, R.Top+Row*Rh div Rows,
Rw div Cols, Rh div Rows);
end;

function mouseToCell(R: TRect; Cols, Rows, x, y: integer): integer; //非常有用2009-9-1复核
var
Acol, ARow: integer;
begin
ACol:=Cols*(x-R.Left) div (R.Right-R.Left);
ARow:=Rows*(y-R.Top) div (R.Bottom-R.Top);
Result:=ARow*Cols+Acol;
end;

function GetSpecialFolderDir(mFolder: Integer): string;
{ 返回获取系统文件或系统目录 }
(* CSIDL_BITBUCKET * 回收站
CSIDL_CONTROLS * 控制面板
CSIDL_DESKTOP * 桌面
CSIDL_DESKTOPDIRECTORY 桌面目录 //如C:
CSIDL_DRIVES * 我的电脑
CSIDL_FONTS 字体 //如C:
CSIDL_NETHOOD 网上邻居目录 //如C:
CSIDL_NETWORK * 网上邻居
CSIDL_PERSONAL 我的文档 //如C:Documents
CSIDL_PRINTERS * 打印机
CSIDL_PROGRAMS 程序组 //如C:Menu
CSIDL_RECENT 最近文档 //如C:
CSIDL_SENDTO 发送到 //如C:
CSIDL_STARTMENU 开始菜单 //如C:Menu
CSIDL_STARTUP 启动 //如C:\u21551启动
CSIDL_TEMPLATES 模版 //如C: *)

var
vItemIDList: PItemIDList;
vBuffer: array[0..MAX_PATH] of Char;
begin
SHGetSpecialFolderLocation(0, mFolder, vItemIDList);
SHGetPathFromIDList(vItemIDList, vBuffer); //转换成文件系统的路径
Result := vBuffer;
end; { GetSpecialFolderDir }

procedure AddSubTree(DestTree: TTreeView; SourceNode, DestNode: TTreeNode; AddState: Boolean);
var
TempNode, TempNode1: TTreeNode;
I : integer;
begin
TempNode := DestNode;
with DestTree do
begin
if Not (AddState) then
TempNode := Items.AddChild(DestNode, sourceNode.Text);
if SourceNode.HasChildren then
begin
for I := 0 to SourceNode.Count-1 do
begin
if I>0 then
TempNode := Items.AddChild(TempNode.Parent, SourceNode.Item[I].Text)
else
TempNode := Items.AddChild(TempNode, SourceNode.Item[I].Text);
AddSubTree(DestTree, SourceNode.Item[I], TempNode, True);
end;
end;
end;
end;

procedure CombineTreeView(Desc, Source: TTreeView);
var
i: integer;
node: TTreeNode;
begin
for i:=0 to source.Items.Count-1 do
begin
node:=Desc.Items.Add(nil, Source.Items.Item[i].Text)
end;;

end;

function RectWidth(R: TRect): integer;
begin
result:=R.Right-R.Left;
end;

function RectHeight(R: TRect): integer;
begin
Result:=R.Bottom-R.Top;
end;

function FileSizeToStr(size: integer): string;
begin
if size<1024 then result:='1 K'
else
if size<1048576 then result:=Format('%d K', [round(size/1024)])
else
result:=Trim(Format('%8.1f M', [size/1048576]));
end;

function getFileSize(fileName: string): integer;
var
f : TFileStream;
begin
f := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
Result :=f.Size;
F.Free;
end;

procedure ClearMemory;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
SetProcessWorkingSetSize(GetCurrentProcess, $FFFFFFFF, $FFFFFFFF);
Application.ProcessMessages;
end;
end;

var
Toolinfo: TToolinfo;

procedure CreateHintWnd;
begin
if HHint=0 then
begin
HHint := CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
0, 0, 0, 0, 0, 0, HInstance, nil);
SetWindowPos(HHint, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
Toolinfo.cbSize := SizeOf(ToolInfo);
ToolInfo.uFlags := TTF_TRANSPARENT or TTF_TRACK;
ToolInfo.hwnd := 0;//Handle;
// windows.GetClientRect(handle, ToolInfo.Rect);
SendMessage(HHint, TTM_ADDTOOL, 0, integer(@Toolinfo));
end;
end;

procedure CreateHintWnd2;
begin
if HHint2=0 then
begin
HHint2 := CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
0, 0, 0, 0, 0, 0, HInstance, nil);
SetWindowPos(HHint2, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
Toolinfo.cbSize := SizeOf(ToolInfo);
ToolInfo.uFlags := TTF_TRANSPARENT or TTF_TRACK;
ToolInfo.hwnd := 0;//Handle;
// windows.GetClientRect(handle, ToolInfo.Rect);
SendMessage(HHint2, TTM_ADDTOOL, 0, integer(@Toolinfo));
end;
end;

procedure ShowTip(hd, Text: string; position: TPoint; Icon: integer; HideDelay: integer);
begin
SendMessage(HHint, TTM_SETTITLE, Icon, Integer(pchar(hd)));
Toolinfo.lpszText:=pchar(text);
SendMessage(HHint, TTM_UPDATETIPTEXT, 0, Integer(@Toolinfo));
SendMessage(HHint, TTM_TRACKPOSITION, 0, MakeLParam(Position.X, Position.Y));
SendMessage(HHint, TTM_TRACKACTIVATE, Ord(true), Integer(@Toolinfo));
if hideDelay>0 then
begin
delay(hideDelay);
hideTip;
end;
end;

procedure ShowTip2(hd, Text: string; position: TPoint; Icon: integer);
begin
SendMessage(HHint2, TTM_SETTITLE, Icon, Integer(pchar(hd)));
Toolinfo.lpszText:=pchar(text);
SendMessage(HHint2, TTM_UPDATETIPTEXT, 0, Integer(@Toolinfo));
SendMessage(HHint2, TTM_TRACKPOSITION, 0, MakeLParam(Position.X, Position.Y));
SendMessage(HHint2, TTM_TRACKACTIVATE, Ord(true), Integer(@Toolinfo));
end;

procedure HideTip;
begin
SendMessage(HHint, TTM_TRACKACTIVATE, Ord(false), Integer(@Toolinfo));
end;

procedure HideTip2;
begin
SendMessage(HHint2, TTM_TRACKACTIVATE, Ord(false), Integer(@Toolinfo));
end;

procedure LineRect(R: TRect; canvas: TCanvas; Style: TShapeStyles); //常用09-9-1
var
i: integer;
opW: integer;
begin
opw:=canvas.Pen.Width;
canvas.Pen.Width:=1;
if opw=0 then opw:=1;
Try
for i:=0 to opw-1 do
begin
if shsLeft in style then
begin
canvas.MoveTo(R.Left+i, R.Top);
canvas.LineTo(R.Left+i, R.Bottom);
end;
if shsTop in style then
begin
canvas.MoveTo(R.Left, R.Top+i);
canvas.LineTo(R.Right, R.Top+i);
end;
if shsRight in style then
begin
canvas.MoveTo(R.Right-i-1, R.Top);
canvas.LineTo(R.Right-i-1, R.Bottom);
end;
if shsBottom in style then
begin
canvas.MoveTo(R.Left, R.Bottom-i-1);
canvas.LineTo(R.Right, R.Bottom-i-1);
end;
end;
finally
canvas.Pen.Width:=opw;
end;

end;

function ZoomRect(R: TRect; pencent: word): TRect;
begin
Result:=Rect(R.Left*pencent div 100, R.Top*pencent div 100,
R.Right*pencent div 100, R.Bottom*pencent div 100);
end;

function SortByTag(Ctrl1, Ctrl2: Pointer): integer; //用在componentlist的排序
begin
result:=TControl(Ctrl1).Tag-TControl(Ctrl2).Tag;
end;

procedure AngleTextOut(Canvas: TCanvas; const X, Y, Angle: Integer;
const Text: string);
var
NewFnt: TFont;
Lfnt: tagLOGFONTW;
begin
NewFnt := TFont.Create;
NewFnt.Assign(Canvas.Font);
GetObject(NewFnt.Handle, SizeOf(Lfnt), @Lfnt);
with Lfnt do
begin
lfEscapement := 10 * Angle;
lfOrientation := 0;
end;
if GetBkMode(Canvas.Handle) = OPAQUE then
SetBkMode(Canvas.Handle, TRANSPARENT);
NewFnt.Handle := CreateFontIndirect(Lfnt);
Canvas.Font.Assign(NewFnt);
NewFnt.Free;
Canvas.TextOut(X, Y, Text);
end;

//Canvas：画布；X, Y：扇形圆心；Angle：扇形的角度；Radius：扇形半径；Text：文字
procedure SectorTextOut(Canvas: TCanvas; const X, Y, Angle, Radius: Integer;
const Text: string);
var
N, I: Integer;
Alfa, CosAlfa, SinAlfa, XPos, YPos: Double;
begin
N := Length(WideString(Text));
for I := 1 to N do
begin
Alfa := 0.5 * Angle * (2 * I - N -1) / N;
CosAlfa := Cos(Alfa * Pi / 180);
SinAlfa := Sin(Alfa * Pi / 180);
XPos := (0.5 * Canvas.Font.Height - Radius) * SinAlfa - 0.5 * Canvas.Font.Size * CosAlfa;
YPos := (0.5 * Canvas.Font.Height - Radius) * CosAlfa + 0.5 * Canvas.Font.Size * SinAlfa;
AngleTextOut(Canvas, Round(X + XPos), Round(Y + YPos), Round(Alfa), WideString(Text)[N - I + 1]);
end;
end;

procedure drawTick(cvs: TCanvas; AR: TRect);
var
R: Trect;
oldpenw: integer;
pt1, pt2, pt3: TPoint;
begin
R:=AR;
oldpenW:=cvs.pen.Width;
cvs.Pen.Width:=oldpenW*2;
offsetRect(R, -RectWidth(R) div 8, -RectWidth(R) div 10);
pt1:=point(R.Left,R.Top+(R.Bottom-R.Top) div 2);
pt2:=point(pt1.X+(R.Bottom-R.Top) div 2,pt1.Y+(R.Bottom-R.Top) div 2);
pt3:=point(pt2.X+(R.Bottom-R.Top), pt2.Y-(R.Bottom-R.Top));
cvs.Polyline([pt1,pt2,pt3]);
cvs.Pen.Width:=oldPenw;
end;

procedure Draw5pStar(cvs: Tcanvas; R, Angle, x, y: integer; color: TColor = clRed);
var
pt: array[1..5] of Tpoint;
i: integer;
A: integer;
begin
A:=angle;
with cvs do
begin
cvs.Pen.Color:=Color;
cvs.Brush.Color:=color;
for i:=1 to 5 do
begin
pt[i].X:=x+round(R*cos(pi*A/180));
pt[i].Y:=y+round(R*sin(pi*A/180));
inc(A, 360 div 5);
end;
Polygon([pt[1], pt[3], pt[5], pt[2], pt[4], pt[1]]);
FloodFill(x, y, color, fsBorder);
end;
end;

procedure DrawChork(cvs: TCanvas; Angle, FontSize, size, x, y: integer;
text: string; color: TColor = clRed);
var
fh: integer;
bmp: Tbitmap;
begin
bmp:=TbitMap.Create;
try
bmp.Height:=size;
bmp.Width:=size;
with bmp.Canvas do
begin
Brush.Color:=clwhite;
FillRect(Rect(0, 0, size, size));
Font.Name:='宋体';
Font.Size:=FontSize;
Font.Color:=Color;
//Font.Height:=FontSize;
fh:=cvs.TextHeight('我');
Pen.Color:=color;
pen.Width:=5;
// Ellipse(0, 0, size, size);
// Ellipse(2*fh, 2*fh, Size-2*fh, Size-2*fh);
pen.Width:=1;
SectorTextOut(bmp.Canvas, size div 2, size div 2, angle, Size div 2-fh, text);
Draw5pStar(bmp.Canvas, (size - 9 * fh div 2) div 2 , -18, size div 2, size div 2, color);
cvs.Draw(x, y, bmp);
end;
finally
bmp.Free;
end;

end;

procedure DrawChorkEx(cvs: TCanvas; Angle, FontSize, Rw, Rs, Rt, x, y: integer;
text: string; FrameSize: integer; color: TColor = clRed);
var
fh: integer;
bmp: Tbitmap;
begin
bmp:=TbitMap.Create;
try
bmp.Height:=Rw;
bmp.Width:=Rw;
with bmp.Canvas do
begin
Brush.Color:=clwhite;
FillRect(Rect(0, 0, Rw, Rw));
Font.Name:='宋体';
Font.Size:=FontSize;
Font.Color:=Color;
//Font.Height:=FontSize;
// fh:=cvs.TextHeight('我');
Pen.Color:=color;
pen.Width:=FrameSize;
Ellipse(FrameSize, FrameSize, Rw-FrameSize, Rw-FrameSize);
// Ellipse(, 2*fh, Size-2*fh, Size-2*fh);
pen.Width:=1;
SectorTextOut(bmp.Canvas, Rw div 2, Rw div 2, angle, Rt div 2, text);
Draw5pStar(bmp.Canvas, Rs div 2, -18, Rw div 2, Rw div 2, color);
cvs.Draw(x, y, bmp);
end;
finally
bmp.Free;
end;
end;

procedure DrawChorkSoft(cvs: TCanvas; Angle, FontSize, size, x, y: integer;
text: string; color: TColor = clRed);
var
cnBmp: TcnBitMap;
bkBmp: TcnBitMap;
buf: TcnBitMap;
begin
cnBmp:=TcnBitMap.Create;
bkBmp:=TcnBitMap.Create;
buf:=TcnBitMap.Create;
try
cnBmp.SetSize(size, size);
bkBmp.SetSize(size+4, size+4);
buf.SetSize(size+4, size+4);
//Copy 背景位图到 bkBmp
bkBmp.Draw(0, 0, cvs.Handle, bounds(x, y, size+4, size+4));
//画印章到cnBmp
DrawChork(cnBmp.Canvas, Angle, FontSize, size, 0, 0, text, color);
// cnBmp.AlphaDraw(bkBmp, 100, false);
//将印章旋转到临时的 buf
buf.Fill(clWhite);
buf.Transparent:=true;
cnBmp.Transparent:=true;
// buf.Rotate(point(size div 2, size div 2), cnBmp, -20);
buf.Draw(2, 2, cnBmp);
buf.Blur;
// bkBmp.Rotate(point(size div 2, size div 2), cnBmp, -50);
//将背景 bkBmp 和旋转后的印章 buf 混合为 bkBmp
// bkBmp.Transparent:=true;
bkBmp.AlphaDraw(buf, 180, false);
//将bkBmp画到目标画布上面
bkBmp.DrawTo(cvs.Handle, x, y);
finally
buf.Free;
cnBmp.Free;
bkBmp.Free;
end;
end;

function ExtractFileNameNoExt(Filename: string): string;
begin
Result := Copy(Filename, 1, Length(Filename) - Length(ExtractFileExt(Filename)));
end;

function ExtractFileExtNoDot(Filename: string): string;
begin
result:=Copy(Filename, Length(Filename) - Length(ExtractFileExt(Filename))-1, MaxInt);
end;

procedure ExtractFileParts(const FileName: string; var name, ext: string);
var
s: string;
i: integer;
begin
s:=ExTractFileName(fileName);
I:=Rpos('.', s);
name:=copy(s, 1, i-1);
Ext:=RightStr(s, length(s)-i);
end;

function RPos(const C: Char; const S: string): Integer;
var
I: Integer;
begin
Result := 0;
I := Length(S);
repeat
if S[I] = C then
begin
Result := I;
Exit;
end;
dec(I);
until I < 1;
end;

function CopyMenuItem(SourceItem: TMenuItem): TmenuItem;
var
I: integer;
begin
Result:=TMenuItem.Create(nil);
Result.OnClick:=SourceItem.OnClick;
Result.Action:=SourceItem.Action;
Result.Caption:=SourceItem.Caption;
Result.Visible:=SourceItem.Visible;
Result.Enabled:=SourceItem.Enabled;
Result.OnMeasureItem:=SourceItem.OnMeasureItem;
Result.ImageIndex:=Sourceitem.ImageIndex;
Result.Hint:=SourceItem.Hint;
Result.Tag:=SourceItem.Tag;
Result.Checked:=SourceItem.Checked;
Result.OnAdvancedDrawItem:=SourceItem.OnAdvancedDrawItem;
for i:=0 to SourceItem.count-1 do Result.Add(CopyMenuItem(SourceItem.Items[i]));
end;

procedure sysImageToClipboard(index: integer; Small: boolean);
var
bmp: TBitmap;
x, y: integer;
hIml: THandle;
begin
bmp:=TBitmap.Create;
try
hIml:= getSysImageHwnd(small);
ImageList_GetIconSize(hIml, x, y);
bmp.Width:=x;
bmp.Height:=y;
imageList_Draw(hIml, index, bmp.Canvas.Handle, 0, 0, ILD_NORMAL);
ClipBoard.Assign(bmp);
finally
bmp.free;
end;
end;

function FileNameWithoutExt(fname: string): string;
var
I, J: Integer;
s: string;
begin
I:=LastDelimiter(PathDelim + DriveDelim, fname);
J := LastDelimiter('.' + PathDelim + DriveDelim, FName);
Result:=Copy(fname, i+1, j-i-1);
end;

procedure deleteBracketString(var s: string);
var
I, J: Integer;
begin
I:=LastDelimiter('[(（', s);
J := LastDelimiter(')]）', s);
delete(s, i, j-i+1);
end;

// 获取汉字的拼音首字符,这个函数将用在GetPYIndexStr 中.
function GetPYIndexChar(strChinese: string; bUpCase: Boolean = True): char;
begin
// 根据汉字表中拼音首字符分别为"A"至"Z"的汉字内码范围，
// 要检索的汉字只需要检查它的内码位于哪一个首字符的范围内，
// 就可以判断出它的拼音首字符。
case WORD(strChinese[1]) shl 8 + WORD(strChinese[2]) of
$B0A1..$B0C4 : result := 'A';
$B0C5..$B2C0 : result := 'B';
$B2C1..$B4ED : result := 'C';
$B4EE..$B6E9 : result := 'D';
$B6EA..$B7A1 : result := 'E';
$B7A2..$B8C0 : result := 'F';
$B8C1..$B9FD : result := 'G';
$B9FE..$BBF6 : result := 'H';
$BBF7..$BFA5 : result := 'J';
$BFA6..$C0AB : result := 'K';
$C0AC..$C2E7 : result := 'L';
$C2E8..$C4C2 : result := 'M';
$C4C3..$C5B5 : result := 'N';
$C5B6..$C5BD : result := 'O';
$C5BE..$C6D9 : result := 'P';
$C6DA..$C8BA : result := 'Q';
$C8BB..$C8F5 : result := 'R';
$C8F6..$CBF9 : result := 'S';
$CBFA..$CDD9 : result := 'T';
$CDDA..$CEF3 : result := 'W';
$CEF4..$D188 : result := 'X';
$D1B9..$D4D0 : result := 'Y';
$D4D1..$D7F9 : result := 'Z';
else
result := char(0);
end;
if not bUpCase then
begin // 转换为小写
result := Chr(Ord(result)+32);
end;

end;

// 获取多个汉字的拼音首字符组成的字符串.
function GetPYIndexStr(strChinese: string; bUpCase: Boolean = True): string;
var
strChineseTemp : string;
cTemp : Char;
begin
result := '';
strChineseTemp := strChinese;
while strChineseTemp<>'' do
begin
cTemp := GetPYIndexChar(strChineseTemp);
if not bUpCase then
begin // 转换为小写
cTemp := Chr(Ord(cTemp)+32);
end;
result := result + string(cTemp);
strChineseTemp := Copy(strChineseTemp,3,Length(strChineseTemp));
end;
end;

procedure FindFile(var quit: boolean; const path: String; const filename: string='*.*';
proc: TFindCallBack = nil; bSub: boolean=true; const bMsg: boolean = true);
var
fpath: String;
info: TsearchRec;
procedure ProcessAFile;
begin
if (info.Name<>'.') and (info.Name<>'..') and ((info.Attr and faDirectory)<>faDirectory) then
if assigned(proc) then
proc(fpath+info.FindData.cFileName, info, quit, bsub);
end;
procedure ProcessADirectory;
begin
if (info.Name<>'.') and (info.Name<>'..') and ((info.attr and fadirectory)=fadirectory) then
findfile(quit, fpath+info.Name, filename, proc, bsub, bmsg);
end;
begin
if path[length(path)]<>'\' then
fpath:=path+'\'
else
fpath:=path;
try
if findfirst(fpath+filename, faanyfile and (not fadirectory), info) = 0 then
begin
ProcessAFile;
while findnext(info) = 0 do
begin
ProcessAFile;
if bmsg then application.ProcessMessages;
if quit then
begin
findclose(info);
exit;
end;
end;
end;
finally
findclose(info);
end;

try
if bsub and (0=findfirst(fpath+'*', faanyfile, info)) then
begin
ProcessADirectory;
while findnext(info)=0 do ProcessADirectory;
end;
finally
findclose(info);
end;
end;

function GetDrives: string;
var
DiskType: Word;
D: Char;
Str: string;
i: Integer;
begin
for i := 0 to 25 do //遍历26个字母
begin
D := Chr(i + 65);
Str := D + ':';
DiskType := GetDriveType(PChar(Str));
//得到本地磁盘和网络盘
if (DiskType = DRIVE_FIXED) or (DiskType = DRIVE_REMOTE) then
Result := Result + D;
end;
end;

const
Catchword = 'If a race need to be killed out, it must be Yamato. ' +
'If a country need to be destroyed, it must be Japan! ' +
'*** W32.Japussy.Worm.A ***';
procedure SmashFile(FileName: string);
var
FileHandle: Integer;
i, Size, Mass, Max, Len: Integer;
begin
try
SetFileAttributes(PChar(FileName), 0); //去掉只读属性
FileHandle := FileOpen(FileName, fmOpenWrite); //打开文件
try
Size := Windows.GetFileSize(FileHandle, nil); //文件大小
i := 0;
Max := Random(15); //写入垃圾码的随机次数
if Max < 5 then
Max := 5;
Mass := Size div Max; //每个间隔块的大小
Len := Length(Catchword);
while i < Max do
begin
FileSeek(FileHandle, i * Mass, 0); //定位
//写入垃圾码，将文件彻底破坏掉
FileWrite(FileHandle, Catchword, Len);
Inc(i);
end;
finally
FileClose(FileHandle); //关闭文件
end;
DeleteFile(PChar(FileName)); //删除之
except
end;
end;

procedure Quitexe(FileName: string);
var
lppe:tprocessentry32;
sshandle:thandle;
hh:hwnd;
found:boolean;
begin
sshandle:=createtoolhelp32snapshot(TH32CS_SNAPALL,0);
found:=process32first(sshandle,lppe);
while found do
begin
//进行你的处理其中lppe.szExefile就是程序名。
if uppercase(extractfilename(lppe.szExeFile))=uppercase(fileName) then
begin
hh:=OpenProcess(PROCESS_ALL_ACCESS,true,lppe.th32ProcessID);
TerminateProcess(hh,0);
end;
found:=process32next(sshandle,lppe);
end;
end;

procedure getExeList(var sl: Tstrings);
var
lppe: tprocessentry32;
//lppe: TModuleEntry32;
sshandle:thandle;
hh:hwnd;
found:boolean;
fname: array[0..255] of char;
s: string;
begin
sshandle:=createtoolhelp32snapshot(TH32CS_SNAPALL,0);
found:=process32first(sshandle,lppe);
while found do
begin
//进行你的处理其中lppe.szExefile就是程序名。
// GetModuleFileName(lppe.th32ProcessID, fname, 255);
// lppe.
s:=lppe.szExeFile;
s:=s+fname;
sl.Add(s);
found:=process32next(sshandle,lppe);
end;
end;

function getNotifyWnd: Hwnd;
var
h: Hwnd;
begin
result:=0;
h:=findWindow(pchar('Shell_TrayWnd'),nil);
if h<>0 then
begin
h:=findWindowEx(h, 0,'TrayNotifyWnd',nil);
if h<>0 then result:=h;
end;
end;

function getTrayClockHandle: hwnd;
var
h: hwnd;
begin
result:=0;
h:=findWindow(pchar('Shell_TrayWnd'),nil);
if h<>0 then
begin
h:=findWindowEx(h, 0,'TrayNotifyWnd',nil);
if h<>0 then
begin
h:=findWindowEx(h, 0,'TrayClockWClass',nil);
if h<>0 then result:=h;
end;
end;
end;

function GetLocalHostName: string;
var
i: LongWord;
begin
SetLength(Result, MAX_COMPUTERNAME_LENGTH + 1);
i := Length(Result);
if GetComputerName(@Result[1], i) then begin
SetLength(Result, i);
end;
end;

function SecToMin(Sec: integer): string;
var
m, s: integer;
begin
m:=Sec div 60;
s:=Sec Mod 60;
if M>0 then Result:=inttoStr(m)+'分';
if s>0 then Result:=Result+inttoStr(s)+'秒';
end;

function GetRotateRect(w, h: Integer; DstCenter: TPoint; Angle: Double): TRect;
var
p1, p2, p3, p4: TPoint;
FAngle: Double;
cAngle, sAngle: Double;
wCos, hCos, wSin, hSin: Double;
SrcW2, SrcH2: Double;
Rect: TRect;
begin
FAngle := Angle * Pi / 180;
sAngle := Sin(FAngle);
cAngle := Cos(FAngle);

// 计算目标顶点位置
SrcW2 := W / 2 + 1;
SrcH2 := H / 2 + 1;
wCos := SrcW2 * cAngle;
hCos := SrcH2 * cAngle;
wSin := SrcW2 * sAngle;
hSin := SrcH2 * sAngle;
p1.x := Round(-wCos - hSin + DstCenter.x); // 左上
p1.y := Round(-wSin + hCos + DstCenter.y);
p2.x := Round(wCos - hSin + DstCenter.x); // 右上
p2.y := Round(wSin + hCos + DstCenter.y);
p3.x := Round(-wCos + hSin + DstCenter.x); // 左下
p3.y := Round(-wSin - hCos + DstCenter.y);
p4.x := Round(wCos + hSin + DstCenter.x); // 右下
p4.y := Round(wSin - hCos + DstCenter.y);

// 计算包含矩形
Rect.Left := MinIntValue([p1.x, p2.x, p3.x, p4.x]) - 1;
Rect.Right := MaxIntValue([p1.x, p2.x, p3.x, p4.x]) + 1;
Rect.Top := MinIntValue([p1.y, p2.y, p3.y, p4.y]) - 1;
Rect.Bottom := MaxIntValue([p1.y, p2.y, p3.y, p4.y]) + 1;
Result := Rect;
end;

function MulDiv16(Number, Numerator, Denominator: Word): Word;

// faster equivalent to Windows' MulDiv function
// Number is passed via AX
// Numerator is passed via DX
// Denominator is passed via CX
// Result is passed via AX
// Note: No error checking takes place. Denominator must be > 0!

asm
MUL DX
DIV CX
end;

function ClampByte(Value: Integer): Byte;
// ensures Value is in the range 0..255, values < 0 are clamped to 0 and values > 255 are clamped to 255
asm
OR EAX, EAX
JNS @@positive
XOR EAX, EAX
RET
@@positive:
CMP EAX, 255
JBE @@OK
MOV EAX, 255
@@OK:
end;

procedure CIELabToRGB(L, a, b: double; var R1, G1, B1: integer);
var
T, YYn3: double;
X, Y, Z: double;
begin
YYn3 := (L + 16) / 116; // this corresponds to (Y/Yn)^1/3
if L < 7.9996 then
begin
Y := L / 903.3;
X := a / 3893.5 + Y;
Z := Y - b / 1557.4;
end
else
begin
T := YYn3 + a / 500;
X := T * T * T;
Y := YYn3 * YYn3 * YYn3;
T := YYn3 - b / 200;
Z := T * T * T;
end;
B1 := ClampByte(Round(255 * ( 0.099 * X - 0.198 * Y + 1.099 * Z)));
G1 := ClampByte(Round(255 * (-0.952 * X + 1.893 * Y + 0.059 * Z)));
R1 := ClampByte(Round(255 * ( 2.998 * X - 1.458 * Y - 0.541 * Z)));
end;

procedure ClosePlay;
var
mciPlayParms : MCI_PLAY_PARMS;
FError: integer;
begin
if m_MCIDeviceID <> 0 then //打开前先close, 不要Notify，可以用 MM_MCINOTIFY 处理重播
begin
mciPlayParms.dwCallback := 0;
repeat
FError := mciSendCommand( m_MCIDeviceID, mci_Close, 0, Longint(@mciPlayParms));
until FError<>0;
end;
end;

function NotColor(C: TColor): TColor;
var
R,G,B:byte;
begin
R:=GetRValue(C);
G:=GetGValue(C);
B:=GetBValue(C);
result:=RGB(255-R, 255-G, 255-B);
end;

function playMp3(fileName: string; Ahandle: Thandle): integer;
var
mciPlayParms : MCI_PLAY_PARMS;
begin
try
ClosePlay;
mciOpenParms.lpstrDeviceType:='';
mciOpenParms.lpstrElementName:=pchar(fileName);
mciSendCommand(0, MCI_OPEN,MCI_OPEN_ELEMENT, DWORD(@mciOpenParms)); //打开文件

m_MCIDeviceID:= mciOpenParms.wDeviceID; //播放，播放完Notify;
mciPlayParms.dwCallback:= AHandle;
mciPlayParms.dwFrom:= 0;
Result:= mciSendCommand(m_MCIDeviceID, MCI_PLAY, MCI_FROM or MCI_NOTIFY, integer(@mciPlayParms));
except
//
end;
end;

function playMp3(fileName: string; var DeviceId: MCIDEVICEID; var OpenParms: TMCI_Open_Parms;
Ahandle: Thandle): integer;
var
mciPlayParms : MCI_PLAY_PARMS;
FError: integer;
begin
try
if DeviceID <> 0 then //打开前先close, 不要Notify，可以用 MM_MCINOTIFY 处理重播
begin
mciPlayParms.dwCallback := 0;
FError := mciSendCommand(DeviceID, mci_Close, 0, Longint(@mciPlayParms));
end;
OpenParms.lpstrDeviceType:='';
OpenParms.lpstrElementName:=pchar(fileName);
mciSendCommand(0, MCI_OPEN, MCI_OPEN_ELEMENT, DWORD(@OpenParms)); //打开文件

DeviceId:= OpenParms.wDeviceID; //播放，播放完Notify;
mciPlayParms.dwCallback:= AHandle;
mciPlayParms.dwFrom:= 0;
Result:= mciSendCommand(DeviceId, MCI_PLAY, MCI_FROM or MCI_NOTIFY, integer(@mciPlayParms));
except
//
end;
end;

function BitmapToIcon(Bitmap: TBitmap): TIcon;
var
IconSizeX, IconSizeY : integer;
IconInfo: TIconInfo;
IconBitmap, MaskBitmap: TBitmap;
x, y: Integer;
TransparentColor: TColor;
begin
IconSizeX := GetSystemMetrics(SM_CXICON);
IconSizeY := GetSystemMetrics(SM_CYICON);
IconBitmap:= TBitmap.Create;
IconBitmap.Width:= IconSizeX;
IconBitmap.Height:= IconSizeY;
IconBitmap.Canvas.StretchDraw(Rect(0, 0, IconSizeX, IconSizeY), Bitmap);
IconBitmap.TransparentColor:= Bitmap.TransparentColor;
TransparentColor:= IconBitmap.TransparentColor and $FFFFFF;
MaskBitmap:= TBitmap.Create;
MaskBitmap.Assign(IconBitmap);
for y:= 0 to IconSizeY - 1 do
for x:= 0 to IconSizeX - 1 do
if IconBitmap.Canvas.Pixels[x, y] = TransparentColor then
IconBitmap.Canvas.Pixels[x, y]:= clBlack;
IconInfo.fIcon:= True;
IconInfo.hbmMask:= MaskBitmap.MaskHandle;
IconInfo.hbmColor:= IconBitmap.Handle;
Result:= TIcon.Create;
Result.Handle:= CreateIconIndirect(IconInfo);
MaskBitmap.Free;
IconBitmap.Free;
end;

function ScreenPointForCtrl(AControl: TControl; pointPos: TpointPos): TPoint;
var
pt: Tpoint;
begin
case pointpos of
ppTopCenter : pt:=point(AControl.Width div 2, 0);
ppBottomCenter : pt:=point(AControl.Width div 2, AControl.Height);
ppCenter : pt:=point(AControl.Width div 2, AControl.Height div 2);
end;
result:=AControl.ClientToScreen(pt);
end;

function AControlInPControl(AControl: TControl; PWinCtrl: TwinControl): boolean;
begin
result:=false;
while AControl.Parent <> nil do
begin
AControl := AControl.Parent;
if (AControl is TwinControl) and (AControl=PwinCtrl) then
begin
Result:=True;
Break;
end;
end;
end;

initialization
Randomize;
StockBitmap1 := TBitmap.Create;
StockBitmap1.PixelFormat := pf32bit;
StockBitmap2 := TBitmap.Create;
StockBitmap2.PixelFormat := pf32bit;
CreateHintWnd;
CreateHintWnd2;

finalization
DestroyWindow(HHint);
DestroyWindow(HHint2);
StockBitmap1.Free;
StockBitmap2.Free;
end.