hyperfrm.pas

String hanlding library. Functions for crypto, token etc

      Msg:=WM_NULL;                  //kill the message
    end;                             //again until they close
  end;
  Result:=CallWindowProc(pPtr1, Handle, Msg, wParam, lParam);
end;


procedure TrayInsert;
  {Adds application icon to tray.}
begin
  if TrayFlg then     //we're already in the tray
    MsgFlg:=True      //make sure message handler is enabled
  else begin
    ICD.cbSize := Sizeof(ICD);
    ICD.Wnd := Application.Handle;
    ICD.uID := $0EFD;
    ICD.uFlags := NIF_MESSAGE OR NIF_ICON OR NIF_TIP;
    ICD.uCallbackMessage := Tray_Msg;
    ICD.hIcon := Application.Icon.Handle;
    StrPCopy(ICD.szTip, Application.Title);
    Shell_NotifyIcon(NIM_ADD, @ICD);
    pPtr1 := Pointer(SetWindowLong(ICD.Wnd, gwl_WndProc,Integer(@EFD_WndProc)));
    TrayFlg := True;  //show we're in tray
    MsgFlg := True;   //turn internal message handler on
  end;
end;


procedure TrayClose(var Action:TCloseAction);
  {Hides main form once icon has been added to tray.}
begin
  if not(TrayFlg) then Exit;
  Application.MainForm.Hide;
  ShowWindow(Application.Handle, SW_HIDE); //make sure TApplication window stays hid
  MsgFlg:=True;                  //activate message handler
  Action:=caNone;                //kill the normal close
end;


procedure TrayDelete;
  {Remove the icon from the tray.}
begin
  if not(TrayFlg) then Exit;                          //icon, what icon?
  MsgFlg:=False;                                      //reset our message flag
  SetWindowLong(ICD.Wnd, gwl_WndProc,Integer(pPtr1)); //remove internal message loop
  Shell_NotifyIcon(NIM_DELETE, @ICD);                 //kill the icon
  TrayFlg:=False;
end;


procedure TrayPopUp;
  {Manually restore a tray app.}
begin
  if not(TrayFlg and MsgFlg) then Exit;
  MsgFlg:=False;                 //disable message handler
  Application.MainForm.Show;     //show main form
  Application.BringToFront;      //give it focus
  ShowWindow(Application.MainForm.Handle, SW_SHOWNORMAL);
end;

function ShellFileOp(const S,D:AnsiString; const FileOp,Flgs:Integer):Boolean;
  {Convenient interface to Win95 shell for file operations.}
var
  Tmp,Temp:AnsiString;
  Delimiter:Char;
