toolbox.pas

delphi框架

unit toolBox;
{**********************************************************************}
{ Copyright 2005 Reserved by Eazisoft.com                              }
{ File name: toolBox.pas                                               }
{ Author: Larry Le                                                     }
{ Description: This unit contains a set tool functions                 }
{                                                                      }
{ History:                                                             }
{ - 1.1, 19 DEC 2005                                                   }
{   add 4 functions,reboot,shutdown,killprocess and terminate          }
{ - 1.0, 04 Mar 2005                                                   }
{                                                                      }
{ Email: [e-mail]                                           }
{                                                                      }
{ The contents of this file are subject to the Mozilla Public License  }
{ Version 1.1 (the "License"); you may not use this file except in     }
{ compliance with the License. You may obtain a copy of the License at }
{ http://www.mozilla.org/MPL/                                          }
{                                                                      }
{ Software distributed under the License is distributed on an "AS IS"  }
{ basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See  }
{ the License for the specific language governing rights and           }
{ limitations under the License.                                       }
{                                                                      }
{ The Original Code is written in Delphi.                              }
{                                                                      }
{ The Initial Developer of the Original Code is Larry Le.              }
{ Copyright (C) eazisoft.com. All Rights Reserved.                     }
{                                                                      }
{**********************************************************************}


interface
uses Winsock,
  SysUtils, Contnrs, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  wininet, shellAPI, windows, jpeg, extctrls, Forms, Dialogs, StdCtrls,
  inifiles, ShDocVw, registry, CopyfileForm, MMSystem, shlobj;

const
  MaxPath = 255;
  MainTitle = '';
  strPrompt = 'Eazisoft';

const
  EWX_FORCE = 4; //Close all programs and switch to another user
  EWX_LOGOFF = 0; //Exit to MS-DOS mode
  EWX_REBOOT = 2; //REBOOT
  EWX_SHUTDOWN = 1; //Shut down

var
  lg_StartFolder: string;
  HomeURL: OleVariant;
  GlobalID: integer = 0;

//procedure debug(s: string);
//Check Web browser online or not
function OnLine: boolean;
procedure BMP2JPG(bmpfile: string; jpgfile: string);
procedure showInfo(s: string);
function showInfo2(s: string): Boolean;
procedure showWarning(s: string);
procedure showError(s: string);
function showConfirm(s: string): Boolean;

//is there some numbers in the given string,return true
function isAllNumber(s: string): Boolean;
//give a title,return the window handle,if not found return 0
function getWindowHandle(title: string): HWND;

function WinExecAndWait32(FileName: string; Visibility: integer): DWORD;
function WinExecAndNotWait32(ComLine: string; FWinStyle: integer): THandle;

function isProgramRunning(hdl: THandle): boolean;

function getIniStringValue(AFile, ASection, AKey, ADefaultValue: string):
  string;
//Close all windows contain the title
procedure CloseAllSubApp(FirstHWND: HWND; title: string);
procedure CloseApp(apphandle: HWND);

//Check the application with the given title running or not
function isAppRunning(appTitle: string): Boolean;
//set IE work online
function setWebBrowserOnLine: Boolean;
//no script debug,
function setNoScriptDebug: Boolean;
//local web not use the proxy
function setLocalWebNotUserProx: Boolean;
//Get IP
function getMyIP: string;
//Get First IP
function getFirstLocalIP: string;
//Get host name of my computer
function getMyHostName: string;
function startWith(s, search: string): Boolean;
//run after windows startup
function StartUpMyProgram(const AKEY: string = ''; AExename: string = ''): boolean;
//undo run after windows startup
function UnStartUpMyProgram(const AKEY: string = ''): boolean;
function GetTempDirectory: string;
function GetExecutePath: string;

function BrowseForFolder(const browseTitle: string; const initialFolder: string = ''): string;
function newMutex(const AMutesID: string = 'eazisoft'): THandle;
function ParamInCommandline(APAram: string): boolean;
function getSystemPath: string;
function isHung(theWindow: HWnd; timeOut: Longint): Boolean;
function ProgramNotRunning(WHandle: THandle): Boolean;
function ChangeSystemDateTime(dtNeeded: TDateTime): Boolean;

procedure ShowBlankPage(WebBrowser: TWebBrowser);
procedure freeMutex(AMutexHandle: THandle);
procedure FileCopy(const sourcefilename, targetfilename: string);
procedure SetMediaAudioOff(DeviceID: word);
procedure SetMediaAudioOn(DeviceID: word);
procedure terminate;
procedure KillProcess(hWindowHandle: HWND);
//
 // show chm help
 //
function HtmlHelpA(hwndcaller: Longint; lpHelpFile: string; wCommand: Longint;
  dwData: string): HWND; stdcall; external 'hhctrl.ocx'

procedure showHelpTopic(AHelpFile: string; topic: string);

function generateID: Integer;

procedure openWeb(AnUrl: string);

function extractValue(AParameter: string): string;
function outPutStrings(AList: TStrings): string;
function ShutDownWindows(Flags: Byte): Boolean;
procedure HideTaskbar;
procedure ShowTaskbar;
procedure AdjustToken;
procedure reboot;
procedure shutdown;


implementation

function ShutDownWindows(Flags: Byte): Boolean;
begin
  Result := ExitWindowsEx(Flags, 0)
end;

function outPutStrings(AList: TStrings): string;
var
  i: integer;
begin
  result := '';
  for i := 0 to ALIst.Count - 1 do
  begin
    result := result + '<li>' + AList[i] + '</li>';
  end;
  if result <> '' then
    result := '<ul>' + result + '</ul>';
end;

function extractValue(AParameter: string): string;
var
  i: integer;
begin
  i := pos('=', AParameter) + 1;
  if i > 0 then
    result := copy(AParameter, i, length(AParameter));
end;


procedure showHelpTopic(AHelpFile: string; topic: string);
begin
  if not FileExists(AHelpFile) then
  begin
    ShowInfo('Sorry,' + AHelpFile + ' doesn"t exists!');
    exit;
  end;

  HtmlHelpA(Application.Handle, Pchar(AHelpFile), 0, topic);
end;

procedure openWeb(AnUrl: string);
begin
  Shellexecute(application.handle, nil, pchar(AnURL), nil, nil,
    sw_shownormal);
end;

// see a program runing or not，if yes return true;

function isProgramRunning(hdl: THandle): Boolean;
var
  FAppState: cardinal;
begin
  result := (GetExitCodeProcess(hdl, FAppState)) and (FAppState = STILL_ACTIVE);
end;

procedure showInfo(s: string);
begin
  application.MessageBox(pchar(s), 'Information', MB_OK + MB_ICONINFORMATION);
end;

procedure showWarning(s: string);
begin
  application.MessageBox(pchar(s), 'Warning', MB_OK + MB_ICONWARNING);
end;

procedure showError(s: string);
begin
  application.MessageBox(pchar(s), 'Warning', MB_OK + MB_ICONERROR);
end;

function showConfirm(s: string): Boolean;
begin
  result := application.MessageBox(pchar(s), 'Confirm', MB_YESNO +
    MB_ICONQUESTION) = ID_YES;
end;

function showinfo2(s: string): Boolean;
begin
  result := application.MessageBox(pchar(s), 'Confirm', MB_OKCANCEL +
    MB_ICONINFORMATION) = ID_OK;
end;


//
 // run a program and wait it exit
 //

function WinExecAndWait32(FileName: string; Visibility: integer): DWORD;
var
  zAppName: array[0..512] of char;
  zCurDir: array[0..255] of char;
  WorkDir: string;
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
begin
  StrPCopy(zAppName, FileName);
  GetDir(0, WorkDir);
  StrPCopy(zCurDir, WorkDir);
  FillChar(StartupInfo, Sizeof(StartupInfo), #0);
  StartupInfo.cb := Sizeof(StartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := Visibility;
  if not CreateProcess(
    nil,
    zAppName, { pointer to command line string }
    nil, { pointer to process security attributes }
    nil, { pointer to thread security attributes }
    false, { handle inheritance flag }
    CREATE_NEW_CONSOLE or { creation flags }
    NORMAL_PRIORITY_CLASS,
    nil, { pointer to new environment block }
    nil, { pointer to current directory name }
    StartupInfo, { pointer to STARTUPINFO }
    ProcessInfo { pointer to PROCESS_INF }
    ) then
    Result := $FFFFFFFF
  else
  begin
    WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
    GetExitCodeProcess(ProcessInfo.hProcess, Result);
  end;
end;

//
 // is eveyting in the given string are numbers?，
 // true:YEs false:no
 //

function isAllNumber(s: string): Boolean;
var
  i: integer;
begin
  if (length(trim(s)) <= 0) then
  begin
    result := false;
    exit;
  end;
  for i := 1 to length(s) do
  begin
    if s[i] = #0 then
      break;
    if (s[i] < '0') or (s[i] > '9') then
    begin
      result := false;
      exit;
    end;
  end;
  result := i > 1;
end;

//
 // run an external application and return the handle
 // if not succeed return 0
 // this function work under W95,W98,NT40 W2000/XP
 //

function WinExecAndNotWait32(ComLine: string; FWinStyle: integer): THandle;
var
  lpAppName: pchar;
  //  lpTitle: Pchar;
  StartInfo: TStartupInfo;
  FProcessInfo: TProcessInformation;
begin
  if ((Length(ComLine) + 2) > 255) then
  begin
    showInfo('Command Line Too Long!');
    Result := 0;
    exit;
  end;

  GetMem(lpAppName, MaxPath);
  StrPCopy(lpAppName, ComLine);
  StartInfo.cb := sizeof(TStartupInfo);
  StartInfo.lpReserved := nil;
  StartInfo.lpDesktop := nil;
  StartInfo.lpTitle := nil; //lpTitle;
  StartInfo.dwFillAttribute := 0;
  StartInfo.cbReserved2 := 0;
  StartInfo.lpReserved2 := nil;
  //这个参数控制Create Window形态
  //STARTF_USESHOWWINDOW 指定这个标志位，指示用ShowWindow的参数建立窗口
  StartInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartInfo.wShowWindow := FWinStyle;

  //Clear ProcessInfo Structure
  FProcessInfo.hProcess := 0;
  FProcessInfo.hThread := 0;
  FProcessInfo.dwProcessId := 0;
  FProcessInfo.dwThreadId := 0;

  //Create process
  if CreateProcess(nil,
    lpAppName,
    nil,
    nil,
    False,
    0,
    nil,
    nil,
    StartInfo,
    FProcessInfo) then
  begin
    result := OpenProcess(PROCESS_ALL_ACCESS, False, FProcessInfo.dwProcessId);
  end
  else //false Create Process;
  begin
    result := 0;
    //ShowInfo('Run application failed!');
  end;

  FreeMem(lpAppName);
  //  FreeMem(lpTitle);
end;

//
 // get the first IP of my host
 //

function getFirstLocalIP: 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);
  if pptr^[0] <> nil then
    result := StrPas(inet_ntoa(pptr^[0]^));
  WSACleanup;
end;

function getIniStringValue(AFile, ASection, AKey, ADefaultValue: string):
  string;
begin
  if not fileExists(Afile) then
  begin
    result := ADefaultValue;
    exit;
  end;
  with TIniFile.Create(AFile) do
  begin
    result := readString(ASection, AKey, ADefaultValue);
    free;
  end;
end;

//
 // close all windows with title
 //

procedure CloseAllSubApp(FirstHWND: HWND; title: string);
var
  Found: HWND;
  Hold: string;
  ZAppName: array[0..127] of char;
begin
  Hold := Application.Title;
  Found := GetWindow(firstHWND, GW_HWNDFIRST);
  while found <> 0 do
  begin
    getWIndowText(Found, zAppname, 127);
    hold := trim(zAppName);
    if (hold <> '') and
      (pos(lowercase(title), lowercase(hold)) > 0) then
    begin
      sendMessage(found, WM_CLOSE, 0, 0);
      //closeWIndow(found);
      //DestroyWindow(Found);
    end;
    Found := GetWindow(Found, GW_HWNDNExt);
  end;
end;

procedure CloseApp(apphandle: HWND);
begin
  sendMessage(apphandle, WM_CLOSE, 0, 0);
end;


function getWindowHandle(title: string): HWND;
var
  Found, firstHWND: HWND;
  Hold: string;
  ZAppName: array[0..127] of char;
begin
  result := 0;
  Hold := Application.Title;
  firstHWND := application.MainForm.Handle;

  Found := GetWindow(firstHWND, GW_HWNDFIRST);
  while found <> 0 do
  begin
    getWIndowText(Found, zAppname, 127);
    hold := trim(zAppName);
    if (hold <> '') and (pos(lowercase(title), lowercase(hold)) > 0) then
    begin
      result := found;
      break;
      exit;
    end;
    Found := GetWindow(Found, GW_HWNDNExt);
  end;
end;

//
 // 检测程序是否已经运行
 //

function isAppRunning(appTitle: string): Boolean;
var
  Found: HWND;
  Hold: string;
  ZAppName: array[0..127] of char;
 // count: Integer;
begin
//  count := 0;
  result := false;
  Found := GetWindow(application.MainForm.Handle, GW_HWNDFIRST);
  while found <> 0 do
  begin
    getWIndowText(Found, zAppname, 127);
    hold := trim(zAppName);
    if (hold <> '') and
      (lowercase(appTitle) = lowercase(hold)) then
    begin
      //postMessage(found, WM_CLOSE, 0, 0);
     // inc(count);
     // if count > 2 then
      begin
        result := true;
        exit;
      end;
    end;
    Found := GetWindow(Found, GW_HWNDNExt);
  end;
end;

//
 // set your IE OnLine
 //

function setWebBrowserOnLine: 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.WriteInteger('GlobalUserOffline', 0);
      reg.CloseKey
    end
    else
      result := false;
  except
    result := false;
  end;
  if assigned(reg) then
    reg.Free;
end;

//
 // 禁止教本调试
 //

function setNoScriptDebug: Boolean;
var
  reg: TRegistry;
begin
  result := true;
  reg := TRegistry.Create(KEY_ALL_ACCESS);
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;