jvfunctions.pas

East make Tray Icon in delphi

    H := FindNext(F);
  end;
  SysUtils.FindClose(F);
  Result := Strings.Count > 0;
end;

procedure Exec(FileName, Parameters, Directory: string);
var
  Operation: string;
begin
  Operation := 'open';
  ShellExecute(GetForegroundWindow, PChar(Operation), PChar(FileName), PChar(Parameters), PChar(Directory),
    SW_SHOWNORMAL);
end;

{ (rb) Duplicate of JclMiscel.WinExec32AndWait }

procedure ExecuteAndWait(FileName: string; Visibility: Integer);
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, nil, nil, False, Create_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,
    nil, nil, StartupInfo, ProcessInfo) then
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
end;

{ (rb) Duplicate of JclFileUtils.DiskInDrive }

function DiskInDrive(Drive: Char): Boolean;
var
  DrvNum: Byte;
  EMode: Word;
begin
  DrvNum := Ord(Drive);
  if DrvNum >= Ord('a') then
    Dec(DrvNum, $20);
  EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    Result := DiskSize(DrvNum - $40) <> -1;
  finally
    SetErrorMode(EMode);
  end;
end;

function FirstInstance(const ATitle: string): Boolean;
var
  Mutex: THandle;
begin
  Mutex := CreateMutex(nil, False, PChar(ATitle));
  try
    Result := (Mutex <> 0) and (GetLastError <> ERROR_ALREADY_EXISTS);
  finally
    ReleaseMutex(Mutex);
  end;
end;

procedure RestoreOtherInstance(MainFormClassName, MainFormCaption: string);
var
  OtherWnd, OwnerWnd: HWND;
begin
  OtherWnd := FindWindow(PChar(MainFormClassName), PChar(MainFormCaption));
  ShowWindow(OtherWnd, SW_SHOW); //in case the window was not visible before

  OwnerWnd := 0;
  if OtherWnd <> 0 then
    OwnerWnd := GetWindow(OtherWnd, GW_OWNER);

  if OwnerWnd <> 0 then
    OtherWnd := OwnerWnd;

  if OtherWnd <> 0 then
  begin
    { (rb) Use JvVCLUtils.SwitchToWindow }
    if IsIconic(OtherWnd) then
      ShowWindow(OtherWnd, SW_RESTORE);

    SetForegroundWindow(OtherWnd);
  end;
end;

procedure HideTraybar;
var
  Wnd: HWND;
begin
  Wnd := FindWindow(PChar(RC_ShellName), nil);
  ShowWindow(Wnd, SW_HIDE);
end;

procedure ShowTraybar;
var
  Wnd: HWND;
begin
  Wnd := FindWindow(PChar(RC_ShellName), nil);
  ShowWindow(Wnd, SW_SHOW);
end;

procedure HideStartBtn(Visible: Boolean);
var
  Tray, Child: HWND;
  C: array [0..127] of Char;
  S: string;
begin
  Tray := FindWindow(PChar(RC_ShellName), nil);
  Child := GetWindow(Tray, GW_CHILD);
  while Child <> 0 do
  begin
    if GetClassName(Child, C, SizeOf(C)) > 0 then
    begin
      S := StrPas(C);
      if UpperCase(S) = 'BUTTON' then
        if Visible then
          ShowWindow(Child, SW_SHOWNORMAL)
        else
          ShowWindow(Child, SW_HIDE);
    end;
    Child := GetWindow(Child, GW_HWNDNEXT);
  end;
end;

procedure ShowStartButton;
begin
  HideStartBtn(True);
end;

procedure HideStartButton;
begin
  HideStartBtn(False);
end;

procedure MonitorOn;
begin
  SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
end;

procedure MonitorOff;
begin
  SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, 2);
end;

procedure LowPower;
begin
  SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, 1);
end;

{$WARNINGS OFF}

procedure SendShift(H: HWND; Down: Boolean);
var
  vKey, ScanCode: Word;
  lParam: Longint;
begin
  vKey := VK_SHIFT;
  ScanCode := MapVirtualKey(vKey, 0);
  lParam := Longint(ScanCode) shl 16 or 1;
  if not Down then
    lParam := lParam or $C0000000;
  SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

procedure SendCtrl(H: HWND; Down: Boolean);
var
  vKey, ScanCode: Word;
  lParam: Longint;
begin
  vKey := VK_CONTROL;
  ScanCode := MapVirtualKey(vKey, 0);
  lParam := Longint(ScanCode) shl 16 or 1;
  if not Down then
    lParam := lParam or $C0000000;
  SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

