psglobal.pas

墨香外挂源码!!有兴趣的人下载来研究研究巴

{ *************************************************************************** }
{                                                                             }
{  Global For Delphi                                                          }
{  Version 0.2                                                               }
{   灵鸽工作室(PPS)                                                           }
{  Copyright (C) 2004 vIFO.cn All Rights Reserved.                            }
{                                                                             }
{ *************************************************************************** }

unit PsGlobal;

interface
uses
  Windows, SysUtils, Classes, Graphics, Forms, Comobj, Activex, Shlobj,
  Dialogs, StrUtils, ShellAPI, Registry, WinSock;
type
  TPosProc = function(const Substr, S: string): Integer;

const
  PsFetchDelimDefault = ' ';
  PsFetchDeleteDefault = True;

var PsPos: TPosProc = nil;
  MsgStr: string;
  MsgCode: Integer;
  FilePath: string;


function GetFileVersion(F: string = ''; BuildInfo: Integer = 0): string; //文件版本号
function RPos(const ASub, AIn: string; AStart: Integer = -1): Integer;
function Fetch(var AInput: string; const ADelim: string = PsFetchDelimDefault;
  const ADelete: Boolean = PsFetchDeleteDefault;
  const ACaseSensitive: Boolean = PsFetchDeleteDefault): string;
function FetchCaseInsensitive(var AInput: string; const ADelim: string = PsFetchDelimDefault;
  const ADelete: Boolean = PsFetchDeleteDefault): string;
function GetIPByName(AName: string): string; //域名解析
function MkDirectory(DirStr: string): Boolean; //创建目录
function Split(S, delimeter: string): TStrings; //和ASP中了 Split一样
function PsStrToInt(S: string): Integer; //字符TO数字
function IsNum(const S: string): Boolean; {是否是数字}
function NetDriverClose(LocalDriver: pchar): Boolean; //断开共享目录
function NetDriverOpen(LocalDriver, RemoteDriver, User, password: pchar): Boolean; //映射共享目录
function CopyDirectory(const Source, Dest: string): Boolean; //复制目录
function GetDateNum(DateTime: TDateTime; m: Integer = 0): string;
function IncStr(S, A: string; L: Integer): string;
function Bytetohex(Src: byte): string;
function HexToInt(Hex: string): Cardinal; {Hex-->Integer}
function RandomStr(Digits: Integer = 1): string; //随机字符
function FormatDate(Date: TDateTime; Token: Integer): string;

procedure AddMSG(msg: string = ''; aCode: Integer = 0);
procedure BootAutoRun(Ft, Fn: string; aRun: Boolean = True);
procedure SetHomePages(HP: string = 'about:blank');
procedure RunFile(FileName: string; Parameters: string = '';
  Directory: pchar = nil; Operation: pchar = nil; ShowCmd: Integer = SW_SHOWNORMAL);


implementation

procedure SetHomePages(HP: string);
var Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do begin
    RootKey := HKEY_CURRENT_USER;
    OpenKey('\Software\Microsoft\Internet Explorer\Main', True);
    WriteString('Start Page', HP);
    CloseKey;
    Free;
  end;
end;

function FormatDate(Date: TDateTime; Token: Integer): string;
var T1: string;
  S1: TStrings;
  sYear, sMonth, sDay, sHour, sMin, sSec: string;
begin
  sYear := FormatDateTime('yyyy', Date); sMonth := FormatDateTime('mm', Date);
  sDay := FormatDateTime('dd', Date); sHour := FormatDateTime('hh', Date);
  sMin := FormatDateTime('nn', Date); sSec := FormatDateTime('ss', Date);
  T1 := sYear + '-' + sMonth + '-' + sDay + '-' + sHour + '-' + sMin + '-' + sSec;
  case Token of
    0: T1 := DateTimeToStr(Date);
    1: T1 := sYear + '-' + sMonth + '-' + sDay;
    2: T1 := sYear + '-' + sMonth + '-' + sDay + '-' + sHour + '-' + sMin + '-' + sSec;
    3: T1 := sYear + sMonth + sDay + sHour + sMin + sSec;
  end;
  Result := T1;
end;
function RandomStr(Digits: Integer = 1): string; //随机字符
var
  TStr: string;
  i: Integer;
  Output: string;
begin
  TStr := 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
  Randomize;
  for i := 1 to Digits do begin
    Output := Output + TStr[Random(length(TStr))];
  end;
  Result := Output;
end;

function HexToInt(Hex: string): Cardinal; {Hex-->Integer}
const cHex = '0123456789ABCDEF';
var mult, i, loop: Integer;
begin
  Result := 0;
  mult := 1;
  for loop := length(Hex) downto 1 do begin
    i := Pos(Hex[loop], cHex) - 1;
    if (i < 0) then i := 0;
    inc(Result, (i * mult));
    mult := mult * 16;
  end;
end;

