jvfunctions.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
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/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvFunctions.PAS, released on 2001-02-28.

The Initial Developer of the Original Code is S閎astien Buysse [sbuysse att buypin dott com]
Portions created by S閎astien Buysse are Copyright (C) 2001 S閎astien Buysse.
All Rights Reserved.

Contributor(s):
Michael Beck [mbeck att bigfoot dott com].
Anthony Steele [asteele att iafrica dott com]
Peter Th鰎nqvist [peter3 att users dott sourceforge dott net]
cginzel [[e-mail]]
Remko Bonte

Last Modified: 2003-02-19

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}

{$I JVCL.INC}

unit JvFunctions;

interface
uses
  Windows, Graphics, Classes, Messages, Controls,
  ComCtrls, SysUtils, ShellApi, ImgList,
  JvTypes;

{$IFNDEF COMPILER6_UP}
type
  EOSError = class(EWin32Error);
{$ENDIF}

type
  TWallpaperStyle = (wpTile, wpCenter, wpStretch);
  TJvWallpaperStyle = TWallpaperStyle;
  PRGBArray = ^TRGBArray;
  TRGBArray = array [0..MaxPixelCount - 1] of TRGBTriple;

// Transform an icon to a bitmap
function IconToBitmap(Ico: HICON): TBitmap;
// Transform an icon to a bitmap using an image list
function IconToBitmap2(Ico: HICON; Size: Integer = 32; TransparentColor: TColor = clNone): TBitmap;
function IconToBitmap3(Ico: HICON; Size: Integer = 32; TransparentColor: TColor = clNone): TBitmap;

//Open an object with the shell (url or something like that)
function OpenObject(Value: PChar): Boolean; overload;
function OpenObject(Value: string): Boolean; overload;

//Raise the last Exception
procedure RaiseLastWin32; overload;
procedure RaiseLastWin32(Text: string); overload;
//Raise the last Exception with a small comment from your part

//Same as linux function ;)
procedure PError(Text: string);

//Return the maximum of three integers
function GetMax(I, J, K: Integer): Integer;

//Return the minimum of three integers
function GetMin(I, J, K: Integer): Integer;

//Convert RGB Values to HSV
procedure RGBToHSV(r, g, b: Integer; var h, s, v: Integer);

{ GetFileVersion returns the most significant 32 bits of a file's binary
  version number. Typically, this includes the major and minor version placed
  together in one 32-bit Integer. It generally does not include the release
  or build numbers. It returns 0 if it failed. }
function GetFileVersion(const AFilename: string): Cardinal;
{$EXTERNALSYM GetFileVersion}

//Get version of Shell.dll
function GetShellVersion: Cardinal;
{$EXTERNALSYM GetShellVersion}

// set the background wallpaper (two versions)
procedure SetWallpaper(Path: string); overload;
procedure SetWallpaper(Path: string; Style: TJvWallpaperStyle); overload;

// screen capture functions
function CaptureScreen: TBitmap; overload;
function CaptureScreen(Rec: TRect): TBitmap; overload;

// CD functions
procedure OpenCdDrive;
procedure CloseCdDrive;

// bitmap manipulation functions
// NOTE: returned bitmap must be freed by caller!
// get red channel bitmap
function GetRBitmap(Value: TBitmap): TBitmap;
// get green channel bitmap
function GetGBitmap(Value: TBitmap): TBitmap;
// get blue channel bitmap
function GetBBitmap(Value: TBitmap): TBitmap;
// get monochrome bitmap
function GetMonochromeBitmap(Value: TBitmap): TBitmap;
// get hue bitmap (h part of hsv)
function GetHueBitmap(Value: TBitmap): TBitmap;
// get saturation bitmap (s part of hsv)
function GetSaturationBitmap(Value: TBitmap): TBitmap;
// get value bbitmap (v part of hsv)
function GetValueBitmap(Value: TBitmap): TBitmap;
// hides / shows the a forms caption area
procedure HideFormCaption(FormHandle: THandle; Hide: Boolean);
// launches the specified CPL file
// format: <Filename> [,@n] or [,,m] or [,@n,m]
// where @n = zero-based index of the applet to start (if there is more than one
// m is the zero-based index of the tab to display
procedure LaunchCpl(FileName: string);

