{

   This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either
  version 2 of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
{$D-}
unit Ufunction;

interface

uses
  Windows, Forms, sysutils, ShellAPI, Graphics,
  comobj, ShlObj, CommCtrl, Classes, ActiveX;

  function GetModuleDir: string;
  function GetAppDirectory:string;
  function GetWindowsDir:string;
  function GetSystemImageList(Large: boolean): HImageList;
  function GetSystemPath(Folder: Integer): string;
  function GetIconIndex(const APath: string; Attrs: DWORD): integer;
  function GetIconIndex2(const APath: string; Attrs: DWORD): integer;
  procedure SplitString(str:string;var returnStr:TStringList;splitchar:char);
  function Get_FileSize(sFileToExamine: string):integer;
  function DateConvert(s:string):string;
  function AdvSelectDirectory(hOwn: HWND; const Caption: string; const Root: WideString;
    var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
    AllowCreateDirs: Boolean = True): Boolean;
  function ConvertSize(value:string):string;

  function HexToTColor(S : string): TColor;
  function ColorToHTML(AColor:TColor):string;
  function compactstring(s:widestring;size:integer):string;
  function makeuniqfilename(s:string):string;
  function ExecuteFile(filename:string; visible:boolean): Boolean;
  function GetVersion: string;
  function difftime(timestamp:tdatetime):integer;
  procedure DrawTransparentBitmap(DC: HDC; hBmp: HBITMAP; xStart, yStart: Integer;
     cTransparentColor: COLORREF);
  function IsActiveDeskTopOn: Boolean;
  function ChangeWallpaper(aFile: String): Boolean;

implementation

function GetAppDirectory:string;
begin
  result:=ExtractFilePath(Application.ExeName);
end;

function GetWindowsDir:string;
var
  Buf: array[0..MAX_PATH] of char;
begin
  windows.GetWindowsDirectory(Buf, MAX_PATH);
  result:=string(buf)+'\';
end;

function ConvertSize(value:string):string;
var
 s,d:double;
begin
try
  s:=strtofloat(value);
  if s > 1000000 then begin
     d := (s / 1000000);
     result:=formatfloat('##.#', d) + ' M';
  end else if s > 1000 then begin
     d := (s / 1000);
     result:=formatfloat('##.#', d) + ' Kb';
  end else begin
     result:=floattostr(s) + ' b';
  end;
except
  result:= '0 b';
end;
end;

function GetSystemPath(Folder: Integer): string;
var
  PIDL: PItemIDList;
  Path: LPSTR;
  AMalloc: IMalloc;
begin
  Path := StrAlloc(MAX_PATH);
  SHGetSpecialFolderLocation(Application.Handle, Folder, PIDL);
  if SHGetPathFromIDList(PIDL, Path) then
    Result := Path;
  SHGetMalloc(AMalloc);
  AMalloc.Free(PIDL);
  StrDispose(Path);
  if Result[length(Result)]<>'\' then Result:=Result+'\';
end;

procedure SplitString(str:string;var returnStr:TStringList;splitchar:char);
var
 p1:integer;
 y:string;
begin

 p1:=pos(splitchar,str);
 while p1>0 do
 begin
    y:=copy(str,1,p1-1);
    returnStr.Add(y);
    delete(str,1,p1);
    p1:=pos(splitchar,str);
 end;
 if str <> '' then returnStr.Add(str);

end;

function GetSystemImageList(Large: boolean): HImageList;
var
  SFI: TSHFileInfo;
begin
  // SHGetFileInfo puts the requested information in the SFI variable, but it
  // also can return the handle of the system image list.  We just pass an
  // empty file because we aren't interested in it, only the returned handle.
  if Large then
    Result := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
      SHGFI_SYSICONINDEX or SHGFI_LARGEICON)
  else
    Result := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
      SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
end;

function GetIconIndex(const APath: string; Attrs: DWORD): integer;
var
  SFI: TSHFileInfo;
