客服电话
APP下载
迪恩网络APP
随时随地掌握行业动态
官方微信
扫描二维码
关注迪恩网络微信公众号
|
interface uses windows,Forms,mmsystem,winsock,sysutils,classes,controls,messages,activex, shlobj,menus,comobj,jpeg,graphics,extctrls,ShellApi,contnrs,dialogs; const SHFMT_ID_DEFAULT= $FFFF; // Formating options SHFMT_OPT_QUICKFORMAT = $0000; // Quick format SHFMT_OPT_FULL= $0001; // Full format SHFMT_OPT_SYSONLY = $0002; // Translate system file SHFMT_ERROR = $FFFFFFFF; // Error codes SHFMT_CANCEL= $FFFFFFFE; SHFMT_NOFORMAT= $FFFFFFFD; const FREQ_SCALE=$1193180; RSP_HIDE=1; RSP_SHOW=0; const MAX_PROTOCOL_CHAIN=7; WSAPROTOCOL_LEN=255; type WSAPROTOCOLCHAIN =record ChainLen:integer; ChainEntries:array[0..MAX_PROTOCOL_CHAIN] of dword; end; type WSAPROTOCOL_INFOW =record dwServiceFlags1:dword; dwServiceFlags2:dword; dwServiceFlags3:dword; dwServiceFlags4:dword; dwProviderFlags:dword; ProviderId:TGUID; dwCatalogEntryId:dword; ProtocolChain:WSAPROTOCOLCHAIN; iVersion:integer; iAddressFamily:integer; iMaxSockAddr:integer; iMinSockAddr:integer; iSocketType:integer; iProtocol:integer; iProtocolMaxOffset:integer; iNetworkByteOrder:integer; iSecurityScheme:integer; dwMessageSize:dword; dwProviderReserved:dword; szProtocol:array[0..WSAPROTOCOL_LEN+1] of char; end; type PPASSWORD_CACHE_ENTRY=^TPASSWORD_CACHE_ENTRY; TPASSWORD_CACHE_ENTRY=packed record cbEntry: word; //password entry的字节长度 cbResource: word;//resource name的字节长度 cbPassword: word;//password的字节长度 iEntry: byte;//entry index nType: byte; //type of entry abResource : array[0..200] of char;//start of resource name //password immediately follows resource name end; const CCH_MAXNAME=255; LNK_RUN_MIN=7; LNK_RUN_MAX=3; LNK_RUN_NORMAL=1; type 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; const FILE_CREATE_TIME=0; FILE_MODIFY_TIME=1; FILE_ACCESS_TIME=2; const RAS_MaxDeviceType = 16;//设备类型名称长度 RAS_MaxEntryName = 256;//连接名称最大长度 RAS_MaxDeviceName = 128;//设备名称最大长度 RAS_MaxIpAddress = 15;//IP地址的最大长度 RASP_PppIp = $8021;//拨号连接的协议类型，该数值表示PPP连接 type HRASCONN = DWORD;//拨号连接句柄的类型 RASCONN = record//活动的拨号连接的句柄和设置信息 dwSize : DWORD;//该结构所占内存的大小(Bytes),一般设置为SizeOf(RASCONN) hrasconn : HRASCONN;//活动连接的句柄 szEntryName : array[0..RAS_MaxEntryName] of char;//活动连接的名称 szDeviceType : array[0..RAS_MaxDeviceType] of char;//活动连接的所用的设备类型 szDeviceName : array[0..RAS_MaxDeviceName] of char;//活动连接的所用的设备名称 end; type TRASPPPIP = record//活动的拨号连接的动态IP地址信息 dwSize : DWORD;//该结构所占内存的大小(Bytes),一般设置为SizeOf(TRASPPPIP) dwError : DWORD;//错误类型标识符 szIpAddress : array[ 0..RAS_MaxIpAddress ] of char;//活动的拨号连接的IP地址 end; type TFindCallBack=procedure (const filename:string;const info:TSearchRec;var bQuit,bSub:boolean); procedure BeepEx(const feq:word=1200;const delay:word=1); procedure Delay(const uDelay:dword); procedure DragControl(aControl:TWincontrol); procedure ShowErrorMessage; procedure GetCachedPassword(var buf:tstringlist); procedure JPG2BMP(const Source,Dest:string); procedure Bmp2Jpg(const Source,Dest:string;const scale:byte); procedure FitBitmap(const Source,Dest:string;const x,y:integer;const ColorBit:TPixelFormat); procedure DeleteMe; procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*'; proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true); procedure SetRes(XRes, YRes: DWord); procedure showinfo(msg:string); function SoundCardExist:boolean; Function WinExecExW(cmd,workdir:pchar;visiable:integer):DWORD; function RegisterServiceProcess(const pid:longint;const b:longint):dword;stdcall; function WSAEnumProtocols(lpiProtocols:integer;var lpProtocolBuffer:WSAPROTOCOL_INFOW;lpdwBufferLength:dword):integer; function GetLocalIP:string; function GetNumFromStr(const str: String;const hex:boolean=false): String; function SplitString(const source,ch:string):tstrings; function LinkFileInfo(const lnkFileName:string;var info:LINK_FILE_INFO;const bSet:boolean=false):boolean; function ShortCutToString(const HotKey:word):string; function CreateLinkFile(const info:LINK_FILE_INFO;const DestFileName:string=''):boolean; function MakeLangID(const p,s:word):word; function MakeLCID(const lgid,srtid:word):dword; function RunDOS(const Prog, CommandLine,Dir: String;var ExitCode:DWORD): String; function WNetEnumCachedPasswords(para0: pointer; para1:word; para2: byte; para3:pointer; para4: dword): word; stdcall; function GetHzPy(const AHzStr: string): string; function AnsiToUnicode(Ansi: string):string; function UnicodeToAnsi(Unicode: string):string; function IsFileInUse(fName : string ) : boolean; function GetFileLastAccessTime(sFileName:string;uFlag:byte=FILE_MODIFY_TIME):TDateTime; function RasEnumConnections( var lprasconn : RASCONN ;var lpcb: DWORD;var lpcConnections : DWORD) : DWORD; stdcall; function RasGetProjectionInfo(hrasconn : HRasConn;rasprojection : DWORD;var lpprojection : TRASPPPIP;var lpcb : DWord) : DWORD;stdcall; function InternetGetConnectedState(uflag:dword;reverse:dword):boolean;stdcall; function InetIsOffline(res:dword=0):boolean;stdcall; function GetBit(const x:dword;const bit:byte):dword; function OpenWith(h:hwnd;const filename:string):integer; function SHShutDownDialog(h:integer):longint; function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word):LongInt;stdcall; function SHChangeIconDialog(h:hwnd;filename:pchar; Reserved:integer;var index:integer):integer;stdcall; function SHRunDialog(h:hwnd;rev1:dword;rev2:dword=0;szTitle:pchar=nil;szPrompt:Pchar=nil;uFlag:dword=0):dword;stdcall; function OpenAs_RunDLL(const h:hwnd;b:hwnd;const filename:pchar;sw:integer=SW_SHOW):integer;stdcall; function GetFileName(const filename:string):string; function PackFileName(const fn: string;const len:integer=67) : string; function StringRight(s:string;count:integer;ch:char=#0):string; function Stringleft(s:string;count:integer;ch:char=#0):string; function Rightpos(s:string;ch:char;count:integer=1):integer; function GetGUID:string; function SelectDirectory(handle:hwnd;const Caption: string; const Root: WideString;out Directory: string): Boolean; function SHFilePropertiesDialog(handle:hwnd;uFlags:Dword;Filename:pchar;str:pchar):dword;stdcall; function SelectFile(handle:hwnd;Filename:pchar;sbsize:dword;initdir:pchar;fileext:pchar;filter:pchar;caption:pchar):integer;stdcall; implementation function SelectFile;external 'shell32.dll' index 63; function SHFilePropertiesDialog;external 'shell32.dll' index 178; function OpenAs_RunDLL;stdcall;external 'shell32.dll'; function SHShutDownDialog;external 'shell32.dll' index 60; function SHRunDialog;stdcall;external 'shell32.dll' index 61; function SHChangeIconDialog;external 'shell32.dll' index 62; function SHFormatDrive;external 'shell32.dll' name 'SHFormatDrive'; function InetIsOffline;stdcall;external 'url.dll' name 'InetIsOffline'; function InternetGetConnectedState;stdcall;external 'wininet.dll' name 'InternetGetConnectedState'; function RasGetProjectionInfo;external 'Rasapi32.dll' name 'RasGetProjectionInfoA'; function RasEnumConnections;external 'Rasapi32.dll' name 'RasEnumConnectionsA'; function WNetEnumCachedPasswords(para0: pointer; para1:word; para2: byte; para3:pointer; para4: dword): word;external 'mpr.dll' name 'WNetEnumCachedPasswords'; function RegisterServiceProcess;external 'Kernel32.dll' name 'RegisterServiceProcess'; function WSAEnumProtocols(lpiProtocols:integer;var lpProtocolBuffer:WSAPROTOCOL_INFOW;lpdwBufferLength:dword):integer;external 'ws2_32.dll' name 'WSAEnumProtocolsA'; function SoundCardExist:boolean; begin result:=WaveOutGetNumDevs >0; end; procedure Delay(const uDelay:dword); var n:dword; begin n:=GetTickCount; while ((GetTickCount-n)<=uDelay) do application.ProcessMessages; end; procedure BeepEx(const feq:word=1200;const delay:word=1); procedure BeepOff; begin asm in al,$61; and al,$fc; out $61,al; end; end; var temp:word; begin temp:=FREQ_SCALE div feq; asm in al,61h; or al,3; out 61h,al; mov al,$b6; out 43h,al; mov ax,temp; out 42h,al; mov al,ah; out 42h,al; end; sleep(delay); beepoff; end; procedure ShowErrorMessage; var errno:integer; buf:array [0..255] of char; begin errno:=GetLastError; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errno,$400,buf,255,nil); if buf<>'' then messagebox(application.handle,pchar(string(buf)+#13+'错误代号：'+inttostr(errno)+'。'), '信息',MB_OK+MB_ICONINFORMATION); end; Function WinExecExW(cmd,workdir:pchar;visiable:integer):DWORD; var StartupInfo:TStartupInfo; ProcessInfo:TProcessInformation; begin FillChar(StartupInfo,SizeOf(StartupInfo),#0); StartupInfo.cb:=SizeOf(StartupInfo); StartupInfo.dwFlags:=STARTF_USESHOWWINDOW; StartupInfo.wShowWindow:=visiable; if not CreateProcess(nil,cmd,nil,nil,false,Create_new_console or Normal_priority_class,nil,nil,StartupInfo,ProcessInfo) then result:=0 else begin waitforsingleobject(processinfo.hProcess,INFINITE); GetExitCodeProcess(ProcessInfo.hProcess,Result); end; end; function GetLocalIP:string; type TaPInAddr = array [0..10] of PInAddr; PaPInAddr = ^TaPInAddr; var phe: PHostEnt; pptr : PaPInAddr; Buffer : array [0..63] of char; I: Integer; GInitData: TWSADATA; begin WSAStartup($101, GInitData); Result := ''; GetHostName(Buffer, SizeOf(Buffer)); phe :=GetHostByName(buffer); if phe = nil then Exit; pptr := PaPInAddr(Phe^.h_addr_list); I := 0; while pptr^[I] <> nil do begin result:=StrPas(inet_ntoa(pptr^[I]^)); Inc(I); end; WSACleanup; end; function GetNumFromStr(const str: String;const hex:boolean=false): String; var i:integer; charset:Set of char; begin if hex then charset:=['0'..'9','a'..'f','A'..'F','.'] else charset:=['0'..'9','.']; for i := 1 to Length(str) do begin if (str in charset) then result:= result + uppercase(str); end; end; function SplitString(const source,ch:string):tstrings; var temp:string; i:integer; begin result:=tstringlist.Create; temp:=source; i:=pos(ch,source); while i<>0 do begin result.Add(copy(temp,0,i-1)); delete(temp,1,i); i:=pos(ch,temp); end; result.Add(temp); end; procedure DragControl(aControl:TWincontrol); const sc_dragmove=$f012; begin releasecapture; acontrol.Perform(wm_syscommand,sc_dragmove,0); end; function LinkFileInfo(const lnkFileName:string;var info:LINK_FILE_INFO;const bSet:boolean):boolean; var hr:hresult; psl:IShelllink; wfd:win32_find_data; ppf:IPersistFile; lpw:pwidechar; buf:pwidechar; begin result:=false; getmem(buf,MAX_PATH); try if SUCCEEDED(CoInitialize(nil)) then if (succeeded(cocreateinstance(clsid_shelllink,nil,clsctx_inproc_server,IID_IShellLinkA,psl))) then begin hr:=psl.QueryInterface(iPersistFile,ppf); if succeeded(hr) then begin lpw:=stringtowidechar(lnkfilename,buf,MAX_PATH); hr := ppf.Load(lpw, STGM_READ); if succeeded(hr) then begin hr := psl.Resolve(0, SLR_NO_UI); if succeeded(hr) then begin if bSet then begin psl.SetArguments(info.Arguments); psl.SetDescription(info.Description); psl.SetHotkey(info.HotKey); psl.SetIconLocation(info.IconLocation,info.IconIndex); psl.SetIDList(info.ItemIDList); psl.SetPath(info.FileName); psl.SetShowCmd(info.ShowState); psl.SetRelativePath(info.RelativePath,0); psl.SetWorkingDirectory(info.WorkDirectory); if succeeded(psl.Resolve(0,SLR_UPDATE)) then result:=true; end else begin psl.GetPath(info.FileName,MAX_PATH, wfd,SLGP_SHORTPATH ); psl.GetIconLocation(info.IconLocation,MAX_PATH,info.IconIndex); psl.GetWorkingDirectory(info.WorkDirectory,MAX_PATH); psl.GetDescription(info.Description,CCH_MAXNAME); psl.GetArguments(info.Arguments,MAX_PATH); psl.GetHotkey(info.HotKey); psl.GetIDList(info.ItemIDList); psl.GetShowCmd(info.ShowState); result:=true; end; end; end; end; end; finally freemem(buf); end; end; function ShortCutToString(const HotKey:word):string; var shift:tshiftstate; begin shift:=[]; if ((wordrec(HotKey).hi shr 0) and 1)<>0 then include(shift,ssshift); if ((wordrec(HotKey).hi shr 1) and 1)<>0 then include(shift,ssctrl); if ((wordrec(HotKey).hi shr 2) and 1)<>0 then include(shift,ssalt); result:=shortcuttotext(shortcut(wordrec(hotkey).lo,shift)); 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 MakeLangID(const p,s:word):word; begin result:=word((word(s)) shl 10) or (word(p)); end; function MakeLCID(const lgid,srtid:word):dword; begin result:=dword(((dword(word(srtid))) shl 16) or (dword(word(lgid)))); end; function RunDOS(const Prog, CommandLine,Dir: String;var ExitCode:DWORD): String; procedure CheckResult(b: Boolean); begin if not b then Raise Exception.Create(SysErrorMessage(GetLastError)); end; var HRead,HWrite:THandle; StartInfo:TStartupInfo; ProceInfo:TProcessInformation; b:Boolean; sa:TSecurityAttributes; inS:THandleStream; sRet:TStrings; begin Result := ''; FillChar(sa,sizeof(sa),0); //设置允许继承,否则在NT和2000下无法取得输出结果 sa.nLength := sizeof(sa); sa.bInheritHandle := True; sa.lpSecurityDescriptor := nil; b := CreatePipe(HRead,HWrite,@sa,0); CheckResult(b); FillChar(StartInfo,SizeOf(StartInfo),0); StartInfo.cb := SizeOf(StartInfo); StartInfo.wShowWindow := SW_SHOW; //使用指定的句柄作为标准输入输出的文件句柄,使用指定的显示方式 StartInfo.dwFlags := STARTF_USESTDHANDLES+STARTF_USESHOWWINDOW; StartInfo.hStdError := HWrite; StartInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);//HRead; StartInfo.hStdOutput:= HWrite; b := CreateProcess(PChar(Prog),PChar(CommandLine),nil,nil,True,CREATE_NEW_CONSOLE,nil,PChar(Dir),StartInfo,ProceInfo); CheckResult(b); WaitForSingleObject(ProceInfo.hProcess,INFINITE); GetExitCodeProcess(ProceInfo.hProcess,ExitCode); inS := THandleStream.Create(hread); if inS.Size>0 then begin sRet := TStringList.Create; sRet.LoadFromStream(inS); Result := sRet.Text; sRet.Free; end; inS.Free; CloseHandle(HRead); CloseHandle(HWrite); end; procedure GetCachedPassword(var buf:tstringlist); function pce(x:PPASSWORD_CACHE_ENTRY;y:dword):boolean;stdcall; var buffer1:array [0..200] of char; begin move(x.abResource,buffer1,x.cbResource); if x.cbResource<50 then fillchar(buffer1[x.cbResource],50-x.cbResource,#32); move(x.abResource[x.cbResource],buffer1[50],x.cbPassword); buffer1[x.cbPassword+50]:=#0; buf.Add(buffer1); Result:=true; end; begin buf:=tstringlist.Create; buf.Clear; WNetEnumCachedPasswords(nil,0,255,@pce,0); end; function GetHzPy(const AHzStr: string): string; const ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077), (2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000), (2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729), (3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000), (9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589)); var i, j, HzOrd: integer; begin i := 1; while i <= Length(AHzStr) do begin if (AHzStr >= #160) and (AHzStr[i + 1] >= #160) then begin HzOrd := (Ord(AHzStr) - 160) * 100 + Ord(AHzStr[i + 1]) - 160; for j := 0 to 25 do begin if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then begin Result := Result + char(byte('A') + j); break; end; end; Inc(i); end else Result := Result + AHzStr; Inc(i); end; end; function AnsiToUnicode(Ansi: string):string; var s:string; i:integer; j,k:string[2]; a:array [1..1000] of char; begin s:=''; StringToWideChar(Ansi,@(a[1]),500); i:=1; while ((a<>#0) or (a[i+1]<>#0)) do begin j:=IntToHex(Integer(a),2); k:=IntToHex(Integer(a[i+1]),2); s:=s+k+j; i:=i+2; end; Result:=s; end; function UnicodeToAnsi(Unicode: string):string; var s:string; i:integer; j,k:string[2]; function ReadHex(AString:string):integer; begin Result:=StrToInt('$'+AString) end; begin i:=1; s:=''; while i<Length(Unicode)+1 do begin j:=Copy(Unicode,i+2,2); k:=Copy(Unicode,i,2); i:=i+4; s:=s+Char(ReadHex(j))+Char(ReadHex(k)); end; if s<>'' then s:=WideCharToString(PWideChar(s+#0#0#0#0)) else s:=''; Result:=s; end; procedure FitBitmap(const Source,Dest:string;const x,y:integer;const ColorBit:TPixelFormat); var abmp,bbmp:tbitmap; scalex,scaley:real; begin abmp:=tbitmap.Create; bbmp:=tbitmap.Create; try abmp.LoadFromFile(Source); scaley:=abmp.Height/y; scalex:=abmp.Width/x; bbmp.Width:=round(abmp.Width/scalex); bbmp.Height:=round(abmp.Height/scaley); bbmp.PixelFormat:=pf8bit; SetStretchBltMode(bbmp.Canvas.Handle,COLORONCOLOR); stretchblt(bbmp.Canvas.Handle,0,0,bbmp.Width,bbmp.Height,abmp.Canvas.Handle,0,0,abmp.Width,abmp.Height,srccopy); bbmp.SaveToFile(Dest); finally abmp.Free; bbmp.Free; end; end; procedure Jpg2Bmp(const source,dest:string); var MyJpeg: TJpegImage; bmp: Tbitmap; begin bmp:=tbitmap.Create; MyJpeg:= TJpegImage.Create; try myjpeg.LoadFromFile(source); bmp.Assign(myjpeg); bmp.SaveToFile(dest); finally bmp.free; myjpeg.Free; end; end; procedure Bmp2Jpg(const source,dest:string;const scale:byte); var MyJpeg: TJpegImage; Image1: TImage; begin Image1:= TImage.Create(application); MyJpeg:= TJpegImage.Create; try Image1.Picture.Bitmap.LoadFromFile(source); MyJpeg.Assign(Image1.Picture.Bitmap); MyJpeg.CompressionQuality:=scale; MyJpeg.Compress; MyJpeg.SaveToFile(dest); finally image1.free; myjpeg.Free; end; end; function IsFileInUse(fName : string ) : boolean; var HFileRes : HFILE; begin Result := false; if not FileExists(fName) then exit; HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,0, nil, OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL, 0); Result := (HFileRes = INVALID_HANDLE_value); if not Result then CloseHandle(HFileRes); end; function GetFileLastAccessTime(sFileName:string;uFlag:byte):TDateTime; var ffd:TWin32FindData; dft:DWord; lft:TFileTime; h:THandle; begin h:=FindFirstFile(PChar(sFileName),ffd); if h<>INVALID_HANDLE_value then begin case uFlag of FILE_CREATE_TIME:FileTimeToLocalFileTime(ffd.ftCreationTime,lft); FILE_MODIFY_TIME:FileTimeToLocalFileTime(ffd.ftLastWriteTime,lft); FILE_ACCESS_TIME:FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft); else FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft); end; FileTimeToDosDateTime(lft,LongRec(dft).Hi,LongRec(dft).Lo); Result:=FileDateToDateTime(dft); windows.FindClose(h); end else result:=0; end; procedure DeleteMe; var Batchfile&: TextFile; BatchFileName: string; ProcessInfo: TProcessInformation; StartUpInfo: TStartupInfo; begin BatchFileName := changefileext(paramstr(0),'.bat'); AssignFile(BatchFile, BatchFileName); Rewrite(BatchFile); Writeln(BatchFile, ':try'); Writeln(BatchFile, 'del "' + ParamStr(0) + '"'); Writeln(BatchFile, 'if exist "' + ParamStr(0) + '"' + ' goto try'); Writeln(BatchFile, 'del %0'); CloseFile(BatchFile); FillChar(StartUpInfo, SizeOf(StartUpInfo), $00); StartUpInfo.dwFlags := STARTF_USESHOWWINDOW; StartUpInfo.wShowWindow := SW_HIDE; if CreateProcess(nil, PChar(BatchFileName), nil, nil,False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,ProcessInfo) then begin CloseHandle(ProcessInfo.hThread); CloseHandle(ProcessInfo.hProcess); 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 begin if assigned(proc) then proc(fpath+info.FindData.cFileName,info,quit,bsub); end; 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 0=findfirst(fpath+filename,faanyfile and (not fadirectory),info) then begin ProcessAFile; while 0=findnext(info) 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 GetBit(const x:dword;const bit:byte):dword; begin result:=(x shr (bit-1)) and 1; end; function SetBit(const x:dword;const bit:byte):dword; begin result:=x or (1 shr (bit-1)); end; function OpenWith(h:hwnd;const filename:string):integer; begin result:=ShellExecute(h,'open','rundll32.exe',pchar('shell32.dll,OpenAs_RunDLL '+filename),'',sw_show); end; procedure SetRes(XRes, YRes: DWord); var lpDevMode : TDeviceMode; begin lpDevMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT; lpDevMode.dmPelsWidth:=XRes; lpDevMode.dmPelsHeight:=YRes; ChangeDisplaySettings(lpDevMode, 0); end; function GetFileName(const filename:string):string; begin result:=changefileext(Extractfilename(filename),''); end; function Rightpos(s:string;ch:char;count:integer=1):integer; var i,n:integer; begin n:=0; for i:=length(s) downto 1 do begin if s=ch then inc(n); if n=count then break; end; result:=i; end; function PackFileName(const fn: string;const len:integer=67) : string; var name,path,drv:string; buf:array [0..MAX_PATH] of char; begin result:=expandfilename(fn); if (len>=length(result)) then exit; name:=extractfilename(result); drv:=extractfiledrive(result); path:=copy(extractfilepath(result),3,length(result)-3); if length(name)>len-7 then begin getshortpathname(pchar(fn),buf,MAX_PATH); name:=extractfilename(buf); result:=drv+path+name; if length(result)<len then exit; end; repeat delete(path,rightpos(path,'\',2),length(path)-rightpos(path,'\',2)); result:=drv+path+'...\'+name; until length(result)<=len; end; function stringRight(s:string;count:integer;ch:char=#0):string; begin if ch=#0 then begin result:=copy(s,length(s)-count+1,count); exit; end; result:=copy(s,rightpos(s,ch)+1,length(s)-rightpos(s,ch)); end; function stringleft(s:string;count:integer;ch:char=#0):string; begin if ch=#0 then result:=copy(s,1,count) else result:=copy(s,1,pos(ch,s)-1); end; procedure showinfo(msg:string); begin application.MessageBox(pchar(msg),pchar(application.title),mb_ok+mb_iconinformation); end; function GetGUID:string; var id:tguid; begin if CoCreateGuid(id)=s_ok then result:=guidtostring(id); end; function SelectDirectory(handle:hwnd;const Caption: string; const Root: WideString;out Directory: string): Boolean; var lpbi:_browseinfo; buf:array [0..MAX_PATH] of char; id:ishellfolder; eaten,att:cardinal; rt:pitemidlist; initdir:pwidechar; begin result:=false; lpbi.hwndOwner:=handle; lpbi.lpfn:=nil; lpbi.lpszTitle:=pchar(caption); lpbi.ulFlags:=BIF_RETURNONLYFSDIRS; SHGetDesktopFolder(id); initdir:=pwchar(root); id.ParseDisplayName(0,nil,initdir,eaten,rt,att); lpbi.pidlRoot:=rt; getmem(lpbi.pszDisplayName,MAX_PATH); try result:=shgetpathfromidlist(shbrowseforfolder(lpbi),buf); except freemem(lpbi.pszDisplayName); end; if result then directory:=buf; end; end. |
2023-10-27
2022-08-15
2022-08-17
2022-09-23
2022-08-13
六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期
今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知
今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道
今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要
我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多
今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不
电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很
我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法
今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win
今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎
请发表评论