code.txt

Delphi经典函数 最新版 有不少更新

procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), Flags);
end;

// 显示提示确认窗口
function InfoOk(Mess: string; Caption: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Caption),
    MB_OK + MB_ICONINFORMATION) = IDOK;
end;

// 显示错误窗口
procedure ErrorDlg(Mess: string; Caption: string);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);
end;

// 显示警告窗口
procedure WarningDlg(Mess: string; Caption: string);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);
end;

// 显示查询是否窗口
function QueryDlg(Mess: string; Caption: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Caption),
    MB_YESNO + MB_ICONQUESTION) = IDYES;
end;

//窗体渐变
procedure SetWindowAnimate(Sender : TForm; IsSetAni : bool);
var
  pOSVersionInfo : OSVersionInfo;
begin
  pOSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo);
  GetVersionEx(pOSVersionInfo);
  if pOSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
  begin
    if IsSetAni then
      AnimateWindow(Sender.Handle,444,AW_HIDE or AW_BLEND);
  end
  else
    if IsSetAni then
    begin
      AnimateWindow(Sender.Handle,444,AW_HIDE or AW_CENTER);
    end;
end;

//▎============================================================▎//
//▎====================⑥ 系统功能函数  =======================▎//
//▎============================================================▎//

// 移动鼠标到控件
procedure MoveMouseIntoControl(AWinControl: TControl);
var
  rtControl: TRect;
begin
  rtControl := AWinControl.BoundsRect;
  MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2);
  SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2,
    rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2);
end;

// 动态设置分辨率
function DynamicResolution(x, y: WORD): Boolean;
var
  lpDevMode: TDeviceMode;
begin
  Result := EnumDisplaySettings(nil, 0, lpDevMode);
  if Result then
  begin
    lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
    lpDevMode.dmPelsWidth := x;
    lpDevMode.dmPelsHeight := y;
    Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
  end;
end;

// 窗口最上方显示
procedure StayOnTop(Handle: HWND; OnTop: Boolean);
const
  csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
  SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
end;

var
  WndLong: Integer;

// 设置程序是否出现在任务栏
procedure SetHidden(Hide: Boolean);
begin
  ShowWindow(Application.Handle, SW_HIDE);
  if Hide then
    SetWindowLong(Application.Handle, GWL_EXSTYLE,
      WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST)
  else
    SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong);
  ShowWindow(Application.Handle, SW_SHOW);
end;

const
  csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);

// 设置任务栏是否可见
procedure SetTaskBarVisible(Visible: Boolean);
var
  wndHandle: THandle;
begin
  wndHandle := FindWindow('Shell_TrayWnd', nil);
  ShowWindow(wndHandle, csWndShowFlag[Visible]);
end;

// 设置桌面是否可见
procedure SetDesktopVisible(Visible: Boolean);
var
  hDesktop: THandle;
begin
  hDesktop := FindWindow('Progman', nil);
  ShowWindow(hDesktop, csWndShowFlag[Visible]);
end;

// 显示等待光标
procedure BeginWait;
begin
  Screen.Cursor := crHourGlass;
end;  

// 结束等待光标
procedure EndWait;
begin
  Screen.Cursor := crDefault;
end;

// 检测是否Win95/98平台
function CheckWindows9598NT: String;
var
   V: TOSVersionInfo;
begin
   V.dwOSVersionInfoSize := SizeOf(V);
   Result := '未知操作系统';
   if not GetVersionEx(V) then Exit;
   if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
      Result := 'Windows 95/98'
   else
      begin
         if V.dwPlatformId = VER_PLATFORM_WIN32_NT then
            Result := 'Windows NT'
         else
            Result :='Windows'
      end;
end;

{* 取得当前操作平台是 Windows 95/98 还是NT}
function GetOSInfo : String;
begin
   Result := '';
   case Win32Platform of
      VER_PLATFORM_WIN32_WINDOWS: Result := 'Windows 95/98';
      VER_PLATFORM_WIN32_NT: Result := 'Windows NT';
   else
      Result := 'Windows32';
   end;
end;

//*获取当前Windows登录名的用户
function GetCurrentUserName : string;
const
   cnMaxUserNameLen = 254;