function SendKey(AppName: string; Key: Char): Boolean;
var
  vKey, ScanCode: Word;
  lParam, ConvKey: Longint;
  Shift, Ctrl: Boolean;
  H: HWND;
begin
  H := FindWindow(PChar(AppName), nil);
  if H <> 0 then
  begin
    ConvKey := OemKeyScan(Ord(Key));
    Shift := (ConvKey and $00020000) <> 0;
    Ctrl := (ConvKey and $00040000) <> 0;
    ScanCode := ConvKey and $000000FF or $FF00;
    vKey := Ord(Key);
    lParam := Longint(ScanCode) shl 16 or 1;
    if Shift then
      SendShift(H, True);
    if Ctrl then
      SendCtrl(H, True);
    SendMessage(H, WM_KEYDOWN, vKey, lParam);
    SendMessage(H, WM_CHAR, vKey, lParam);
    lParam := lParam or $C0000000;
    SendMessage(H, WM_KEYUP, vKey, lParam);
    if Shift then
      SendShift(H, False);
    if Ctrl then
      SendCtrl(H, False);
    Result := True;
  end
  else
    Result := False;
end;

{$WARNINGS ON}

procedure RebuildIconCache;
var
  Dummy: DWORD;
begin
  SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, SPI_SETNONCLIENTMETRICS,
    Longint(PChar('WindowMetrics')), SMTO_NORMAL or SMTO_ABORTIFHUNG, 10000, Dummy);
end;

procedure AssociateFileExtension(IconPath, ProgramName, Path, Extension: string);
begin
  with TRegistry.Create do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey(ProgramName, True);
    WriteString('', ProgramName);
    if IconPath <> '' then
    begin
      OpenKey(RC_DefaultIcon, True);
      WriteString('', IconPath);
    end;
    CloseKey;
    OpenKey(ProgramName, True);
    OpenKey('shell', True);
    OpenKey('open', True);
    OpenKey('command', True);
    WriteString('', '"' + Path + '" "%1"');
    Free;
  end;
  with TRegistry.Create do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('.' + extension, True);
    WriteString('', ProgramName);
    Free;
  end;
  RebuildIconCache;
end;

procedure AssociateExtension(IconPath, ProgramName, Path, Extension: string);
begin
  AssociateFileExtension(IconPath, ProgramName, Path, Extension);
end;

function GetRecentDocs: TStringList;
var
  Path: string;
  t: TSearchRec;
  Res: Integer;
begin
  Result := TStringList.Create;
  Result.Clear;
  Path := INcludeTrailingPathDelimiter(GetRecentFolder);
  //search for all files
  Res := FindFirst(Path + '*.*', faAnyFile, t);
  try
    while Res = 0 do
    begin
      if (t.Name <> '.') and (t.Name <> '..') then
        Result.Add(Path + T.Name);
      Res := FindNext(t);
    end;
  finally
    FindClose(t);
  end;
end;

{ (rb) Duplicate of JvWinDialogs.AddToRecentDocs }

procedure AddToRecentDocs(const Filename: string);
begin
  SHAddToRecentDocs(SHARD_PATH, PChar(Filename));
end;

function RegionFromBitmap(const Image: TBitmap): HRGN;
begin
  Result := 0;
  if Assigned(Image) and not Image.Empty then
    Result := CreateRegionFromBitmap(Image, Image.Canvas.Pixels[0, 0], rmExclude);
end;

function EnumWindowsProc(Handle: THandle; lParam: TStrings): Boolean; stdcall;
var
  St: array [0..256] of Char;
  St2: string;
begin
  if IsWindowVisible(Handle) then
  begin
    GetWindowText(Handle, St, SizeOf(St));
    St2 := St;
    if St2 <> '' then
      with TStrings(lParam) do
        AddObject(St2, TObject(Handle));
  end;
  Result := True;
end;

procedure GetVisibleWindows(List: Tstrings);
begin
  List.BeginUpdate;
  try
    List.Clear;
    EnumWindows(@EnumWindowsProc, Integer(List));
  finally
    List.EndUpdate;
  end;
end;

// from JvComponentFunctions

function StrPosNoCase(const psSub, psMain: string): Integer;
begin
  Result := Pos(AnsiUpperCase(psSub), AnsiUpperCase(psMain));
end;

function StrRestOf(const Ps: string; const n: Integer): string;
begin
  Result := Copy(Ps, n, (Length(Ps) - n + 1));
