main.pas

灰鸽子VIP1.2经典源代码

    m := (Tmp div 1000) div 60 - h * 60;
    result := inttostr(h) + ':' + inttostr(m) + ':' + inttostr(s);
  except
    result := '00:00:00';
  end;
end;

function CenterStr(Src: string; Before, After: string): string;
var
  Pos1, Pos2: WORD;
begin
  Pos1 := Pos(Before, Src);
  Pos2 := Pos(After, Src);
  if (Pos1 = 0) or (Pos2 = 0) then
  begin
    Result := '';
    Exit;
  end;
  Pos1 := Pos1 + Length(Before);
  if Pos2 - Pos1 = 0 then
  begin
    Result := '';
    Exit;
  end;
  Result := Copy(Src, Pos1, Pos2 - Pos1);
end;

procedure THgzVip.wmqueryendsession(var message: twmqueryendsession);
begin
  inherited;
  message.Result := 1;
  Application.Terminate;
end;

procedure THgzVip.AddLineStr(LineStr: string; IsColor: integer; isBold: Bool);
var
  i: integer;
begin
  if ISClientClose then Exit;
  LineStr:=DateTimeToStr(Now) + ' - ' +LineStr;
  try
    with CmdRichEdit do
    begin
      Lines.Insert(0,LineStr);
      SelStart:=0;
      SelLength:=Length(LineStr);
      if IsColor = 0 then SelAttributes.Color := clGreen;
      if IsColor = 1 then SelAttributes.Color := clBlue;
      if IsColor = 2 then SelAttributes.Color := clRed;
      if IsColor = 3 then
      begin
        Randomize;
        SelAttributes.Color := RGB(Random(255), Random(255), Random(255));
      end;
      if isBold then SelAttributes.Style := [fsBold];
      SelLength:=0;
    end;
  except
    try
      CmdRichEdit.Lines.Clear;
      CmdRichEdit.Lines.Insert(0,LineStr);
    except
    end;
  end;
end;

function Soundkarte: Boolean;
begin
  Result := WaveOutGetNumDevs > 0;
end;

function GetFileSize(const FileName: string): integer;
var f: TFileStream;
begin
  f := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  Result := f.Size;
  F.Free;
end;


function Temppath: string;
var tmpdir: array[0..255] of char;
begin
  GetTempPath(255, @tmpdir);
  Result := StrPas(Tmpdir);
end;

