{$I ATViewerOptions.inc}

unit ATxUtils;

interface

uses
  Windows, Graphics, Controls, Forms;

function IsWindowsVista: Boolean;

procedure FixFormFont(AFont: TFont);
procedure FixImageList32Bit(ImageList: TImageList);
procedure SetFormStyle(Form: TForm; Value: Boolean);
function GetFormOnTop(Form: TForm): Boolean;
procedure SetFormOnTop(Form: TForm; Value: Boolean);

function FGetAppDataPath: WideString;                    //%AppData% path
function SExpandVars(const S: WideString): WideString;   //Expand env vars
function SExpanded(const S: WideString): Boolean;        //All env vars are already expanded
procedure SSetEnvVariable(const Name, Value: WideString);

function IsFilenameRemote(const fn: WideString): Boolean; //File on Network disk ( \\server\share\... )
function IsFilenameFixed(const fn: WideString): Boolean; //File on Fixed disk (C: D:..)
procedure SDecodeSearchW(var S: WideString);             //Prepare string for search: replace \n \r \0..

function FFileWriteStringA(const AFileName: WideString; const S: AnsiString): Boolean;
function FFileWriteStringW(const AFileName: WideString; const S: WideString): Boolean;
function FNumberName(const FN: WideString): WideString; //Generate number name by mask 'File%d.ext'
function FClipName(const Ext: string): WideString;      //Clipboard file name (in %Temp%)
function FPasteToFile: WideString;                      //Pastes clipboard to FClipName

const
  WM_XBUTTONDOWN   = $020B;
  WM_XBUTTONUP     = $020C;
  WM_XBUTTONDBLCLK = $020D;


implementation

uses
  SysUtils,
  Classes, Consts, CommCtrl, ATxFProc, ATxSProc,
  TntClasses, Clipbrd, TntClipbrd,
  {$ifdef PNG}
  PngImage,
  {$endif}
  ATViewerMsg, ATxMsgProc;

//--------------------------------------------------------
function IsWindowsVista: Boolean;
begin
  Result:=
    (Win32Platform = VER_PLATFORM_WIN32_NT) and
    (Win32MajorVersion >= 6);
end;

//--------------------------------------------------------
{
Windows XP icons in Delphi
I want to display Windows XP compatible icons on tool bars in my Delphi application. How do I do that? 
http://discuss.joelonsoftware.com/default.asp?joel.3.8105.4
}
procedure FixImageList32Bit(ImageList: TImageList);
const
  Mask: array[Boolean] of Longint = (0, ILC_MASK);
var
  TempList: TImageList;
begin
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and Assigned(ImageList) then
  begin
    TempList := TImageList.Create(nil);
    try
      TempList.Assign(ImageList);
      with ImageList do
      begin
        Handle := ImageList_Create(Width, Height, ILC_COLOR32 or Mask[Masked],
          0, AllocBy);
        if not HandleAllocated then
          raise EInvalidOperation.Create(SInvalidImageList);
      end;

      Imagelist.AddImages(TempList);
    finally
      FreeAndNil(TempList);
    end;
  end;
end;

//--------------------------------------------------------
{
Creating Windows Vista Ready Applications with Delphi
http://www.installationexcellence.com/articles/VistaWithDelphi/Index.html
}
procedure FixFormFont(AFont: TFont);
var
  LogFont: TLogFont;
begin
  if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then
    AFont.Handle := CreateFontIndirect(LogFont)
  else
    AFont.Handle := GetStockObject(DEFAULT_GUI_FONT);
end;

//--------------------------------------------------------
type
  TSHGetSpecialFolderPathA = function(hwndOwner: HWND; lpszPath: PAnsiChar;
    nFolder: Integer; fCreate: BOOL): BOOL; stdcall;
  TSHGetSpecialFolderPathW = function(hwndOwner: HWND; lpszPath: PWideChar;
    nFolder: Integer; fCreate: BOOL): BOOL; stdcall;

const
  sAppData = '%AppData%';
  CSIDL_APPDATA = $001a;

function FGetAppDataPathA: string;
var
  Handle: THandle;
  Func: TSHGetSpecialFolderPathA;
  Buffer: array[0..MAX_PATH-1] of char;
begin
  Result:= '';

  Handle := GetModuleHandle(kernel32);
  if Handle <> 0 then
    begin
    Func:= GetProcAddress(Handle, 'SHGetSpecialFolderPathA');
    if Assigned(Func) then
      begin
      if Func(0, Buffer, CSIDL_APPDATA, true) then
        Result:= Buffer;
      end;
    end;

  if Result = '' then
    Result:= SExpandVars(sAppData);
end;

function FGetAppDataPath: WideString;
begin
  Result:= FGetAppDataPathA;
end;

//--------------------------------------------------------
function SExpandVars(const S: WideString): WideString;
const
  BufSize = 4 * 1024;
var
  BufferA: array[0 .. BufSize - 1] of AnsiChar;
  BufferW: array[0 .. BufSize - 1] of WideChar;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    FillChar(BufferW, SizeOf(BufferW), 0);
    ExpandEnvironmentStringsW(PWChar(S), BufferW, BufSize);
    Result := WideString(BufferW);
  end
  else
  begin
    FillChar(BufferA, SizeOf(BufferA), 0);
    ExpandEnvironmentStringsA(PChar(AnsiString(S)), BufferA, BufSize);
    Result := AnsiString(BufferA);
  end;
end;

