toolbox.pas

delphi框架

    if
      reg.OpenKey('\Software\Microsoft\Internet Explorer\AdvancedOptions\BROWSE\SCRIPT_DEBUGGER',
      true) then
    begin
      reg.WriteString('CheckedValue', 'no');
      reg.CloseKey
    end
    else
      result := false;
  except
    result := false;
  end;
  if assigned(reg) then
    reg.Free;
end;

//
 // 本地地址不使用Proxy
 ////

function setLocalWebNotUserProx: Boolean;
var
  reg: TRegistry;
begin
  result := true;
  reg := TRegistry.Create(KEY_ALL_ACCESS);
  try
    reg.RootKey := HKEY_CURRENT_USER;
    if
      reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet Settings',
      true) then
    begin
      reg.WriteString('ProxyOverride', '<local>');
      reg.CloseKey
    end
    else
      result := false;
  except
    result := false;
  end;
  if assigned(reg) then
    reg.Free;
end;

function getMyHostName: string;
var
  wVersionRequested: WORD;
  wsaData: TWSAData;
  p: PHostEnt;
  s: array[0..128] of char;
begin
  {启动 WinSock}
  wVersionRequested := MAKEWORD(1, 1);
  WSAStartup(wVersionRequested, wsaData);

  {计算机名}
  GetHostName(@s, 128);
  p := GetHostByName(@s);
  result := p^.h_Name;
  WSACleanup;
end;

function getMyIP: string;
var
  wVersionRequested: WORD;
  wsaData: TWSAData;
  p: PHostEnt;
  s: array[0..128] of char;
  p2: pchar;
begin
  {启动 WinSock}
  wVersionRequested := MAKEWORD(1, 1);
  WSAStartup(wVersionRequested, wsaData);

  {计算机名}
  GetHostName(@s, 128);
  p := GetHostByName(@s);

  {IP地址}
  p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
  result := p2;

  WSACleanup;
end;

function startWith(s, search: string): Boolean;
begin
  result := pos(search, s) = 1;
end;

//
 // 将程序strExeFileName置为自动启动
 //

function StartUpMyProgram(const AKEY: string = ''; AExename: string = ''): boolean;
var
  key, name: string;
begin
  //建立一个Registry实例
  with TRegistry.Create do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    //设置根键值为HKEY_LOCAL_MACHINE
    //找到Software\Microsoft\Windows\CurrentVersion\Run
    if OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', True) then
      //写入自己程序的快捷方式信息
    begin
      if AKey = '' then
        key := strPrompt
      else
        key := AKey;

      if AExename = '' then
        name := Application.ExeName
      else
        name := AExeName;

      WriteString(key, name);
      result := true;
    end
    else
      result := false;
    //善后处理
    CloseKey;
    Free;
  end;
end;

function UnStartUpMyProgram(const AKey: string = ''): boolean;
begin
  //建立一个Registry实例
  with TRegistry.Create do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    //设置根键值为HKEY_LOCAL_MACHINE
    //找到Software\Microsoft\Windows\CurrentVersion\Run
    if OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', True) then
      //写入自己程序的快捷方式信息
    begin
      if AKey = '' then
        deleteValue(strPrompt)
      else
        deleteValue(akey);

      result := true;
    end
    else
      result := false;
    //善后处理
    CloseKey;
    Free;
  end;
end;

procedure BMP2JPG(bmpfile: string; jpgfile: string);
var
  img: TImage;
  jpg: TJPEGIMage;
begin
  img := TImage.Create(nil);
  jpg := TJPEGIMage.Create;
  try
    img.Picture.LoadFromFile(bmpfile);
    jpg.Assign(img.Picture.Graphic);
    jpg.SaveToFile(jpgfile);
    deletefile(pchar(bmpfile));
  finally
    img.Free;
    jpg.free;
  end;
end;

function GetExecutePath: string;
begin
  result := extractFilePath(application.ExeName);
end;

function GetTempDirectory: string;
var
  TempDir: array[0..255] of Char;
begin
  GetTempPath(255, @TempDir);
  Result := StrPas(TempDir);
end;

function OnLine: boolean;
var
  ConnectState: DWORD;
  StateSize: DWORD;
begin
  ConnectState := 0;
  StateSize := SizeOf(ConnectState);
  result := false;
  if InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ConnectState,
    StateSize) then
    if (ConnectState and INTERNET_STATE_DISCONNECTED) <> 2 then
      result := true;
end;

//产生唯一的ID，在第一次调用此函数前，需要将GlobalID置为零
//

function generateID: Integer;
var
  hMutex: THANDLE;
begin
  hMutex := newMutex('getgenerateID');
  inc(GlobalID);
  result := GlobalID;
  freeMutex(hMutex);