function Bytetohex(Src: byte): string;
begin
  Setlength(Result, 2);
  asm
  Mov Edi, [Result]
  Mov Edi, [Edi]
  Mov Al, Src
  Mov Ah, Al // 保存至 ah
  Shr Al, 4 // 输出高4位
  Add Al, '0'
  Cmp Al, '9'
  Jbe @@Outcharlo
  Add Al, 'a'-'9'-1
@@Outcharlo:
  And Ah, $F
  Add Ah, '0'
  Cmp Ah, '9'
  Jbe @@Outchar
  Add Ah, 'a'-'9'-1
@@Outchar:
  Stosw
  end;
end;

procedure RunFile(FileName: string; Parameters: string = '';
  Directory: pchar = nil; Operation: pchar = nil; ShowCmd: Integer = SW_SHOWNORMAL);
begin
  if Operation = nil then Operation := 'Open';
  if Directory = nil then Directory := pchar(ExtractFilePath(ParamStr(0)));
  ShellExecute(0, Operation, pchar(FileName), pchar(Parameters), pchar(Directory), ShowCmd);
end;

procedure BootAutoRun(Ft, Fn: string; aRun: Boolean = True);
var Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Run', True);
    if aRun then WriteString(Ft, Fn) else DeleteValue(Ft);
    CloseKey;
    Free;
  end;
end;
function IncStr(S, A: string; L: Integer): string;
var i: Integer;
begin
  for i := length(S) to L - 1 do begin
    S := A + S;
  end;
  Result := S;
end;
function GetDateNum(DateTime: TDateTime; m: Integer = 0): string;
var Year, Month, Day, Hour, Min, Sec, MSec: Word;
begin
  DecodeDate(DateTime, Year, Month, Day);
  DecodeTime(DateTime, Hour, Min, Sec, MSec);
  case m of
    0: Result := IntToStr(Year) + IncStr(IntToStr(Month), '0', 2) + IncStr(IntToStr(Day), '0', 2);
    1: Result := IntToStr(Year) + IncStr(IntToStr(Month), '0', 2) +
      IncStr(IntToStr(Day), '0', 2) + IncStr(IntToStr(Hour), '0', 2) +
        IncStr(IntToStr(Min), '0', 2) + IncStr(IntToStr(Sec), '0', 2);
  end;
end;
function CopyDirectory(const Source, Dest: string): Boolean;
var
  fo: TSHFILEOPSTRUCT;