{
  GetControlPanelApplets retrieves information about all control panel applets in a specified folder.
  APath is the Path to the folder to search and AMask is the filename mask (containing wildcards if necessary) to use.

  The information is returned in the Strings and Images lists according to the following rules:
   The Display Name and Path to the CPL file is returned in Strings with the following format:
     '<displayname>=<Path>'
   You can access the DisplayName by using the Strings.Names array and the Path by accessing the Strings.Values array
   Strings.Objects can contain either of two values depending on if Images is nil or not:
     * If Images is nil then Strings.Objects contains the image for the applet as a TBitmap. Note that the caller (you)
     is responsible for freeing the bitmaps in this case
     * If Images <> nil, then the Strings.Objects array contains the index of the image in the Images array for the selected item.
       To access and use the ImageIndex, typecast Strings.Objects to an int:
         Tmp.Name := Strings.Name[I];
         Tmp.ImageIndex := Integer(Strings.Objects[I]);
  The function returns True if any Control Panel Applets were found (i.e Strings.Count is > 0 when returning)
}

function GetControlPanelApplets(const APath, AMask: string; Strings: TStrings; Images: TImageList = nil): Boolean;
{ GetControlPanelApplet works like GetControlPanelApplets, with the difference that it only loads and searches one cpl file (according to AFilename).
  Note though, that some CPL's contains multiple applets, so the Strings and Images lists can contain multiple return values.
  The function returns True if any Control Panel Applets were found in AFilename (i.e if items were added to Strings)
}
function GetControlPanelApplet(const AFilename: string; Strings: TStrings; Images: TImageList = nil): Boolean;

// execute a program without waiting
procedure Exec(FileName, Parameters, Directory: string);
// execute a program and wait for it to finish
procedure ExecuteAndWait(FileName: string; Visibility: Integer);
// returns True if Drive is accessible
function DiskInDrive(Drive: Char): Boolean;
// returns True if this is the first instance of the program that is running
function FirstInstance(const ATitle: string): Boolean;
// restores a window based on it's classname and Caption. Either can be left empty
// to widen the search
procedure RestoreOtherInstance(MainFormClassName, MainFormCaption: string);

// manipulate the traybar and start button
procedure HideTraybar;
procedure ShowTraybar;
procedure ShowStartButton;
procedure HideStartButton;

// (rom) SC_MONITORPOWER is documented as Windows 95 only
// (rom) better do some testing
// set monitor functions
procedure MonitorOn;
procedure MonitorOff;
procedure LowPower;

// send a key to the window named AppName
function SendKey(AppName: string; Key: Char): Boolean;

// associates an extension to a specific program
procedure AssociateExtension(IconPath, ProgramName, Path, Extension: string);

function GetRecentDocs: TStringList;
procedure AddToRecentDocs(const Filename: string);
// create a region from a bitmap
function RegionFromBitmap(const Image: TBitmap): HRGN;

// returns a list of all windows currently visible, the Objects property is filled with their window handle
procedure GetVisibleWindows(List: Tstrings);

// JvComponentFunctions
{-----------------------------------------------------------------------------
Comments:
  Functions pulled out of MemoEx, used in MemoEx.pas and TypedEdit.pas

  This unit has low internal cohesion (ie it contains routines that do all kinds of stuff)
  Some are very good candidates for wider reuse
  some are quite specific to the controls
  and in a larger library this unit would be broken up

  I have tried to group related functions together
}

function CharIsMoney(const Ch: Char): Boolean;

{ there is a STrToIntDef provided by Delphi, but no "safe" versions of
  StrToFloat or StrToCurr }
function StrToFloatDef(const Str: string; Def: Extended): Extended;
function StrToCurrDef(const Str: string; Def: Currency): Currency;

{ GetChangedText works out the new text given the current cursor pos & the key pressed
  It is not very useful in other contexts,
  but it is in this unit as it is needed in both MemoEx and TypedEdit }
function GetChangedText(const Text: string; SelStart, SelLength: Integer; Key: Char): string;

function MakeYear4Digit(Year, Pivot: Integer): Integer;

function StrIsInteger(const S: string): Boolean;
function StrIsFloatMoney(const Ps: string): Boolean;
function StrIsDateTime(const Ps: string): Boolean;

function PreformatDateString(Ps: string): string;

function BooleanToInteger(const Pb: Boolean): Integer;
function StringToBoolean(const Ps: string): Boolean;

function SafeStrToDateTime(const Ps: string): TDateTime;
function SafeStrToDate(const Ps: string): TDateTime;
function SafeStrToTime(const Ps: string): TDateTime;

function StrDelete(const psSub, psMain: string): string;

{ listview functions }
function ConvertStates(const State: Integer): TItemStates;

function ChangeHasDeselect(const peOld, peNew: TItemStates): Boolean;
function ChangeHasSelect(const peOld, peNew: TItemStates): Boolean;

function ChangeHasDefocus(const peOld, peNew: TItemStates): Boolean;
function ChangeHasFocus(const peOld, peNew: TItemStates): Boolean;