function IsValidFileName(const FileName: string): boolean;
begin
  result := True; ;
  if (pos('\', Filename) > 0) or (pos('/', Filename) > 0) or (pos(':', Filename) > 0)
    or (pos('*', Filename) > 0) or (pos('?', Filename) > 0) or (pos('"', Filename) > 0)
    or (pos('<', Filename) > 0) or (pos('>', Filename) > 0) or (pos('|', Filename) > 0) then
  begin
    result := False;
  end;
end;

procedure GetLocalIP;
type
  TaPInAddr = array[0..255] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: array[0..63] of char;
  i: integer;
  GInitData: TWSADATA;
  Temp: string;
begin
  wsastartup($101, GInitData);
  Temp := '';
  GetHostName(Buffer, SizeOf(Buffer));
  phe := GetHostByName(buffer);
  if not assigned(phe) then
    exit;
  pptr := PaPInAddr(Phe^.h_addr_list);
  i := 0;
  while pptr^[I] <> nil do begin
    Temp := Temp + StrPas(inet_ntoa(pptr^[I]^)) + ',';
    inc(i);
  end;
  Delete(Temp, Length(Temp), 1);
  try
    HgzVip.Caption := HgzVip.Translate('Caption','灰鸽子 Vip 1.2') +'    '+ Temp;    //
  except
  end;
  wsacleanup;
end;

function HostToIP(Name: string; var Ip: string): Boolean;
var
  wsdata: TWSAData;
  hostName: array[0..255] of char;
  hostEnt: PHostEnt;
  addr: PChar;
begin
  WSAStartup($0101, wsdata);
  try
    gethostname(hostName, sizeof(hostName));
    StrPCopy(hostName, Name);
    hostEnt := gethostbyname(hostName);
    if Assigned(hostEnt) then
      if Assigned(hostEnt^.h_addr_list) then begin
        addr := hostEnt^.h_addr_list^;
        if Assigned(addr) then begin
          IP := Format('%d.%d.%d.%d', [byte(addr[0]),
            byte(addr[1]), byte(addr[2]), byte(addr[3])]);
          Result := True;
        end
        else
          Result := False;
      end
      else
        Result := False
    else begin
      Result := False;
    end;
  finally
    WSACleanup;
  end
end;


function RandomPass(const Str: string): string;
var
  fkey: integer;
  Text: PChar;
  i: Integer;
begin
  Text := Pchar(Str);
  fkey := random(9);
  if fkey = 0 then fkey := 3;
  for i := 0 to length(Str) - 1 do
  begin
    Text[i] := Chr(Ord(Text[i]) + fkey);
  end;
  Result := inttostr(fkey) + Text;
end;


function THgzVip.DongdaiIP: string;
var
  WSAData: TWSAData;
  HostName: array[0..MAX_COMPUTERNAME_LENGTH] of Char;
  HostEnt: PHostEnt;
  LastIP: PInAddr;
  IPList: ^PInAddr;
begin
  if 0 = WSAStartup(MAKEWORD(1, 1), WSAData) then
  try
    if 0 = gethostname(HostName, MAX_COMPUTERNAME_LENGTH + 1) then
    begin
      HostEnt := gethostbyname(HostName);
      if HostEnt <> nil then
      begin
        IPList := Pointer(HostEnt^.h_addr_list);
        repeat
          LastIP := IPList^;
          INC(IPList);
        until IPList^ = nil;
        if LastIP <> nil then begin
          Result := inet_ntoa(LastIP^);
        end;
      end;
    end;
  finally
    WSACleanup;
  end;
end;


function GetFilepath(FileName: string): string; {从全路径中分离路径,有'\'}
var Contador: integer;
begin
  Contador := 1;
  while Copy(FileName, Length(FileName) - Contador, 1) <> '\' do
  begin
    Contador := Contador + 1;
  end;
  Result := (Copy(FileName, 1, Length(FileName) - Contador));
end;


{如何创建目录树}
procedure MakeDir(Dir: string);
  function Last(What: string; Where: string): Integer;
  var
    Ind: Integer;
  begin
    Result := 0;
    for Ind := (Length(Where) - Length(What) + 1) downto 1 do
      if Copy(Where, Ind, Length(What)) = What then begin
        Result := Ind;
        Break;
      end;
  end;
var
  PrevDir: string;
  Ind: Integer;
begin
  if Copy(Dir, 2, 1) <> ':' then
    if Copy(Dir, 3, 1) <> '\' then
      if Copy(Dir, 1, 1) = '\' then
        Dir := 'C:' + Dir
      else
        Dir := 'C:\' + Dir
    else
      Dir := 'C:' + Dir; if not DirectoryExists(Dir) then begin
     {如果目录不存在,取得上一个目录名}
    Ind := Last('\', Dir); {最后一个 '\'的位置}
    PrevDir := Copy(Dir, 1, Ind - 1); {上一个目录}
     {如果上一个目录不存在}
     {传递给此递归过程}
    if not DirectoryExists(PrevDir) then
      MakeDir(PrevDir);
     {在这里,上一个目录必须存在
      创建(in "Dir"; variable)目录}
    CreateDir(Dir);
  end;
end;


function CustomSortProc(Item1, Item2: TListItem; ParamSort: integer):
  integer; stdcall;
  function ToFileSize(TheFilesize: string): integer;
  var
    i: integer;
    S: string;
  begin
    try
      if pos(',', TheFilesize) = 0 then
      begin
        Result := Strtoint(TheFilesize);
        Exit;
      end;
      for i := 1 to length(TheFilesize) do
      begin
        if TheFilesize[i] <> ',' then
          S := S + TheFilesize[i];
      end;
      Result := Strtoint(S);
    except
    end;
  end;
begin
  try
    case ParamSort of
      0:
        begin
          if UpDown[0] = True then begin
            if (Item1.ImageIndex = 4) and (Item2.ImageIndex = 4) then begin
              Result := CompareText(Item1.Caption, Item2.Caption);
              Exit;
            end;
            if (Item1.ImageIndex = 32) and (Item2.ImageIndex = 32) then begin
              Result := CompareText(Item1.Caption, Item2.Caption);
              Exit;
            end;
            if (Item1.ImageIndex > 4) and (Item2.ImageIndex > 4) and
              (Item1.ImageIndex < 28) then begin
              Result := CompareText(Item1.Caption, Item2.Caption);
              Exit;
            end;
            if (Item1.ImageIndex > 32) and (Item2.ImageIndex > 32) then begin
              Result := CompareText(Item1.Caption, Item2.Caption);
              Exit;
            end;
            if (Item1.ImageIndex = 4) and (Item2.ImageIndex > 4) then begin
              Result := -1;
              Exit;
            end;
            if (Item1.ImageIndex = 32) and (Item2.ImageIndex > 32) then begin
              Result := -1;
              Exit;
            end;
            if (Item1.ImageIndex > 4) and (Item2.ImageIndex = 4) then begin
              Result := -1;
              exit;
            end;
          end
          else
            if (Item1.ImageIndex = 4) and (Item2.ImageIndex = 4) then begin
              Result := -CompareText(Item1.Caption, Item2.Caption);
              exit;
            end;
          if (Item1.ImageIndex = 32) and (Item2.ImageIndex = 32) then begin
            Result := -CompareText(Item1.Caption, Item2.Caption);
            exit;
          end;
          if (Item1.ImageIndex > 4) and (Item2.ImageIndex > 4)
            and (Item1.ImageIndex < 28) then begin
            Result := -CompareText(Item1.Caption, Item2.Caption);
            exit;
          end;
          if (Item1.ImageIndex > 32) and (Item2.ImageIndex > 32) then begin
            Result := -CompareText(Item1.Caption, Item2.Caption);
            exit;
          end;
          //if (Item1.ImageIndex = 1) and (Item2.ImageIndex > 1) then begin
          //  Result := -1;
          //  exit;
          //end;
          if (Item1.ImageIndex = 32) and (Item2.ImageIndex > 32) then begin
            Result := -1;
            exit;
          end;
          if (Item1.ImageIndex > 4) and (Item2.ImageIndex = 4) then begin
            Result := -1;
            exit;
          end;
          if (Item1.ImageIndex > 32) and (Item2.ImageIndex = 32) then begin
            Result := -1;
            exit;
          end;
        end;
      1:
        begin
          if UpDown[1] = True then begin
            if (Item1.ImageIndex = 4) and (Item2.ImageIndex = 4) then begin
              Result := 1;
              Exit;
            end;
            if (Item1.ImageIndex > 4) and (Item2.ImageIndex > 4)
              and (Item1.ImageIndex < 28) and (Item2.ImageIndex < 28) then
            begin
              if ToFileSize(Item1.SubItems.Strings[0]) > ToFileSize(Item2.SubItems.Strings[0]) then
                Result := -1
              else Result := 1;
              Exit;
            end;
            if (Item1.ImageIndex > 32) and (Item2.ImageIndex > 32) then begin
              if ToFileSize(Item1.SubItems.Strings[0]) > ToFileSize(Item2.SubItems.Strings[0]) then
                Result := -1
              else Result := 1;
              Exit;
            end;
            if (Item1.ImageIndex = 4) and (Item2.ImageIndex > 4) then begin
              Result := -1;
              Exit;
            end;
            if (Item1.ImageIndex = 32) and (Item2.ImageIndex > 32) then begin
              Result := -1;
              Exit;
            end;
            if (Item1.ImageIndex = 32) and (Item2.ImageIndex = 32) then begin
              Result := 1;
              Exit;
            end;
          end
          else begin
            if (Item1.ImageIndex = 4) and (Item2.ImageIndex = 4) then begin
              Result := 1;
              Exit;