hyperfrm.pas

String hanlding library. Functions for crypto, token etc

//*** HYPERFRM v6.00a - (c)1996-2001, EFD Systems ***
//(Form and shell related routines moved from HyperString)
//
//This source code is licensed for the private personal use of
//our clients and may not be re-distributed under any circumstances.
//
//THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF
//ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO
//THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A
//PARTICULAR PURPOSE.

{$B-,H+,X+,J-} //Essential directives
{$IFDEF VER140}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}

unit HyperFrm;

interface

uses
  Windows, Messages, SysUtils, Controls, Forms, Dialogs, Classes, Graphics,
  Registry, Printers, WinSpool, ShellAPI, ShlObj, HyperStr,MAPI;

function  KillProc(const ClassName:AnsiString):Boolean;
function  ToggleSysKeys:Boolean;
function  GetKeyToggle(const Key:Integer):Boolean;
function  SetTopMost(const Hnd:Thandle; Flag:Boolean):Boolean;
procedure EnterTab(const hForm:THandle;var Key:Char);
procedure AddScrollBar(const hListBox:THandle;const Width:DWord);
procedure AddTabStops(const hListBox:THandle;const Stops:array of DWord);
function  SetTaskBar(const Visible:Boolean):Boolean;
procedure NoTaskBtn;
procedure NoCloseProgram;

function  GetWindows:Ansistring;
function  GetClasses:Ansistring;

procedure DebugConsole;
procedure DebugMsg(const Msg:AnsiString);

procedure TrayInsert;
procedure TrayClose(var Action:TCloseAction);
procedure TrayDelete;
procedure TrayPopUp;

function  ShellFileOp(const S,D:AnsiString; const FileOp,Flgs:Integer):Boolean;
function  MapNetDrive:Integer;
function  ShellToDoc(const FilePath:AnsiString):THandle;
procedure MakeDoc(const FileName:AnsiString);

procedure FlashMsg(const Title,Msg:AnsiString; TOut:Integer);
function  FormatDisk(Drive:Word):Boolean;
procedure FlashSplash(Bitmap:TGraphic; const Title:AnsiString);
procedure KillSplash;
function  GetFolder(const Msg,Path:AnsiString;FSOnly:Boolean):AnsiString;
function  GetWinFolder(const SpecialFolder : Integer) : AnsiString;
function  GetWinName(FileName: AnsiString): AnsiString;

procedure PrintStr(Source:AnsiString;Font:TFont);
procedure SaveStr(Source,FileName:AnsiString);
function  LoadStr(FileName:AnsiString):AnsiString;
function  LoadRec(FileName:AnsiString;var Rec; RecLen:Integer):Boolean;
function  SaveRec(FileName:AnsiString;var Rec; RecLen:Integer):Boolean;

function  GetPaperNames:AnsiString;
procedure GetComList(Strings:TStrings);
function  ShowFileProperties(FilePath:AnsiString):Boolean;
function  ShowPrinterProperties(PrnName:AnsiString):Boolean;

function  SendMAPI(Subj,Body,SendTo,CC,BCC,Att:AnsiString;MAPIFlags:Cardinal):Integer;

implementation

type
  TRegisterServiceProcess = function(dwProcessID, dwType: DWord): DWord; stdcall;

const
{$ifdef VER90}      //Delphi 2 doesn't have this constant
  PROCESS_TERMINATE = $0001;
{$endif}
  Tray_Msg = wm_User+$0EFD;        //tray notification message
var
  Splash: TForm;
  ICD   : TNotifyIconData;
  SF    : TShFileOpStruct;
  DebugFlg: Boolean=False;
  TrayFlg : Boolean=False;
  MsgFlg  : Boolean=False;
  BfrFlg  : Boolean=False;
  CloseFlg: Boolean=False;
  pPtr1:Pointer;
  SysKeyFlg:Integer=-1;
  Temp,Tmp:AnsiString;
  dwI:dWord;

function SetTopMost(const Hnd:THandle; Flag:Boolean):Boolean;
  {Set and reset a given Window to stay on top of ALL Windows.
   Setting 'formstyle:=fsStayOnTop' only works for windows within the application
   and causes flicker.}
var
  hFlag:Thandle;
begin
  Result:=False;
  if IsWindow(Hnd) then begin
    if Flag then hFlag:=HWND_TOPMOST else hFlag:=HWND_NOTOPMOST;  
    SetWindowPos(Hnd, hFlag, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE );
    Result:=True;
  end;
end;


procedure FlashSplash(Bitmap:TGraphic; const Title:AnsiString);
  {Dynamically create a splash form in a flash.}
