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

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

  1. xu

    xuxiaohan New Member Member

    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 New Member Member

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

    LoveHui New Member Member

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

    xuxiaohan New Member Member

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

    neugls New Member Member

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

    liuzhigang_0625 New Member Member

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

    xuxiaohan New Member Member

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

    zbdzjx New Member Member

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

    fatalexception New Member Member

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

    delphi大男孩 New Member Member

    delphi世界欢迎你qq群23981160
     
  11. yc

    yczjs New Member Member

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