function SExpanded(const S: WideString): Boolean;
begin
  Result := Pos('%', S) = 0;
end;

procedure SSetEnvVariable(const Name, Value: WideString);
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    SetEnvironmentVariableW(PWChar(Name), PWChar(Value))
  else
    SetEnvironmentVariableA(PChar(AnsiString(Name)), PChar(AnsiString(Value)));
end;

//--------------------------------------------------------
procedure SDecodeSearchW(var S: WideString);
const
  DecodeRec: array[1..5] of TStringDecodeRec =
    ((SFrom: '\n'; STo: #13),
     (SFrom: '\r'; STo: #10),
     (SFrom: '\t'; STo: #9),
     (SFrom: '\\'; STo: '\'),
     (SFrom: '\0'; STo: #0));
begin
  S := SDecodeW(S, DecodeRec);
end;

//--------------------------------------------------------
function IsFilenameRemote(const fn: WideString): Boolean;
begin
  Result := Copy(fn, 1, 2) = '\\';
end;

function IsFilenameFixed(const fn: WideString): Boolean;
var
  Dir: AnsiString;
begin
  Result := false;
  if Pos(':\', fn) = 2 then
  begin
    Dir:= Copy(fn, 1, 3);
    Result:= GetDriveType(PChar(Dir)) = DRIVE_FIXED;
  end;
end;

//--------------------------------------------------------
procedure SetFormStyle(Form: TForm; Value: Boolean);
const
  cNormalStyles = WS_BORDER or WS_DLGFRAME or WS_CAPTION or WS_THICKFRAME;
begin
  with Form do
  begin
    if Value then
      SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) or cNormalStyles)
    else
      SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and not cNormalStyles);

    SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOSIZE or SWP_NOMOVE or SWP_FRAMECHANGED);
  end;
end;

function GetFormOnTop(Form: TForm): Boolean;
begin
  with Form do
    Result:= (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0;
end;

procedure SetFormOnTop(Form: TForm; Value: Boolean);
const
  cTopMost: array[Boolean] of DWORD = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
  with Form do
    SetWindowPos(Handle, cTopMost[Value], 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or SWP_NOOWNERZORDER);
end;

//--------------------------------------------------------
function FFileWriteStringA(const AFileName: WideString; const S: AnsiString): Boolean;
begin
  if S = '' then
    begin Result := False; Exit end;

  try
    with TTntFileStream.Create(AFileName, fmCreate) do
      try
        WriteBuffer(S[1], Length(S));
        Result := True;
      finally
        Free;
      end;
  except
    Result := False;
  end;
end;

function FFileWriteStringW(const AFileName: WideString; const S: WideString): Boolean;
const
  Sig: WideChar = #$FEFF;
begin
  if S = '' then
    begin Result := False; Exit end;

  try
    with TTntFileStream.Create(AFileName, fmCreate) do
      try
        if S[1] <> Sig then
          WriteBuffer(Sig, 2);
        WriteBuffer(S[1], Length(S) * 2);
        Result := True;
      finally
        Free;
      end;
  except
    Result := False;
  end;
end;


//FN must contain '%d' mask
function FNumberName(const FN: WideString): WideString;
var
  N: Integer;
begin
  N := 0;
  repeat
    Inc(N);
    Result := SFormatWD(FN, [N]);
  until not IsFileExist(Result);
end;

function FTempPath: string;
var
  buf: array[0 .. MAX_PATH-1] of char;
begin
  FillChar(buf, SizeOf(buf), 0);
  GetTempPath(SizeOf(buf), buf);
  Result := buf;
end;


function FClipName(const Ext: string): WideString;
const
  cName = 'Clipboard';
begin
  Result := FTempPath + cName + Ext;
end;


function FPasteToFile: WideString;
var
  b: TBitmap;
  {$ifdef PNG}
  p: TPngObject;
  {$endif}
  //m: TMetafile;
  SA: AnsiString;
  SW: WideString;
begin
  Result := '';

  try
    if Clipboard.HasFormat(CF_BITMAP) then
    {$ifdef PNG}
    begin
      b := TBitmap.Create;
      p := TPngObject.Create;
      try
        b.Assign(Clipboard);
        p.Assign(b);
        Result := FClipName('.png');
        p.SaveToFile(Result);
      finally
        b.Free;
        p.Free;
      end;
    end
    {$else}
    begin
      b := TBitmap.Create;
      try
        b.Assign(Clipboard);
        Result := FClipName('.bmp');
        b.SaveToFile(Result);
      finally
        b.Free;
      end;
    end
    {$endif}
    (*
    else
    if Clipboard.HasFormat(CF_METAFILEPICT) then
    begin
      m := TMetafile.Create;
      try
        m.Assign(Clipboard);
        Result := FClipName('.wmf');
        m.SaveToFile(Result);
      finally
        m.Free;
      end;
    end
    *)
    else
    if Clipboard.HasFormat(CF_UNICODETEXT) then
    begin
      SW := TntClipboard.AsWideText;
      Result := FClipName('.txt');
      if not FFileWriteStringW(Result, SW) then
        raise Exception.Create('');
    end
    else
    if Clipboard.HasFormat(CF_TEXT) then
    begin
      SA := Clipboard.AsText;
      Result := FClipName('.txt');
      if not FFileWriteStringA(Result, SA) then
        raise Exception.Create('');
    end
    else
      MsgWarning(MsgString(127));
  except
    MsgError(MsgString(128));
    Result := '';
  end;
end;


end.