var
   sUserName : string;
   dwUserNameLen : Dword;
begin
   dwUserNameLen := cnMaxUserNameLen-1;
   SetLength( sUserName, cnMaxUserNameLen );
   GetUserName(Pchar( sUserName ), dwUserNameLen );
   SetLength( sUserName, dwUserNameLen );
   Result := sUserName;
end;

function GetRegistryOrg_User(UserKeyType:string):string;
var
   Myreg:Tregistry;
   RegString:string;
begin
   MyReg:=Tregistry.Create;
   MyReg.RootKey:=HKEY_LOCAL_MACHINE;
   if (Win32Platform = VER_PLATFORM_WIN32_NT) then
      RegString:='Software\Microsoft\Windows NT\CurrentVersion'
   else
      RegString:='Software\Microsoft\Windows\CurrentVersion';

   if MyReg.openkey(RegString,False) then
   begin
      if UpperCase(UserKeyType)='REGISTEREDORGANIZATION' then
         Result:= MyReg.readstring('RegisteredOrganization')
      else
         begin
            if UpperCase(UserKeyType)='REGISTEREDOWNER' then
               Result:= MyReg.readstring('RegisteredOwner')
            else
               Result:='';
         end;
   end;
   MyReg.CloseKey;
   MyReg.Free;
end;

//获取操作系统版本号
function GetSysVersion:string;
Var
   OSVI:OSVERSIONINFO;
   ObjSysVersion:string;
begin
   OSVI.dwOSversioninfoSize:=Sizeof(OSVERSIONINFO);
   GetVersionEx(OSVI);
   ObjSysVersion:=IntToStr(OSVI.dwMinorVersion)+','+IntToStr(OSVI.dwMinorVersion)+','
            +IntToStr(OSVI.dwBuildNumber)+','+IntToStr(OSVI.dwPlatformId)+','
            +OSVI.szCSDVersion;
   if rightstr(ObjSysVersion,1)=',' then
      ObjSysVersion:=Substr(ObjSysVersion,1,length(ObjSysVersion)-1);
   Result:=ObjSysVersion;
end;

//Windows启动模式
function WinBootMode:string;
begin
   case(GetSystemMetrics(SM_CLEANBOOT)) of
      0:Result:='正常模式启动';
      1:Result:='安全模式启动';
      2:Result:='安全模式启动，但附带网络功能';
   else
      Result:='错误：系统启动有问题。';
   end;
end;

////Windows ShutDown等
procedure WinShutDown(ShutWinType:PShutType; PForce:Boolean);
var
  hToken, hProcess: THandle;
  tp, prev_tp: TTokenPrivileges;
  Len, Flags: DWORD;
  CanShutdown: Boolean;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, True, GetCurrentProcessID);
    try
      if not OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
         Exit;
    finally
      CloseHandle(hProcess);
    end;
    try
      if not LookupPrivilegeValue('', 'SeShutdownPrivilege',
        tp.Privileges[0].Luid) then Exit;
      tp.PrivilegeCount := 1;
      tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      if not AdjustTokenPrivileges(hToken, False, tp, SizeOf(prev_tp),
        prev_tp, Len) then Exit;
    finally
      CloseHandle(hToken);
    end;
  end;
  CanShutdown := True;
//  DoQueryShutdown(CanShutdown);
  if not CanShutdown then Exit;
  if PForce then Flags := EWX_FORCE else Flags := 0;
  case ShutWinType of
    UPowerOff:  ExitWindowsEx(Flags or EWX_POWEROFF, 0);
    UShutdown:  ExitWindowsEx(Flags or EWX_SHUTDOWN, 0);
    UReboot:    ExitWindowsEx(Flags or EWX_REBOOT, 0);
    ULogoff:    ExitWindowsEx(Flags or EWX_LOGOFF, 0);
    USuspend:   SetSystemPowerState(True, PForce);
    UHibernate: SetSystemPowerState(False, PForce);
  end;
end;


//▎============================================================▎//
//▎=====================⑦硬件功能函数=========================▎//
//▎============================================================▎//

function GetClientGUID:string;
var
  myGuid:TGUID;
  ResultStr:string;