function GetListItemColumn(const pcItem: TListItem; piIndex: Integer): string;

{ returns the sum of pc.Left, pc.Width and piSpace}
function ToRightOf(const pc: TControl; piSpace: Integer = 0): Integer;
{ sets the top of pc to be in the middle of pcParent }
procedure CenterHeight(const pc, pcParent: TControl);
{ returns the fractional value of pcValue}
function TimeOnly(pcValue: TDateTime): TTime;
{ returns the integral value of pcValue }
function DateOnly(pcValue: TDateTime): TDate;

type
  TdtKind = (dtkDateOnly, dtkTimeOnly, dtkDateTime);

const
  { TDateTime value used to signify Null value}
  NullEquivalentDate: TDateTime = 0.0;

function DateIsNull(const pdtValue: TDateTime; const pdtKind: TdtKind): Boolean;
// Replacement for Win32Check to avoid platform specific warnings in D6
function OSCheck(RetVal: Boolean): Boolean;

{ Shortens a fully qualified Path name so that it can be drawn with a specified length limit.
  Same as FileCtrl.MinimizeName in functionality (but not implementation). Included here to
  not be forced to use FileCtrl unnecessarily }
function MinimizeName(const Filename: string; Canvas: TCanvas; MaxLen: Integer): string;

{ RunDLL32 runs a function in a DLL using the utility rundll32.exe (on NT) or rundll.exe (on Win95/98)
 ModuleName is the name of the DLL to load, FuncName is the function to call and CmdLine is
 the command-line parameters (if any) to send to the function. Set WaitForCompletion to False to
 return immediately after the call.
 CmdShow should be one of the SW_SHOWXXXX constants and defaults SW_SHOWDEFAULT
 Return value:
 if WaitForCompletion is True, returns True if the wait didn't return WAIT_FAILED
 if WaitForCompletion is False, returns True if the process could be created
 To get information on why RunDLL32 might have failed, call GetLastError
 To get more info on what can actually be called using rundll32.exe, take a look at
 http://www.dx21.com/SCRIPTING/RUNDLL32/REFGUIDE.ASP?NTI=4&SI=6
}
type
  // the signature of procedures in DLL's that can be called using rundll32.exe
  TRunDLL32Proc = procedure(Handle: HWND; hInstance: HMODULE; CmdLine: PChar; CmdShow: Integer); stdcall;

function RunDLL32(const ModuleName, FuncName, CmdLine: string; WaitForCompletion: Boolean; CmdShow: Integer =
  SW_SHOWDEFAULT): Boolean;
{ RunDll32Internal does the same as RunDLL32 but does not use the RunDLL32.exe application to do it.
 Rather it loads the DLL, gets a pointer to the function in FuncName and calls it with the given parameters.
 Because of this behaviour, RunDll32Internal works slightly different from RunDLL32:
 * It doesn't return any value indicating success/failure
 * There is no WaitForCompletion parameter (but see comment below on how to circumvent this)
 * You must pass in a valid windows handle in Wnd. Note that if you pass 0, the call might fail, with no indication of why.
 * To simulate WaitForCompletion = False, pass the return value of GetDesktopWindow as the Wnd parameter,
 * To simulate WaitForCompletion = True, pass the handle of the calling window (f ex the form you are calling the procedure from)
 * If you try to call a function in a DLL that doesn't use the TRunDLL32Proc signature, your program
   might crash. Using the RunDLL32 function protects you from any problems with calling the wrong functions
   (a dialog is displayed if do something wrong)
 * RunDll32Internal is slightly faster but RunDLL32 is safer
}
procedure RunDll32Internal(Wnd: HWnd; const DLLName, FuncName, CmdLine: string; CmdShow: Integer = SW_SHOWDEFAULT);
{ GetDLLVersion loads DLLName, gets a pointer to the DLLVersion function and calls it, returning the major and minor version values
from the function. Returns False if the DLL couldn't be loaded or if GetDLLVersion couldn't be found. }
function GetDLLVersion(const DLLName: string; var pdwMajor, pdwMinor: Integer): Boolean;

{$IFNDEF COMPILER6_UP}
{ D5 compatibility functions }
procedure RaiseLastOSError;
function IncludeTrailingPathDelimiter(const APath: string): string;
function ExcludeTrailingPathDelimiter(const APath: string): string;
{$ENDIF}

implementation

uses
  Forms, Registry, ExtCtrls,
  {$IFDEF COMPILER6_UP}
  Types,
  {$ENDIF}
  MMSystem,
  ShlObj, CommCtrl,
  JclSysInfo,
  JclStrings, JclGraphics;