end;

function newMutex(const AMutesID: string = 'eazisoft'): THandle;
var
  hMutex: THANDLE;
  Err: DWORD;
begin
  hMutex := CreateMutex(nil, FALSE, pchar(AMutesID));
  Err := GetLastError();
  if (Err = ERROR_ALREADY_EXISTS) then // ????,??
  begin
    WaitForSingleObject(hMutex, INFINITE); //8000L);
    hMutex := CreateMutex(nil, FALSE, 'generateID');
  end;
  result := hMutex;
end;

procedure freeMutex(AMutexHandle: THandle);
begin
  ReleaseMutex(AMutexHandle);
end;

procedure ShowBlankPage(WebBrowser: TWebBrowser);
var
  URL: OleVariant;
begin
  URL := 'about:blank';
  WebBrowser.Navigate2(URL);
end;

function ParamInCommandline(APAram: string): boolean;
var
  i: integer;
begin
  result := false;
  for i := 1 to paramCount do
  begin
    if (lowercase(paramstr(i)) = lowercase(aparam)) then
    begin
      result := true;
      break;
    end;
  end;
end;

function getSystemPath: string;
var
  MySysPath: PCHAR;
begin
  GetMem(MySysPath, 255);
  GetSystemDirectory(MySysPath, 255);
  result := MySysPath;
  freeMem(MySysPath);
end;

{This way uses a File stream.}

procedure FileCopy(const sourcefilename, targetfilename: string);
begin
  with TFormCopyFile.create(nil) do
  begin
    show;
    lblFrom.caption := 'Copying file: ' + extractFileName(sourcefilename) + ' ';

    update;
    copyFile(pchar(sourcefilename), pchar(targetfilename), false);
    close;
    free;
  end;
end;


function isHung(theWindow: HWnd; timeOut: Longint): Boolean;
var
  dwResult: DWord;
  i: integer;
begin
  i := SendMessageTimeout(theWindow,
    WM_NULL,
    0,
    0,
    SMTO_ABORTIFHUNG or SMTO_BLOCK,
    timeOut,
    dwResult);
  Result := i <> 0;
end;

function ProgramNotRunning(WHandle: THandle): Boolean;
var
  dwExitCode: DWORD;
  fprocessExit: boolean;
begin
  dwExitCode := 0;
  fprocessExit := GetExitCodeProcess(WHandle, dwExitCode);
  result := (fprocessExit and (dwExitCode <> STILL_ACTIVE));
end;


function ChangeSystemDateTime(dtNeeded: TDateTime): Boolean;
var
//  tzi: TTimeZoneInformation;
  dtSystem: TSystemTime;
begin
//  GetTimeZoneInformation(tzi);
//  dtNeeded := dtNeeded + tzi.Bias / 1440;
  datetimeToSystemTime(dtNeeded, dtSystem);
  {with dtSystem do
  begin
    wYear := StrToInt(FormatDateTime('yyyy', dtNeeded));
    wMonth := StrToInt(FormatDateTime('mm', dtNeeded));
    wDay := StrToInt(FormatDateTime('dd', dtNeeded));
    wHour := StrToInt(FormatDateTime('hh', dtNeeded));
    wMinute := StrToInt(FormatDateTime('nn', dtNeeded));
    wSecond := StrToInt(FormatDateTime('ss', dtNeeded));
    wMilliseconds := 0;
  end;
  }
  Result := SetLocalTime(dtSystem);
end;


procedure HideTaskbar; //隐藏
var
  wndHandle: THandle;
  wndClass: array[0..50] of Char;
begin
  StrPCopy(@wndClass[0], 'Shell_TrayWnd');
  wndHandle := FindWindow(@wndClass[0], nil);
  ShowWindow(wndHandle, SW_HIDE);
end;

procedure ShowTaskbar; //显示
var
  wndHandle: THandle;
  wndClass: array[0..50] of Char;
begin
  StrPCopy(@wndClass[0], 'Shell_TrayWnd');
  wndHandle := FindWindow(@wndClass[0], nil);
  ShowWindow(wndHandle, SW_RESTORE);
end;


procedure SetMediaAudioOff(DeviceID: word);
var
  SetParm: TMCI_SET_PARMS;
begin
  SetParm.dwAudio := MCI_SET_AUDIO_ALL;
  mciSendCommand(DeviceID,
    MCI_SET,
    MCI_SET_AUDIO or MCI_SET_OFF,
    Longint(@SetParm));
end;

procedure SetMediaAudioOn(DeviceID: word);
var
  SetParm: TMCI_SET_PARMS;
begin
  SetParm.dwAudio := MCI_SET_AUDIO_ALL;
  mciSendCommand(DeviceID,
    MCI_SET,
    MCI_SET_AUDIO or MCI_SET_ON,
    Longint(@SetParm));