var
  I,L1,R1:Integer;
  R:TRect;
  MS: TMemoryStatus;
  VerInfoSize,VerValueSize,dwI: DWord;
  VerInfo,VerValue: Pointer;
  Tmp,Temp,key1,key2,xl:AnsiString;
begin
  Splash:=TForm.Create(Application);
  with Splash do begin
    Name := 'EFD_Splash';
    Caption := Title;
    Position := poScreenCenter;
    BorderStyle := bsDialog;
    FormStyle := fsStayOnTop;
    BorderIcons := [];
    Height := 279;
    Width := 349;
    Cursor:=crHourGlass;
    Show;
    Application.ProcessMessages;
    with Canvas do begin
      Draw(16,16,BitMap);
      R.Top := 168;
      R.Left := 80;
      R.Right := R.Left+249;
      R.Bottom := R.Top+2;
      FrameRect(R);
      MoveTo(R.Left,R.Top);
      LineTo(R.Right,R.Top);
      Brush.Style := bsClear;
      L1 := Abs((3*Font.Height) Div 2);
      SetDelimiter(#32);
      if IsWinNT then begin
        Key1:='SOFTWARE\Microsoft\Windows NT\CurrentVersion';
        Key2:='Windows NT '+GetKeyValues(HKEY_LOCAL_MACHINE, Key1,'CurrentVersion');
      end else begin
        Key1:='SOFTWARE\Microsoft\Windows\CurrentVersion';
        Key2:=GetKeyValues(HKEY_LOCAL_MACHINE, Key1,'Version,VersionNumber');
      end;
      SetDelimiter(#10);
      Tmp:=GetKeyValues(HKEY_LOCAL_MACHINE,Key1,'RegisteredOwner,RegisteredOrganization,ProductID');
      R1:=1;
      R.Top:=176-(4*L1);
      for I:=0 to 2 do begin
        Temp:=GetToken(Tmp,R1);
        if Length(Temp)>0 then begin
          TextOut(R.Left,R.Top,Temp);
          R.Top:=R.Top+L1;
        end;
        NextToken(Tmp,R1);
      end;
      SetDelimiter(' ');
      R.Top := 176;
      TextOut(R.Left,R.Top,Key2);
      R.Top:=R.Top+L1;
      TextOut(R.Left,R.Top,'Memory Available to Windows:');

      MS.dwLength:=SizeOf(MS);
      GlobalMemoryStatus(MS);
      Tmp:=IntToFmtStr(MS.dwTotalPhys div 1024)+' KB';
      TextOut(R.Right-TextWidth(Tmp),R.Top,Tmp);

      VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), dwI);
      if VerInfoSize<>0 then begin
        GetMem(VerInfo, VerInfoSize);
        try
          if GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo) then begin
            SetLength(Tmp,0);
            R.Top:=28+L1;
            xl:='040904E4';  //US English
            if VerQueryValue(VerInfo,'\VarFileInfo\Translation',VerValue,VerValueSize) then begin
              if VerValueSize>=4 then begin
                Move(VerValue^,I,4);
                xl:=IntToHex(LoWord(I),4)+IntToHex(HiWord(I),4);
              end;
            end;
            xl:='\StringFileInfo\'+xl;
            if VerQueryValue(VerInfo, PChar(xl+'\FileDescription'), VerValue, VerValueSize) then begin
              if VerValueSize>1 then begin
                Font.Style:=[fsItalic];
                TextOut(R.Left,R.Top,PChar(VerValue));
                Font.Style:=[];
                R.Top:=R.Top+L1;
              end;
            end;
            VerQueryValue(VerInfo, PChar(xl+'\ProductVersion'), VerValue, VerValueSize);
            if VerValueSize>1 then Tmp:=PChar(VerValue)+' ';
            VerQueryValue(VerInfo, PChar(xl+'\LegalCopyright'), VerValue, VerValueSize);
            if VerValueSize>1 then Tmp:=Tmp+PChar(VerValue);
            if Length(Tmp)>0 then TextOut(R.Left,R.Top,Tmp);
            if VerQueryValue(VerInfo, PChar(xl+'\CompanyName'), VerValue, VerValueSize) then begin
              if VerValueSize>1 then begin
                R.Top:=R.Top+L1;
                TextOut(R.Left,R.Top,PChar(VerValue));
              end;
            end;
            if VerQueryValue(VerInfo, PChar(xl+'\LegalTrademarks'), VerValue, VerValueSize) then begin
              if VerValueSize>1 then begin
                R.Top:=R.Top+L1;
                TextOut(R.Left,R.Top,PChar(VerValue));
              end;
            end;
            if VerQueryValue(VerInfo, PChar(xl+'\ProductName'), VerValue, VerValueSize) then begin
              if VerValueSize>1 then begin
                R.Top:=16;
                Font.Size:=18;
                Font.Color:=clBlue;
                Font.Style:=[];
                TextOut(R.Left,R.Top,PChar(VerValue));
              end;
            end;
          end;
        finally
          FreeMem(VerInfo, VerInfoSize);
        end;
      end;
    end;
  end;