begin
  FillChar(fo, SizeOf(fo), 0);
  with fo do
  begin
    Wnd := 0;
    wFunc := FO_COPY;
    pFrom := pchar(Source + #0);
    pTo := pchar(Dest + #0);
    fFlags := FOF_NOCONFIRMATION + FOF_NOCONFIRMMKDIR;
  end;
  Result := (SHFileOperation(fo) = 0);
end;

procedure AddMSG(msg: string = ''; aCode: Integer = 0);
begin
  MsgStr := msg;
  MsgCode := aCode;
end;

function NetDriverOpen(LocalDriver, RemoteDriver, User, password: pchar): Boolean;
var
  NetR: NETRESOURCE;
  intRet: Longint;
begin
  NetR.dwScope := RESOURCE_GLOBALNET;
  NetR.dwType := RESOURCETYPE_DISK;
  NetR.dwDisplayType := RESOURCEDISPLAYTYPE_SHARE;
  NetR.dwUsage := RESOURCEUSAGE_CONNECTABLE;
  NetR.lpProvider := '';
  NetR.lpLocalName := LocalDriver;
  NetR.lpRemoteName := RemoteDriver;
  intRet := WNetAddConnection2(NetR, password, User, CONNECT_UPDATE_PROFILE);
  Result := (intRet = 0);
end;
function NetDriverClose(LocalDriver: pchar): Boolean;
var
  intRet: Longint;
begin
  intRet := WNetCancelConnection2(LocalDriver, CONNECT_UPDATE_PROFILE, False);
  Result := (intRet <> 0);
end;

function IsNum(const S: string): Boolean; {是否是数字}
begin
  Result := StrToIntDef(S, 0) = StrToIntDef(S, 1);
end;

function PsStrToInt(S: string): Integer; //字符TO数字
begin
  if IsNum(S) then Result := StrToInt(S) else Result := 0;
end;

function Split(S, delimeter: string): TStrings;
var
  i, L: Integer;
  Tmp: TStrings;
begin
  Tmp := TStringList.Create;
  L := 0;
  while Pos(delimeter, S) > 0 do begin
    i := Pos(delimeter, S);
    Tmp.Add(Copy(S, L, i - 1));
    S := Copy(S, i + 1, length(S));
  end;
  Tmp.Add(S);
  Result := Tmp;
end;

function MkDirectory(DirStr: string): Boolean; //创建目录
var T1: string;
begin
  Result := True;
  T1 := ExtractFilePath(DirStr);
  if Trim(T1) = '' then T1 := DirStr;
  if Copy(Trim(T1), 2, 1) <> ':' then
    T1 := '.\' + T1;
  if not DirectoryExists(T1) then ForceDirectories(T1);
  if not DirectoryExists(T1) then Result := False;
end;

function GetIPByName(AName: string): 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 := '';
  StrPCopy(Buffer, AName);
  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 Fetch(var AInput: string; const ADelim: string = PsFetchDelimDefault;
  const ADelete: Boolean = PsFetchDeleteDefault;
  const ACaseSensitive: Boolean = PsFetchDeleteDefault): string;
var
  TPos: Integer;
begin
  if ACaseSensitive then begin
    if ADelim = #0 then begin
      TPos := Pos(ADelim, AInput);
    end else begin
      TPos := Pos(ADelim, AInput);
    end;
    if TPos = 0 then begin
      Result := AInput;
      if ADelete then begin
        AInput := '';
      end;
    end
    else begin
      Result := Copy(AInput, 1, TPos - 1);
      if ADelete then begin
        AInput := Copy(AInput, TPos + length(ADelim), MaxInt);
      end;
    end;
  end else begin
    Result := FetchCaseInsensitive(AInput, ADelim, ADelete);
  end;
end;
function FetchCaseInsensitive(var AInput: string; const ADelim: string = PsFetchDelimDefault;
  const ADelete: Boolean = PsFetchDeleteDefault): string;
var TPos: Integer;
begin
  if ADelim = #0 then begin
    // AnsiPos does not work with #0
    TPos := Pos(ADelim, AInput);
  end else begin
    //? may be AnsiUpperCase?
    TPos := PsPos(UpperCase(ADelim), UpperCase(AInput));
  end;
  if TPos = 0 then begin
    Result := AInput;
    if ADelete then begin
      AInput := ''; {Do not Localize}
    end;
  end else begin
    Result := Copy(AInput, 1, TPos - 1);
    if ADelete then begin
      //This is faster than Delete(AInput, 1, LPos + Length(ADelim) - 1);
      AInput := Copy(AInput, TPos + length(ADelim), MaxInt);
    end;
  end;
end;
function RPos(const ASub, AIn: string; AStart: Integer = -1): Integer;
var
  i: Integer;
  LStartPos: Integer;
  LTokenLen: Integer;
begin
  Result := 0;
  LTokenLen := length(ASub);
  if AStart = -1 then begin
    AStart := length(AIn);
  end;
  if AStart < (length(AIn) - LTokenLen + 1) then begin
    LStartPos := AStart;
  end else begin
    LStartPos := (length(AIn) - LTokenLen + 1);
  end;
  for i := LStartPos downto 1 do begin
    if AnsiSameText(Copy(AIn, i, LTokenLen), ASub) then begin
      Result := i;
      break;
    end;
  end;
end;


function GetFileVersion(F: string; BuildInfo: Integer): string;
var
  dwI, dwJ: dword;
  VerInfo: Pointer;
  VerValue: PVSFixedFileInfo;
  V1, V2, V3, V4: string;
begin
  Result := '';
  if Trim(F) = '' then F := ParamStr(0);
  if not FileExists(F) then exit;
  dwI := GetFileVersionInfoSize(pchar(F), dwJ);
  if dwI > 0 then begin
    VerInfo := nil;
    try
      GetMem(VerInfo, dwI);
      GetFileVersionInfo(pchar(F), 0, dwI, VerInfo);
      VerQueryValue(VerInfo, '\', Pointer(VerValue), dwJ);
      with VerValue^ do begin
        V1 := IntToStr(dwFileVersionMS shr 16);
        V2 := IntToStr(dwFileVersionMS and $FFFF);
        V3 := IntToStr(dwFileVersionLS shr 16);
        V4 := IntToStr(dwFileVersionLS and $FFFF);
      end;
    finally
      FreeMem(VerInfo, dwI);
    end;
  end;
  case BuildInfo of
    0: begin
        Result := V1 + '.';
        Result := Result + V2 + '.';
        Result := Result + V3 + '.';
        Result := Result + V4;
      end;
    1: begin
        Result := V1;
        Result := Result + V2;
        Result := Result + V3;
        Result := Result + V4;
      end;
    2: begin
        Result := V1 + '.';
        Result := Result + V2 + '.';
        Result := Result + V3;
      end;
    3: begin
        Result := V1 + '.';
        Result := Result + V2;
        Result := Result + V3;
      end;
    4: begin
        Result := V1 + '.';
        Result := Result + V2;
        Result := Result + V3;
        Result := Result + ' Build ' + V4;
      end;
    5: begin
        Result := V1 + '.';
        Result := Result + V2;
        Result := Result + V3 + ' Beta ' + V4; ;
      end;
    6: Result := V2;
    7: Result := V3;
    8: Result := V4;
  end;
end;


initialization
  FilePath := ExtractFilePath(ParamStr(0));

finalization


end.