resourcestring
  SWin32Error = 'Win32 Error.  Code: %d.'#10'%s';

const
  RC_ControlRegistry = 'Control Panel\Desktop';
  RC_WallpaperStyle = 'WallpaperStyle';
  RC_WallpaperRegistry = 'Wallpaper';
  RC_TileWallpaper = 'TileWallpaper';
  RC_OpenCDDrive = 'set cdaudio door open wait';
  RC_CloseCDDrive = 'set cdaudio door closed wait';
  RC_RunCpl = 'rundll32.exe shell32,Control_RunDLL ';
  RC_ShellName = 'Shell_TrayWnd';
  RC_DefaultIcon = 'DefaultIcon';

var
  ShellVersion: Integer;

{$IFNDEF COMPILER6_UP}

{ (rb) Duplicate of JclBase.RaiseLastOSError }

procedure RaiseLastOSError;
begin
  RaiseLastWin32Error;
end;

function IncludeTrailingPathDelimiter(const APath: string): string;
begin
  if (Length(APath) > 0) and (APath[Length(APath)] <> '\') then
    Result := APath + '\'
  else
    Result := APath;
end;

function ExcludeTrailingPathDelimiter(const APath: string): string;
begin
  Result := APath;
  while (Length(Result) > 0) and (Result[Length(Result)] = '\') do
    SetLength(Result, Length(Result) - 1);
end;

{$ENDIF}

function IconToBitmap(Ico: HICON): TBitmap;
var
  Pic: TPicture;
begin
  Pic := TPicture.Create;
  Pic.Icon.Handle := Ico;
  Result := TBitmap.Create;
  Result.Height := Pic.Icon.Height;
  Result.Width := Pic.Icon.Width;
  Result.Canvas.Draw(0, 0, Pic.Icon);
  Pic.Free;
end;

function IconToBitmap2(Ico: HICON; Size: Integer = 32; TransparentColor: TColor = clNone): TBitmap;
begin
  // (p3) this seems to generate "better" bitmaps...
  with TImageList.CreateSize(Size, Size) do
  try
    Masked := True;
    BkColor := TransparentColor;
    ImageList_AddIcon(Handle, Ico);
    Result := TBitmap.Create;
    Result.PixelFormat := pf24bit;
    if TransparentColor <> clNone then
      Result.TransparentColor := TransparentColor;
    Result.Transparent := TransparentColor <> clNone;
    GetBitmap(0, Result);
  finally
    Free;
  end;
end;

function IconToBitmap3(Ico: HICON; Size: Integer = 32; TransparentColor: TColor = clNone): TBitmap;
var
  Icon: TIcon;
  Tmp: TBitmap;
begin
  Icon := TIcon.Create;
  Tmp := TBitmap.Create;
  try
    Icon.Handle := CopyIcon(Ico);
    Result := TBitmap.Create;
    Result.Width := Icon.Width;
    Result.Height := Icon.Height;
    Result.PixelFormat := pf24bit;
    // fill the bitmap with the transparant color
    Result.Canvas.Brush.Color := TransparentColor;
    Result.Canvas.FillRect(Rect(0, 0, Result.Width, Result.Height));
    Result.Canvas.Draw(0, 0, Icon);
    Result.TransparentColor := TransparentColor;
    Tmp.Assign(Result);
    //    Result.Width := Size;
    //    Result.Height := Size;
    Result.Canvas.StretchDraw(Rect(0, 0, Result.Width, Result.Height), Tmp);
    Result.Transparent := True;
  finally
    Icon.Free;
    Tmp.Free;
  end;
end;

function OpenObject(Value: string): Boolean;
begin
  Result := OpenObject(PChar(Value));
end;

{ (rb) Duplicate of JvFunctions.Exec }

function OpenObject(Value: PChar): Boolean;
begin
  Result := ShellExecute(0, 'open', Value, nil, nil, SW_SHOWNORMAL) > HINSTANCE_ERROR;
end;

procedure RaiseLastWin32;
begin
  PError('');
end;

procedure RaiseLastWin32(Text: string);
begin
  PError(Text);
end;

procedure PError(Text: string);
var
  LastError: Integer;
  St: string;
begin
  LastError := GetLastError;
  if LastError <> 0 then
  begin
    St := Format(SWin32Error, [LastError, SysErrorMessage(LastError)]);
    if Text <> '' then
      St := Text + ':' + St;
    raise EOSError.Create(St);
  end;
end;

function GetMax(I, J, K: Integer): Integer;
begin
  if J > I then
    I := J;
  if K > I then
    I := K;
  Result := I;
end;

function GetMin(I, J, K: Integer): Integer;
begin
  if J < I then
    I := J;