end;



procedure FlashMsg(const Title,Msg:AnsiString; TOut:Integer);
  {Dynamically create a timed message display form.}
var
  I,J:Integer;
begin
  with TForm.Create(Application) do begin
    Name := 'EFD_Msg'+IntToStr(GetTickCount AND $FFFF);
    Caption := Title;
    Position := poScreenCenter;
    BorderStyle := bsDialog;
    FormStyle := fsStayOnTop;
    BorderIcons := [];
    Height := 64;
    I := Canvas.TextWidth(Msg);
    J := Canvas.TextHeight(Msg);
    Height := 5*J;
    Width := iMax(128,I + (I Shr 1));
    I := Left+((Width - I ) Shr 1);
    J := Top+J;
    Show;
    Canvas.Brush.Style := bsClear;
    Canvas.TextOut(I,J,Msg);
    I:=GetTickCount+DWord(TOut);
    repeat
      Application.ProcessMessages;
    until GetTickCount>DWord(I);
    Free;
  end;
end;


procedure KillSplash;
begin
  if IsWindow(Splash.Handle) then Splash.Free;
end;


procedure EnterTab(const hForm:THandle;var Key:Char);
  {Make Enter act like Tab by calling from FormKeyPress event handler.
   Form.KeyPreview must be set to True.}
begin
  if Key = #13 then begin
    Key := #0;
    PostMessage(hForm, WM_NEXTDLGCTL, 0, 0);
  end;
end;


function  SetTaskBar(const Visible:Boolean):Boolean;

  {Enables/Disables the Windows task bar based upon the Visible parameter.
   Not a very 'Windows friendly' function but necessary if you want your
   app to have the entire screen available.}

var
  TrayHandle: THandle;
begin
  Result:=False;
  TrayHandle := FindWindow('Shell_TrayWnd', nil);
  if TrayHandle<>0 then begin
    if Visible then
      ShowWindow(TrayHandle, SW_RESTORE)
    else
      ShowWindow(TrayHandle, SW_HIDE);
    Result:=True;
  end;
end;


procedure  NoTaskBtn;
  {Disables the display of a taskbar button for the application.}
var
  WinStyle:Integer;
begin
  WinStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);
  WinStyle := WinStyle OR WS_EX_TOOLWINDOW AND (NOT WS_EX_APPWINDOW);
  SetWindowLong(Application.Handle, GWL_EXSTYLE, WinStyle);
end;


procedure  NoCloseProgram;
  {Hides app from system Close Program (Ctrl-Alt-Del) dialog in Win95.}
var
  hkernel:THandle;
  RegisterServiceProcess:TRegisterServiceProcess;
  dwI:DWord;
begin
  if IsWinNT=False then begin
    hKernel:=LoadLibrary('KERNEL32.DLL');
    if hKernel<>0 then begin
      CloseFlg:=Not CloseFlg;
      if CloseFlg then dwI:=1 else dwI:=0;
      @RegisterServiceProcess:=GetProcAddress(hKernel,'RegisterServiceProcess');
      RegisterServiceProcess(GetCurrentProcessID, dwI);
      FreeLibrary(hKernel);
    end;
  end;
end;

procedure DebugConsole;
begin
  if FindWindow('TAppBuilder',nil)<>0 then begin
    if DebugFlg then begin
      FreeConsole;
      DebugFlg:=False;
    end else if GetStdhandle(STD_OUTPUT_HANDLE)=INVALID_HANDLE_VALUE then DebugFlg:=AllocConsole;
  end;
end;


procedure DebugMsg(const Msg:AnsiString);
begin
  if DebugFlg then WriteLn(Msg);
end;


function EFD_WndProc(Handle: hWnd; Msg, wParam, lParam:Integer):Integer; stdcall;
  {Internal message handler for tray applications.}
begin
  if MsgFlg AND (Msg=Tray_Msg) then begin  //are we filtering ?
    if (lParam=wm_LButtonDown) or (lParam=wm_RButtonDown) then begin //left or right button click ?
      MsgFlg:=False;                 //clear flag so we don't come here
      Application.MainForm.Show;     //show main form
      Application.BringToFront;      //give it focus
      ShowWindow(Application.MainForm.Handle, SW_SHOWNORMAL);