end;

{!!!!!!!! use these cos the JCL one is badly broken }

{ Am using this one purely as an itnernal for StrReplace

 Replace part of a string with new text. iUpdatePos is the last update position
 i.e. the position the substr was found + the length of the replacement string + 1.
 Use 0 first time in }

function StrReplaceInstance(const psSource, psSearch, psReplace: string;
  var piUpdatePos: Integer; const pbCaseSens: Boolean): string;
var
  liIndex: Integer;
  lsCopy: string;
begin
  Result := psSource;
  if piUpdatePos >= Length(psSource) then
    Exit;
  if psSearch = '' then
    Exit;

  Result := StrLeft(psSource, piUpdatePos - 1);
  lsCopy := StrRestOf(psSource, piUpdatePos);

  if pbCaseSens then
    liIndex := Pos(psSearch, lsCopy)
  else
    liIndex := StrPosNoCase(psSearch, lsCopy);
  if liIndex = 0 then
  begin
    Result := psSource;
    piUpdatePos := Length(psSource) + 1;
    Exit;
  end;

  Result := Result + StrLeft(lsCopy, liIndex - 1);
  Result := Result + psReplace;
  piUpdatePos := Length(Result) + 1;
  Result := Result + StrRestOf(lsCopy, liIndex + Length(psSearch));
end;

function LStrReplace(const psSource, psSearch, psReplace: string;
  const pbCaseSens: Boolean): string;
var
  liUpdatePos: Integer;
begin
  liUpdatePos := 0;
  Result := psSource;
  while liUpdatePos < Length(Result) do
    Result := StrReplaceInstance(Result, psSearch, psReplace, liUpdatePos, pbCaseSens);
end;

{ if it's not a decimal point then it must be a digit, space or Currency symbol
  also always use $ for money }

function CharIsMoney(const Ch: Char): Boolean;
begin
  Result := CharIsDigit(Ch) or (Ch = AnsiSpace) or (Ch = '$') or (Ch = '-') or
    (Pos(Ch, CurrencyString) > 0);
end;

function StrToCurrDef(const Str: string; Def: Currency): Currency;
var
  lStr: string;
begin
  try
    lStr := StrStripNonNumberChars(Str);

    if lStr = '' then
      Result := Def
    else
      Result := StrToCurr(lstr);
  except
    Result := Def;
  end;
end;

function StrToFloatDef(const Str: string; Def: Extended): Extended;
var
  lStr: string;
begin
  lStr := StrStripNonNumberChars(Str);

  if lStr = '' then
    Result := Def
  else
  try
      { the string '-' fails StrToFloat, but it can be interpreted as 0  }
    if StrRight(lStr, 1) = '-' then
      lStr := lStr + '0';

      { a string that ends in a '.' such as '12.' fails StrToFloat,
       but as far as I am concerned, it may as well be interpreted as 12.0 }
    if StrRight(lStr, 1) = '.' then
      lStr := lStr + '0';

    Result := StrToFloat(lStr);
  except
    Result := Def;
  end;
end;

function GetChangedText(const Text: string; SelStart, SelLength: Integer; Key: Char): string;
begin
  { take the original text, replace what will be overwritten with new value }
  Result := Text;

  if SelLength > 0 then
    Delete(Result, SelStart + 1, SelLength);
  if Key <> #0 then
    Insert(Key, Result, SelStart + 1);
end;

{ "window" technique for years to translate 2 digits to 4 digits.
   The window is 100 years wide
   The windowsill year is the lower edge of the window
  A windowsill year of 1900 is equivalent to putting 1900 before every 2-digit year
 if piWindowsillYear is 1940, then 40 is interpreted as 1940, 00 as 2000 and 39 as 2039
 The system default is 1950
}
{ "window" technique for years to translate 2 digits to 4 digits.
   The window is 100 years wide
   The pivot year is the lower edge of the window
  A pivot year of 1900 is equivalent to putting 1900 before every 2-digit year
 if pivot is 1940, then 40 is interpreted as 1940, 00 as 2000 and 39 as 2039
 The system default is 1950

 Why the reimplementation?
 JclDatetime.Make4DigitYear will fail after 2100, this won't
 note that in this implementation pivot is a 4-digit year
 I have made it accept JclDatetime.Make4DigitYear's 2 digit pivot years.
 They are expanded by adding 1900.

 It is also better in that a valid 4-digit year will pass through unchanged,
 not fail an assertion.
}

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