begin
  CreateGuid(myGuid);
  ResultStr:=GUIDToString(myGuid);
  ResultStr:=Communal.Replace(ResultStr,'-','',False);
  ResultStr:=Communal.Replace(ResultStr,'{','',False);
  ResultStr:=Communal.Replace(ResultStr,'}','',False);
  Result:=Substr(ResultStr,1,30);
end;

// 声卡是否存在
function SoundCardExist: Boolean;
begin
  Result := WaveOutGetNumDevs > 0;
end;

//* 获取磁盘序列号
function GetDiskSerial(DiskChar: Char): string;
var
   SerialNum : pdword;
   a, b : dword;
   Buffer : array [0..255] of char;
begin
   result := '';
   if GetVolumeInformation(PChar(diskchar+':\'), Buffer, SizeOf(Buffer), SerialNum,a, b, nil, 0) then
      Result := IntToStr(SerialNum^);
end;

//*检查磁盘准备是否就绪
function DiskReady(Root: string) : Boolean;
var
   Oem : CARDINAL ;
   Dw1,Dw2 : DWORD ;
begin
   Oem := SetErrorMode( SEM_FAILCRITICALERRORS ) ;
   if LENGTH(Root) = 1 then Root := Root + ':\\';
      Result := GetVolumeInformation( PCHAR( Root ), NIL,0,NIL, Dw1,Dw2, NIL,0 ) ;
   SetErrorMode( Oem ) ;
end;

//*检查驱动器A中磁盘的是否有文件及文件状态
function DriveState (driveletter: Char) : TDriveState;
var
   mask: String[6];
   sRec: TSearchRec;
   oldMode: Cardinal;
   retcode: Integer;
begin
   oldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
   mask:= '?:\*.*';
   mask[1] := driveletter;
   {$I-}
   retcode := FindFirst (mask, faAnyfile, Srec);
   FindClose(Srec);
   {$I+}
   case retcode of
   0 : Result := DSDISK_WITHFILES; //磁盘有文件
   -18 : Result := DSEMPTYDISK; //好的空磁盘
   -21, -3: Result := DSNODISK; //NT,Win31的错误代号
   else
      Result := DSUNFORMATTEDDISK;
   end;
   SetErrorMode(oldMode);
end;

//写串口
procedure WritePortB( wPort : Word; bValue : Byte );
begin
   asm
   mov dx, wPort
   mov al, bValue
   out dx, al
   end;
end;

//读串口
function ReadPortB( wPort : Word ):Byte;
begin
   asm
   mov dx, wPort
   in al, dx
   mov result, al
   end;
end;

//获知当前机器CPU的速率（MHz）
function CPUSpeed: Double;
const
   DelayTime = 500;
   var
   TimerHi, TimerLo: DWORD;
   PriorityClass, Priority: Integer;
begin
   PriorityClass := GetPriorityClass(GetCurrentProcess);
   Priority := GetThreadPriority(GetCurrentThread);
   SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
   SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
   Sleep(10);
   asm
   dw 310Fh
   mov TimerLo, eax
   mov TimerHi, edx
   end;
   Sleep(DelayTime);
   asm
   dw 310Fh
   sub eax, TimerLo
   sbb edx, TimerHi
   mov TimerLo, eax
   mov TimerHi, edx
   end;
   SetThreadPriority(GetCurrentThread, Priority);
   SetPriorityClass(GetCurrentProcess, PriorityClass);
   Result := TimerLo / (1000.0 * DelayTime);
end;

//获取CPU的标识ID号
function GetCPUID : TCPUID; assembler; register;
asm
  PUSH    EBX         {Save affected register}
  PUSH    EDI
  MOV     EDI,EAX     {@Resukt}
  MOV     EAX,1
  DW      $A20F       {CPUID Command}
  STOSD			          {CPUID[1]}
  MOV     EAX,EBX
  STOSD               {CPUID[2]}
  MOV     EAX,ECX
  STOSD               {CPUID[3]}
  MOV     EAX,EDX
  STOSD               {CPUID[4]}
  POP     EDI					{Restore registers}
  POP     EBX
end;

//获取计算机的物理内存
function GetMemoryTotalPhys : Dword;
var
   memStatus: TMemoryStatus;
be