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

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 我的文档 //如Cocuments 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='' 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 else s:=s+deli+sl
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
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 := 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 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 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 我的文档 //如Cocuments 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.Text) else TempNode := Items.AddChild(TempNode, SourceNode.Item.Text)
AddSubTree(DestTree, SourceNode.Item, 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.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.X:=x+round(R*cos(pi*A/180))
pt.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 = 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));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.

如有不合理不完善的地方，请指正，谢谢

这么多函数，不做注释很难用上的

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

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

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

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

對某些人有用，對某些人沒用。有用的時候就怕找不到。

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

delphi世界欢迎你qq群23981160

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