begin
  Result:=False;
  if FileOp in [FO_DELETE,FO_COPY,FO_MOVE,FO_RENAME] then begin
    Delimiter:=GetDelimiter;
    SF.Wnd:=0;
    SF.wFunc:=FileOp;
    SF.fAnyOperationsAborted:=False;
    Tmp:=S;
    Temp:=D;
    if Length(Tmp)=0 then Exit;
    if Tmp[Length(Tmp)]<>Delimiter then Tmp:=Tmp+Delimiter;
    ReplaceC(Tmp,Delimiter,#0);  //replace delimiters with nulls (double null at end)
    if Length(Temp)>0 then begin
      if Temp[Length(Temp)]<>Delimiter then Temp:=Temp+Delimiter;
      ReplaceC(Temp,Delimiter,#0);
    end;
    SF.pFrom:=PChar(Tmp);
    SF.pTo:=PChar(Temp);
    SF.fFlags:=Flgs AND (NOT FOF_WANTMAPPINGHANDLE);
    Result:=NOT((ShFileOperation(SF)<>0) OR SF.fAnyOperationsAborted);
    SetLength(Temp,0);
    SetLength(Tmp,0);
  end;
end;

function SHFormatDrive(H:hWnd;D,F,O:Word):Integer;stdcall;external 'shell32.dll';
function FormatDisk(Drive:Word):Boolean;

  {Convenient MODAL interface to shell disk format operations. Drive is ASCII
   drive letter; A = 65, B=66, etc..

   Returns True if valid drive and no user abort.}

begin
  Drive:=(Drive AND 31)-1;
  Result:= (ShFormatDrive(Application.MainForm.Handle,Drive,$FFFF,0)>=0);
end;

function MapNetDrive:Integer;
begin
  Result:=WNetConnectionDialog(Application.Handle,RESOURCETYPE_DISK);
end;


function ShellToDoc(const FilePath:AnsiString):THandle;
  {Open a document with associated application using Windows shell}
begin
  Result:=ShellExecute(Application.Handle,nil,PChar(FilePath),nil,nil,SW_SHOWNORMAL);
end;


procedure FreePIDL(PIDL:PItemIDList); stdcall;external 'shell32.dll' index 155;
function  SHSimpleIDListFromPath(Path: Pointer): PItemIDList; stdcall;external 'shell32.dll' index 162;

function  GetPIDLFromPath(Path: AnsiString): PItemIDList;
var
  PWPath:WideString;
begin
  if IsWinNT then begin
    SetLength(PWPath,Length(Path) SHL 1);
    StringToWideChar(Path,PWideChar(PWPath),Length(Path)+1);
    Result:=ShSimpleIDListFromPath(PWideChar(PWPath));
  end else Result:=SHSimpleIDListFromPath(PChar(Path));
end;


function GetFolder(const Msg,Path:AnsiString;FSOnly:Boolean):AnsiString;
  {Browse for folder using Windows shell. Returns path of selected folder,
   null string on abort.}
var
  pbi : TBrowseInfo;
  PIDL: PItemIDList;
begin
  SetLength(Result,MAX_PATH+1);
//  pbi.hwndOwner := Application.MainForm.Handle;
  pbi.hwndOwner := Screen.ActiveForm.Handle;
  pbi.pidlRoot := nil;
  if Length(Path)>0 then pbi.pidlRoot:=GetPIDLFromPath(ExtractFileDir(Path));
  pbi.pszDisplayName := PChar(Result);
  pbi.lpszTitle := PChar(Msg);
  pbi.ulFlags :=BIF_STATUSTEXT OR BIF_DONTGOBELOWDOMAIN;
  if FSOnly then pbi.ulFlags := pbi.ulFlags OR BIF_RETURNONLYFSDIRS;
  pbi.lpfn := nil;
  pbi.lParam := 0;
  pbi.iImage := 0;
  PIDL:=SHBrowseForFolder(pbi);
  if (PIDL<>nil) and SHGetPathFromIDList(PIDL,PChar(Result)) then
    SetLength(Result,StrLen(PChar(Result)))
  else Setlength(Result,0);
  FreePIDL(PIDL);
  FreePIDL(pbi.pidlRoot);
end;


function GetWinFolder(const SpecialFolder : Integer) : AnsiString;
  {Retrieves location of Special Windows folders.  See SHGetSpecialFolderLocation
   for a list of valid SpecialFolder constants.  "SHLOBJ" must be added to "Uses".}
var
  Pidl: PItemIDList;
begin
  SetLength(Result,MAX_PATH+1);
  if SHGetSpecialFolderLocation(0, SpecialFolder, Pidl)=NOERROR then begin
    if SHGetPathFromIDList(Pidl, PChar(Result)) then
       Setlength(Result,StrLen(PChar(Result)))
    else SetLength(Result,0);
  end;
end;


function GetWinName(FileName: AnsiString): AnsiString;
  {Retrieve long filename equivalent}
var
  PIDL: PItemIDList;
  Shell: IShellFolder;
  WideName: WideString;
  AnsiName: AnsiString;
  Dummy: DWord;
begin
  Result := FileName;
  if Succeeded(SHGetDesktopFolder(Shell)) then begin
    SetLength(WideName,Length(FileName) SHL 1);
    StringToWideChar(FileName,PWideChar(WideName),Length(FileName)+1);
    if Succeeded(Shell.ParseDisplayName(0, nil, PWideChar(WideName), Dummy, PIDL, Dummy)) then
    if PIDL<>nil then begin
      SetLength(AnsiName,MAX_PATH+1);
      if SHGetPathFromIDList(PIDL, PChar(AnsiName)) then begin
        Result := AnsiName;
        SetLength(Result,StrLen(PChar(Result)));
      end;
      FreePIDL(PIDL);
    end;
  end;
end;


procedure MakeDoc(const FileName:AnsiString);
  {Adds FileName to Window's Documents menu.  Clears the menu if FileName = null.}
begin
  if Length(FileName)>0 then
    SHAddToRecentDocs(SHARD_PATH, pChar(FileName))
  else
    SHAddToRecentDocs(SHARD_PATH, nil);
end;

function  GetKeyToggle(const Key:Integer):Boolean;
  { Returns current keyboard status.  Any key may be specifed, the standard
    toggle keys are VK_INSERT,VK_NUMLOCK,VK_SCROLL, VK_CAPITAL}
begin
   Result := Odd(GetKeyState(Key));
end;

function ToggleSysKeys:Boolean;
  {Enables/Disables system keys (Win95 only).  Returns current key state.}
var
  Tmp: Bool;
begin
  if SystemParametersInfo(SPI_SCREENSAVERRUNNING, SysKeyFlg, @Tmp, 0 ) then SysKeyFlg:= NOT SysKeyFlg;
  Result:=(SysKeyFlg<>0);
end;


procedure AddScrollBar(const hListBox:THandle;const Width:DWord);
  {Add a horizontal scroll bar to a ListBox component.}
begin
  SendMessage(hListBox,LB_SetHorizontalExtent,Width,0);
end;


procedure AddTabStops(const hListBox:THandle;const Stops:array of DWord);
  {Add horizontal tab stops to a ListBox component.}
begin
  SendMessage(hListBox,LB_SETTABSTOPS, High(Stops)+1,Longint(@Stops));
end;


function  KillProc(const ClassName:AnsiString):Boolean;

  {Terminates the first process with the given window class.  Window class is
   fixed whereas Window title can change.

   Example: KillProc('NOTEPAD') unconditionally terminates Windows Notepad if
            it is running. }
var
  hWnd,hProc:THandle;
  pid:DWORD;
begin
  Result:=False;
  hWnd := FindWindow(PCHAR(ClassName),nil);
  if IsWindow(hWnd) then begin
    GetWindowThreadProcessId(hWnd, @pid);
    hproc := OpenProcess(PROCESS_TERMINATE, FALSE, pid);
    if hproc<>0 then begin
      Result:=TerminateProcess(hProc,0);
      if Result then CloseHandle(hProc);
    end;
  end;
end;


procedure PrintStr(Source:AnsiString; Font:TFont);
  {Print contents of Source on default printer using Font.}
var
  Prn: TextFile;
begin
  if Length(Source)=0 then Exit;
  AssignPrn(Prn);
  try
    Rewrite(Prn);
    try
      if Font=nil then begin
        Printer.Canvas.Font.Name:='Courier New';
        Printer.Canvas.Font.Size:=12;
      end else Printer.Canvas.Font:=Font;
      Write(Prn, Source);
    finally
      CloseFile(Prn);
    end;
  except
    on EInOutError do raise Exception.Create('Error printing text.');
  end;
end;


procedure SaveStr(Source,FileName:AnsiString);
  {Save contents of Source string into FileName.}
var
  F:File;
  SaveMode:Integer;
begin
  AssignFile(F,FileName);
  SaveMode:=FileMode;
  FileMode:=1;            //always set this regardless of what docs say
  try
    Rewrite(F,1);
    try
      BlockWrite(F,Source[1],Length(Source));
    finally
      CloseFile(F);
    end;
  except
    on EInOutError do raise Exception.Create('Error writing to '+Filename);
  end;
  FileMode:=SaveMode;
end;


function LoadStr(FileName:AnsiString):AnsiString;
  {Retrieve contents of FileName as string.}
var
  F:File;
  I:Integer;
  SaveMode:Integer;
begin
  Setlength(Result,0);
  AssignFile(F,FileName);
  SaveMode:=FileMode;
  FileMode := 0;
  try
    Reset(F,1);
    try
      if SetFileLock(TFileRec(F).Handle,0,FileSize(F)) then begin
        SetLength(Result,FileSize(F));
        BlockRead(F,Result[1],Length(Result),I);
        ClrFileLock(TFileRec(F).Handle,0,FileSize(F));
        SetLength(Result,I);
      end;
    finally
      CloseFile(F);
    end;
  except
    on EInOutError do raise Exception.Create('Error reading from'+Filename);
  end;
  FileMode:=SaveMode;
end;


function LoadRec(FileName:AnsiString;var Rec; RecLen:Integer):Boolean;
  {Retrieve contents of FileName as record type.}
var
  F:File;
  I:Integer;
begin
  I:=-1;
  AssignFile(F,FileName);
  FileMode := 0;
  try
    Reset(F,1);
    try
      if SetFileLock(TFileRec(F).Handle,0,RecLen) then begin
        BlockRead(F,Rec,RecLen,I);
        ClrFileLock(TFileRec(F).Handle,0,RecLen);
      end;
    finally
      CloseFile(F);
      Result:=I=RecLen;
    end;
  except