应部分网友要求,公开 myfunctions 单元,里面有很多有用的函数(0)

Discussion in 'Object Pascal' started by xuxiaohan, Dec 8, 2010.

  1. xu

    xuxiaohan Member

    Apr 1, 2015
    unit myFunctions;//---------- 说 明--------------// by 冯思锐 最后修改2010-11-23// QQ: fengsirui@sina.com// 部分代码来自互联网,大部分为自己所写// 博客:http://blog.sina.com.cn/fsr2009// 有一个函数 DrawChorkSoft(背景水印)需要引用cnGraphics,cnPack里面的一个单元,开源的可以在网上下载。interfaceuses 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.19procedure 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
    //取的 本机IPfunction 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);//播放Mp3function 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;implementationuses 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=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)
    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
    AArray:=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
    AStr:=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 firstfunction 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)+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)+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+Send;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 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^ <> nil do begin result:=StrPas(inet_ntoa(pptr^^))
    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='.' 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)+'.'+doctypeend;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 = #13) or (Result = #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 := char(byte(S) xor (Key shr 8))
    Key := (byte(Result) + 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 := char(byte(S) xor (Key shr 8))
    Key := (byte(S) + 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 thenend;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-1var 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 CXend;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 255asm 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.[/i][/I][/i][/i][/i][/I][/I][/I][/i][/i][/i][/i][/i][/i][/i]
     
  2. xu

    xuxiaohan Member

    Apr 1, 2015
    如有不合理不完善的地方,请指正,谢谢
     
  3. Lo

    LoveHui Member

    Apr 1, 2015
    这么多函数,不做注释很难用上的
     
  4. xu

    xuxiaohan Member

    Apr 1, 2015
    现在研究MQL4,希望有共同爱好者互相交流
     
  5. ne

    neugls Member

    Apr 1, 2015
    呵呵,这个也太多啦!我觉得你应该分们别类,然后再发!呵呵,不过能发出来已经不错了,支持!
     
  6. li

    liuzhigang_0625 Member

    Apr 1, 2015
    说句不中听的话, 就凭你单元的名称,感觉就没有什么收藏价值。 估计适合新手
     
  7. xu

    xuxiaohan Member

    Apr 1, 2015
    因人而异吧,不管是新手也好,老手也好,说有用的就是有用,说没有用的,那肯定就没有用。有网友在博客留言要求公开(我的部分公开控件引用到这个单元)。
     
  8. zb

    zbdzjx Member

    Apr 1, 2015
    對某些人有用,對某些人沒用。有用的時候就怕找不到。
     
  9. fa

    fatalexception Member

    Apr 1, 2015
    楼主公开自己的劳动成果,怎么还有人说风凉话啊,又没有强迫下载。建议楼主给每个函数做个“一句话说明”。
     
  10. de

    delphi大男孩 Member

    Apr 1, 2015
    delphi世界欢迎你qq群23981160
     
  11. yc

    yczjs Member

    Apr 1, 2015
    既然公开,再加个函数说明就更好了,呵呵!