begin
  if FileExists(APath) or DirectoryExists(APath) then
    // If the file or directory exists, just let Windows figure out it's attrs.
    SHGetFileInfo(PChar(APath), 0, SFI, SizeOf(TSHFileInfo),
      SHGFI_SYSICONINDEX)
  else
    // File doesn't exist, so Windows doesn't know what to do with it.  We have
    // to tell it by passing the attributes we want, and specifying the
    // SHGFI_USEFILEATTRIBUTES flag so that the function knows to use them.
    SHGetFileInfo(PChar(APath), Attrs, SFI, SizeOf(TSHFileInfo),
      SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
  Result := SFI.iIcon;
end;

function GetIconIndex2(const APath: string; Attrs: DWORD): integer;
var
  SFI: TSHFileInfo;
begin
    SHGetFileInfo(PChar(APath), Attrs, SFI, SizeOf(TSHFileInfo),
      SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
  Result := SFI.iIcon;
end;

function Get_FileSize(sFileToExamine: string):integer;
var
  FileHandle: THandle;
  FileSize: LongWord;
begin
  //a- Get file size
  FileHandle := CreateFile(PChar(sFileToExamine),
    GENERIC_READ,
    0, {exclusive}
    nil, {security}
    OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL,
    0);
  FileSize := GetFileSize(FileHandle, nil);
  Result := FileSize;
  CloseHandle(FileHandle);
end;

function DateConvert(s:string):string;
var
 s2:string;
 DateTime :TDatetime;
// FormatSettings:TFormatSettings;
begin

  s2:=copy(s,6,3);
  delete(s,6,3);
  delete(s2,1,1);
  if strtoint(s2)>80 then s2:='19'+s2
  else s2:='20'+s2;
  s:=s2+'-'+s;

//  GetLocaleFormatSettings(LOCALE_USER_DEFAULT, FormatSettings);
  DateTime:=StrToDateTime(s); //,FormatSettings);
  result:=sysutils.FormatDateTime('yyyy-mm-dd ampm h:nn',DateTime);

end;

function AdvSelectDirectory(hOwn: HWND; const Caption: string; const Root: WideString;
  var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
  AllowCreateDirs: Boolean = True): Boolean;
  // callback function that is called when the dialog has been initialized
  //or a new directory has been selected 

  // Callback-Funktion, die aufgerufen wird, wenn der Dialog initialisiert oder
  //ein neues Verzeichnis selektiert wurde 
  function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer; 
    stdcall; 
  var 
    PathName: array[0..MAX_PATH] of Char; 
  begin 
    case uMsg of 
      BFFM_INITIALIZED: SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
      // include the following comment into your code if you want to react on the 
      //event that is called when a new directory has been selected 
      // binde den folgenden Kommentar in deinen Code ein, wenn du auf das Ereignis 
      //reagieren willst, das aufgerufen wird, wenn ein neues Verzeichnis selektiert wurde 
      {BFFM_SELCHANGED: 
      begin 
        SHGetPathFromIDList(PItemIDList(lParam), @PathName); 
        // the directory "PathName" has been selected
        // das Verzeichnis "PathName" wurde selektiert
      end;} 
    end; 
    Result := 0; 
  end;
var
  WindowList: Pointer; 
  BrowseInfo: TBrowseInfo; 
  Buffer: PChar; 
  RootItemIDList, ItemIDList: PItemIDList; 
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder; 
  Eaten, Flags: LongWord; 
const 
  // necessary for some of the additional expansions
  // notwendig fur einige der zusatzlichen Erweiterungen 
  BIF_USENEWUI = $0040; 
  BIF_NOCREATEDIRS = $0200; 
begin 
  Result := False; 
  if not DirectoryExists(Directory) then
    Directory := ''; 
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); 
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin 
    Buffer := ShellMalloc.Alloc(MAX_PATH); 
    try 
      RootItemIDList := nil; 
      if Root <> '' then 
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(hOwn, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end; 
      OleInitialize(nil); 
      with BrowseInfo do 
      begin
        hwndOwner := hOwn;
        pidlRoot := RootItemIDList; 
        pszDisplayName := Buffer; 
        lpszTitle := PChar(Caption); 
        // defines how the dialog will appear:
        // legt fest, wie der Dialog erscheint: 
        ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI or 
          BIF_EDITBOX * Ord(EditBox) or BIF_BROWSEINCLUDEFILES * Ord(ShowFiles) or 
          BIF_NOCREATEDIRS * Ord(not AllowCreateDirs); 
        lpfn    := @SelectDirCB;
        if Directory <> '' then 
          lParam := Integer(PChar(Directory)); 
      end; 
      WindowList := DisableTaskWindows(0); 
      try 
        ItemIDList := ShBrowseForFolder(BrowseInfo); 
      finally 
        EnableTaskWindows(WindowList); 
      end; 
      Result := ItemIDList <> nil; 
      if Result then 
      begin 
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

function StringToTColor(S : string) : TColor;
var
 I:Integer;
 List:TStringList;
begin
  List := TStringList.Create;
  TRY
    List.CommaText := S;
    if List.Count < 3 then
       Result := clBlack
    else
    begin
       Result:=StrToInt(List[2]) Shl 16 Or
       StrToInt(List[1]) Shl 8 Or
       StrToInt(List[0]);
    end;
  FINALLY
    List.Free;
  END;
end;

function ColorToHTML(AColor:TColor):string;
begin

  AColor:=ColorToRGB(AColor);
  Result:=Format('#%.2x%.2x%.2x',[(AColor) and $FF,
                                  (AColor shr  8) and $FF,
                                  (AColor shr 16) and $FF]);
end;

function HexToInt(HexStr: String): Int64;
var
  RetVar: Int64;
  I: byte;
begin
  HexStr := UpperCase(HexStr);
  if HexStr[length(HexStr)] = 'H' then Delete(HexStr,length(HexStr),1);
  RetVar := 0;

  for I := 1 to length(HexStr) do
  begin
    RetVar := RetVar shl 4;
    if HexStr[i] in ['0'..'9'] then
      RetVar := RetVar + (byte(HexStr[i]) - 48)
    else if HexStr[i] in ['A'..'F'] then
      RetVar := RetVar + (byte(HexStr[i]) - 55)
    else
    begin
      Retvar := 0;
      Break;
    end;
  end;

  Result := RetVar;
end;

function HexToTColor(S : string): TColor;
var
 a:string;
begin
  result:=clBlack;
  if S[1] <> '#' then exit;
  delete(S,1,1);
  if length(S) <> 6 then exit;
  a := inttostr(HexToInt(copy(S,1,2))) + ',' +
  inttostr(HexToInt(copy(S,3,2))) + ',' +
  inttostr(HexToInt(copy(S,5,2)));
  result:=StringToTColor(a);
end;

function compactstring(s:widestring;size:integer):string;
var
  len:integer;
  s1,s2:string;
begin
  len:=length(s);
  if len<=size then begin
    result:=s;
    exit;
  end;
  s1:=copy(s,1,size div 2);
  s2:=copy(s,len-(size div 2),(size div 2)+1);
  result:=s1+'...'+s2;
end;


function makeuniqfilename(s:string):string;
var
  s1,s2,s3:string;
  k:integer;
begin
  s1:=sysutils.ExtractFilePath(s);
  s2:=sysutils.ExtractFileName(s);
  s2:=sysutils.ChangeFileExt(s2,'');
  s3:=sysutils.ExtractFileExt(s);

  k:=1;
  while sysutils.FileExists(s) do begin
    s:=s1+format('%s[%d]%s',[s2,k,s3]);
    inc(k);
  end;
  result:=s;
end;

function ExecuteFile(filename:string; visible:boolean): Boolean;
var
  SUInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  s:string;
begin
  FillChar(SUInfo, SizeOf(SUInfo), #0);
  with SUInfo do begin
     cb := SizeOf(SUInfo);
     dwFlags := STARTF_USESHOWWINDOW;
     if visible then
        wShowWindow := SW_NORMAL
     else
        wShowWindow := SW_HIDE;
//     s:=sysutils.ExtractFilePath(filename);
     createprocess(nil, PChar(filename), nil, nil, False,
        CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil,
        SUInfo, ProcInfo);
  end;
end;

function GetVersion: string;
var
  VerInfoSize: DWORD;
  VerInfo: Pointer;
  VerValueSize: DWORD;
  VerValue: PVSFixedFileInfo;
  Dummy: DWORD;
begin
  Result := '';
  VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
  if VerInfoSize = 0 then Exit;
  GetMem(VerInfo, VerInfoSize);
  GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  with VerValue^ do
  begin
    Result := IntToStr(dwFileVersionMS shr 16);
    Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
    Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
    Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
  end;
  FreeMem(VerInfo, VerInfoSize);
end;

function difftime(timestamp:tdatetime):integer;
var
  diff:TDateTime;
  Hour, Min, Sec, MSec: Word;
begin
  diff:=now-timestamp;
  DecodeTime(diff, Hour, Min, Sec, MSec);
  result:=(trunc(diff)*24*60)+(hour*60)+min;
end;

function GetModuleDir: string;
var
  szFileName: array[0..MAX_PATH] of Char;
begin
  FillChar(szFileName, SizeOf(szFileName), #0);
  GetModuleFileName(hInstance, szFileName, MAX_PATH);
  Result := szFileName;
  Result:= sysutils.ExtractFilePath(result);
  if (length(result)>0) and (result[length(result)]<>'\') then
    result:=result+'\';
end;

procedure DrawTransparentBitmap(DC: HDC; hBmp: HBITMAP; xStart, yStart: Integer;
  cTransparentColor: COLORREF);
var
  bm: BITMAP;
  cColor: COLORREF;
  bmAndBack, bmAndObject, bmAndMem, bmSave: HBITMAP;
  bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBITMAP;
  hdcMem, hdcBack, hdcObject, hdcTemp, hdcSave: HDC;
  ptSize: TPOINT;
begin
  hdcTemp := CreateCompatibleDC(DC);
  SelectObject(hdcTemp, hBmp);  // Select the bitmap
  GetObject(hBmp, SizeOf(BITMAP), @bm);
  ptSize.x := bm.bmWidth;       // Get width of bitmap
  ptSize.y := bm.bmHeight;      // Get height of bitmap
  DPtoLP(hdcTemp, ptSize, 1);   // Convert from device to logical points
  // Create some DCs to hold temporary data.
  hdcBack := CreateCompatibleDC(DC);
  hdcObject := CreateCompatibleDC(DC);
  hdcMem := CreateCompatibleDC(DC);
  hdcSave := CreateCompatibleDC(DC);
  // Create a bitmap for each DC. DCs are required for a number of GDI functions.
  // Monochrome DC
  bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
  // Monochrome DC
  bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
  bmAndMem := CreateCompatibleBitmap(DC, ptSize.x, ptSize.y);
  bmSave := CreateCompatibleBitmap(DC, ptSize.x, ptSize.y);
  // Each DC must select a bitmap object to store pixel data.
  bmBackOld := SelectObject(hdcBack, bmAndBack);
  bmObjectOld := SelectObject(hdcObject, bmAndObject);
  bmMemOld := SelectObject(hdcMem, bmAndMem);
  bmSaveOld := SelectObject(hdcSave, bmSave);
  // Set proper mapping mode.
  SetMapMode(hdcTemp, GetMapMode(DC));
  // Save the bitmap sent here, because it will be overwritten.
  BitBlt(hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);
  // Set the background color of the source DC to the color
  // contained in the parts of the bitmap that should be transparent
  cColor := SetBkColor(hdcTemp, cTransparentColor);
  // Create the object mask for the bitmap by performing a BitBlt
  // from the source bitmap to a monochrome bitmap.
  BitBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);
  // Set the background color of the source DC back to the original color.
  SetBkColor(hdcTemp, cColor);
  // Create the inverse of the object mask.
  BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);
  // Copy the background of the main DC to the destination.
  BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, DC, xStart, yStart, SRCCOPY);
  // Mask out the places where the bitmap will be placed.
  BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);
  // Mask out the transparent colored pixels on the bitmap.
  BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
  // XOR the bitmap with the background on the destination DC.
  BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCPAINT);
  // Copy the destination to the screen.
  BitBlt(DC, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);
  // Place the original bitmap back into the bitmap sent here.
  BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);
  // Delete the memory bitmaps.
  DeleteObject(SelectObject(hdcBack, bmBackOld));
  DeleteObject(SelectObject(hdcObject, bmObjectOld));
  DeleteObject(SelectObject(hdcMem, bmMemOld));
  DeleteObject(SelectObject(hdcSave, bmSaveOld));
  // Delete the memory DCs.
  DeleteDC(hdcMem);
  DeleteDC(hdcBack);
  DeleteDC(hdcObject);
  DeleteDC(hdcSave);
  DeleteDC(hdcTemp);
end;

function IsActiveDeskTopOn: Boolean;
var
  h: HWND;
begin
  h := FindWindow('Progman', nil);
  h := FindWindowEx(h, 0, 'SHELLDLL_DefView', nil);
  h := FindWindowEx(h, 0, 'Internet Explorer_Server', nil);
  Result := h <> 0;
end;

function ChangeWallpaper(aFile: String): Boolean;
const
  CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
  hObj: IUnknown;
  ADesktop: IActiveDesktop;
  str: string;
  wstr: PWideChar;
begin
  hObj     := CreateComObject(CLSID_ActiveDesktop);
  ADesktop := hObj as IActiveDesktop;
  wstr := AllocMem(MAX_PATH);
  try
    StringToWideChar(aFile, wstr, MAX_PATH);
    ADesktop.SetWallpaper(wstr, 0);
    ADesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
  finally
    FreeMem(wstr);
  end;
end;

end.