end;

//
//this function is for reboot and shutdown use
//

procedure AdjustToken;
var
  hdlProcessHandle: Cardinal;
  hdlTokenHandle: Cardinal;
  tmpLuid: Int64;
//    tkpPrivilegeCount: Int64;
  tkp: TOKEN_PRIVILEGES;
  tkpNewButIgnored: TOKEN_PRIVILEGES;
  lBufferNeeded: Cardinal;
  Privilege: array[0..0] of _LUID_AND_ATTRIBUTES;
begin
  hdlProcessHandle := GetCurrentProcess;
  OpenProcessToken(hdlProcessHandle,
    (TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY),
    hdlTokenHandle);

  // Get the LUID for shutdown privilege.
  LookupPrivilegeValue('', 'SeShutdownPrivilege', tmpLuid);
  Privilege[0].Luid := tmpLuid;
  Privilege[0].Attributes := SE_PRIVILEGE_ENABLED;
  tkp.PrivilegeCount := 1; // One privilege to set
  tkp.Privileges[0] := Privilege[0];
  // Enable the shutdown privilege in the access token of this
  // process.
  windows.AdjustTokenPrivileges(hdlTokenHandle,
    False,
    tkp,
    Sizeof(tkpNewButIgnored),
    tkpNewButIgnored,
    lBufferNeeded);
end;

//reboot the computer
//

procedure reboot;
begin
  AdjustToken;
  ExitWindowsEx((EWX_SHUTDOWN or EWX_FORCE or EWX_REBOOT), $FFFF);
end;

procedure shutdown;
begin
  AdjustToken;
  ExitWindowsEx(EWX_SHUTDOWN or EWX_FORCE, $FFFF);
end;



procedure terminate;
begin
  KillProcess(application.Handle);
end;

//kill a process with given window handle

procedure KillProcess(hWindowHandle: HWND);
var
  hprocessID: INTEGER;
  processHandle: THandle;
  DWResult: DWORD;
begin
  SendMessageTimeout(hWindowHandle, WM_CLOSE, 0, 0,
    SMTO_ABORTIFHUNG or SMTO_NORMAL, 5000, DWResult);

  if isWindow(hWindowHandle) then
  begin
    // PostMessage(hWindowHandle, WM_QUIT, 0, 0);

    { Get the process identifier for the window}
    windows.GetWindowThreadProcessID(hWindowHandle, @hprocessID);
    if hprocessID <> 0 then
    begin
      { Get the process handle }
      processHandle := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION,
        False, hprocessID);
      if processHandle <> 0 then
      begin
        { Terminate the process }
        TerminateProcess(processHandle, 0);
        CloseHandle(ProcessHandle);
      end;
    end;
  end;
end;


///////////////////////////////////////////////////////////////////
// Call back function used to set the initial browse directory.
///////////////////////////////////////////////////////////////////

function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT;
  lParam, lpData: LPARAM): Integer stdcall;
begin
  if uMsg = BFFM_INITIALIZED then
    SendMessage(Wnd, BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1]));
  result := 0;
end;

///////////////////////////////////////////////////////////////////
// This function allows the user to browse for a folder
//
// Arguments:-
//    browseTitle : The title to display on the browse dialog.
//  initialFolder : Optional argument. Use to specify the folder
//                  initially selected when the dialog opens.
//
// Returns: The empty string if no folder was selected (i.e. if the
//          user clicked cancel), otherwise the full folder path.
///////////////////////////////////////////////////////////////////

function BrowseForFolder(const browseTitle: string; const initialFolder: string = ''): string;
var
  browse_info: TBrowseInfo;
  folder: array[0..MAX_PATH] of char;
  find_context: PItemIDList;
begin
  FillChar(browse_info, SizeOf(browse_info), #0);
  lg_StartFolder := initialFolder;
  browse_info.pszDisplayName := @folder[0];
  browse_info.lpszTitle := PChar(browseTitle);
  browse_info.ulFlags := BIF_RETURNONLYFSDIRS;
  browse_info.hwndOwner := Application.Handle;
  if initialFolder <> '' then
    browse_info.lpfn := BrowseForFolderCallBack;
  find_context := SHBrowseForFolder(browse_info);
  if Assigned(find_context) then
  begin
    if SHGetPathFromIDList(find_context, folder) then
      result := folder
    else
      result := '';
    GlobalFreePtr(find_context);
  end
  else
    result := '';
end;

//procedure debug(s: string);
//begin
//{$IFDEF INFODEBUG}
//  TFormDebug.getInstance.DebugInfo(s);
//{$ENDIF}
//end;

end.