hyperfrm.pas

String hanlding library. Functions for crypto, token etc

    on EInOutError do raise Exception.Create('Error reading from'+Filename);
  end;
end;


function SaveRec(FileName:AnsiString;var Rec; RecLen:Integer):Boolean;
  {Save contents of record type into FileName.}
var
  F:File;
  I:Integer;
begin
  I:=-1;
  AssignFile(F,FileName);
  FileMode:=1;            //always set this regardless of what docs say
  try
    Rewrite(F,1);
    try
      BlockWrite(F,Rec,RecLen,I);
    finally
      CloseFile(F);
      Result:=I=RecLen;
    end;
  except
    on EInOutError do raise Exception.Create('Error writing to '+Filename);
  end;
end;


function GetPaperNames:AnsiString;
  {Returns a tokenized string (comma delimited) listing the names of all
   paper types supported by the default printer driver.}
var
  Tmp, Device, Port: AnsiString;
  I,J:Integer;
begin
  Result:='';
  Tmp:=GetDefaultPrn;
  if Length(Tmp)=0 then Exit;
  I:=1;
  Device:=Parse(Tmp,',',I);
  Parse(Tmp,',',I);
  Port:=Parse(Tmp,',',I);
  J := DeviceCapabilities( PChar(Device), PChar(Port), DC_PAPERNAMES, Nil, Nil );
  if J > 0 then begin
    SetLength(Tmp,J*64);
    DeviceCapabilities( PChar(Device), PChar(Port), DC_PAPERNAMES, PChar(Tmp), Nil);
    for I:= 1 To J do begin
      Result := Result + PChar(CStr(Tmp,((I-1)*64)+1,64) );
      if I<J then Result := Result+',';
    end;
    SetLength(Tmp,0);
  end;
end;


procedure GetComList(Strings:TStrings);

  {Reads all available COM ports from Registry and stores them in a TStrings
   list (ListBox). Also checks to see if a modem is attached to the port.
   If so, the modem 'Model' string is appended to the COM port name.}

var
  hTmp                   : HKEY;
  key,tKey,kBfr,vBfr,S   : AnsiString;
  I,N                    : Integer;
  J,K,Cnt,Max_Key,Max_Val: DWord;
begin
  //first, clear any existing entries in list
  if Strings.Count>0 then Strings.Clear;
  //read all available ports
  key:='hardware\devicemap\serialcomm';
  if RegOpenKeyEx(HKEY_LOCAL_MACHINE,PChar(Key),0,KEY_READ,hTmp) = ERROR_SUCCESS then begin
    if RegQueryInfoKey(hTmp, nil, nil, nil, nil, nil, nil, @Cnt, @Max_Key,
      @Max_Val, nil, nil) = ERROR_SUCCESS then begin;
      if Cnt>0 then begin
        SetLength(kBfr,Max_Key+1);
        SetLength(vBfr,Max_Val+1);
        for I:=0 to Cnt - 1 do begin
          J:=Max_Key+1;
          K:=Max_Val+1;
          if RegEnumValue(hTmp, I, PChar(kBfr), J, nil, nil, PByte(vBfr), @K)=ERROR_SUCCESS then begin;
            if K>1 then begin
              S:=LStr(vBfr,K-1);  //extract the port name from the buffer
              if Strings.IndexOf(S)=-1 then Strings.Add(S); //avoid any duplicates
            end;
          end;
        end;
      end;
    end;
    RegCloseKey(hTmp);
  end;

  //supplement port list with modem 'Model' string

  key:='System\CurrentControlSet\Services\Class\Modem';
  if RegOpenKeyEx(HKEY_LOCAL_MACHINE,PChar(Key),0,KEY_READ,hTmp) = ERROR_SUCCESS then begin
    if RegQueryInfoKey(hTmp, nil, nil, nil, @Cnt,@Max_Key, nil, nil, nil,
      nil, nil, nil) = ERROR_SUCCESS then begin;
      if Cnt>0 then begin
        SetLength(kBfr,Max_Key+1);
        SetLength(vBfr,MAX_PATH+1);
        for I:=0 to Cnt - 1 do begin
          J:=Max_Key+1;
          if RegEnumKeyEx(hTmp, I, PChar(kBfr), J, nil, nil, nil, nil)=ERROR_SUCCESS then begin;
            tKey:=key+'\'+LStr(kBfr,J);
            RegCloseKey(hTmp);
            if RegOpenKeyEx(HKEY_LOCAL_MACHINE,PChar(tKey),0,KEY_READ,hTmp) = ERROR_SUCCESS then begin
              J:=MAX_PATH;
              if RegQueryValueEx(hTmp,'AttachedTo',nil,nil,PByte(vBfr),@J) = ERROR_SUCCESS then begin
                S:=LStr(vBfr,J-1);
                J:=MAX_PATH;
                if RegQueryValueEx(hTmp,'Model',nil,nil,PByte(vBfr),@J) = ERROR_SUCCESS then begin
                   N:=Strings.IndexOf(S);
                   S:=S+'-'+LStr(vBfr,J-1);
                   if N=-1 then Strings.Add(S) else Strings[N]:=S;
                end;
              end;
              RegCloseKey(hTmp);
            end;
            RegOpenKeyEx(HKEY_LOCAL_MACHINE,PChar(Key),0,KEY_READ,hTmp);
          end;
        end;
      end;
    end;
    RegCloseKey(hTmp);
  end;

end;

function  SHObjectProperties(Owner: HWND; Flags: UINT; ObjectName: Pointer;
                             InitialTabName: Pointer): LongBool;
                             stdcall;external 'shell32.dll' index 178;

function  ShowFileProperties(FilePath:AnsiString):Boolean;
begin
  Result:=SHObjectProperties(Application.Handle,$02,PChar(FilePath),nil);
end;

function  ShowPrinterProperties(PrnName:AnsiString):Boolean;
begin
  Result:=SHObjectProperties(Application.Handle,$01,PChar(PrnName),nil);
end;


function GetWindows:AnsiString;
  {Returns a tokenized string listing all currently active Windows.}
var
  lpCallBack: TFNWndEnumProc;

  function DoEnumWin(hwnd:THandle;lIntParam:LPARAM):Bool stdcall;
  begin
    if IsWindow(hwnd) then begin
      SetLength(Tmp,256);
      dwI:=GetWindowText(hwnd,PChar(Tmp),255);
      if dwI>0 then begin
        SetLength(Tmp,dwI);
        InsertToken(Temp,Tmp,0);
      end;
    end;
    Result:=True;
  end;

begin
  SetLength(Temp,0);
  lpCallBack:=@DoEnumWin;
  ENumWindows(lpCallBack,0);
  Result:=Temp;
end;


function GetClasses:AnsiString;
  {Returns a tokenized string listing all active window class names.}
var
  lpCallBack: TFNWndEnumProc;

  function DoEnumWin(hWnd:THandle;lIntParam:LPARAM):Bool stdcall;
  begin
    if IsWindow(hWnd) then begin
      SetLength(Tmp,256);
      dwI:=GetClassName(hWnd,PChar(Tmp),255);
      if dwI>0 then begin
        SetLength(Tmp,dwI);
        InsertToken(Temp,Tmp,0);
      end;
    end;
    Result:=True;
  end;

begin
  SetLength(Temp,0);  
  lpCallBack:=@DoEnumWin;
  ENumWindows(lpCallBack,0);
  Result:=Temp;
end;


function SendMAPI(Subj,Body,SendTo,CC,BCC,Att:AnsiString;MAPIFlags:Cardinal):Integer;
const
  FDelimiters=';,';
var
  MAPIMessage : TMAPIMessage;
  RB          : PMapiRecipDesc;
  RC          : LongInt;
  AB          : PMapiFileDesc;
  AC          : LongInt;

  procedure AllocateRecipients(var RecipientsBuffer : PMapiRecipDesc;
                               var RecipientsCount  : LongInt);
  var
    ES       : LongInt;
    RI       : LongInt;

    procedure AddRecipients(RecipientsString : AnsiString;RecipientsClass:Cardinal);
    var
     RS : AnsiString;
     I:Integer;
    begin
      I:=1;
      repeat
        //Find recipient string
        RS := Parse(RecipientsString, FDelimiters, I);
        if Length(RS)>0 then begin
          //Assign recipient buffer
          with PMapiRecipDesc(PAnsiChar(RecipientsBuffer) + (RI * ES))^ do begin
            ulRecipClass := RecipientsClass;
            lpszName := StrAlloc(Length(RS) + 1);
            StrPCopy(lpszName, RS);
          end;
          Inc(RI);
        end;
      until (I>Length(RecipientsString)) OR (I<1);
    end;

  begin
    //Initialize recipient index
    RI:=0;

    //Calculate recipient count
    RecipientsCount :=CountW(SendTo,FDelimiters)+CountW(CC,FDelimiters)+
                      CountW(BCC,FDelimiters);

    //Calculate element size
    ES := SizeOf(TMapiRecipDesc);

    //Allocate and initialize buffer
    GetMem(RecipientsBuffer, RecipientsCount * ES);
    FillChar(RecipientsBuffer^, RecipientsCount * ES, #0);

    //Add recipients to buffer
    AddRecipients(SendTo, MAPI_TO);
    AddRecipients(CC, MAPI_CC);
    AddRecipients(BCC, MAPI_BCC);
  end;

  procedure DeallocateRecipients(RecipientsBuffer : PMapiRecipDesc;
                                 RecipientsCount  : LongInt);
  var
    I  : LongInt;
    ES : LongInt;
  begin
     //Calculate element size
    ES := SizeOf(TMapiRecipDesc);

     //Deallocate addresses
    for I := 0 to RecipientsCount - 1 do
      with PMapiRecipDesc(PAnsiChar(RecipientsBuffer) + (I * ES))^ do StrDispose(lpszAddress);

     //Deallocate buffer
    FreeMem(RecipientsBuffer, RecipientsCount * ES);
  end;

  procedure AllocateAttachments(var AttachmentBuffer : PMapiFileDesc;
                                var AttachmentCount  : LongInt);
  var
    ES : LongInt;
    FI : LongInt;
    FS : AnsiString;
     I : Integer;
  begin
    //Calculate attachments count
    AttachmentCount := CountW(Att, FDelimiters);

    //Calculate element size
    ES := SizeOf(TMapiFileDesc);

    //Allocate and initialize buffer
    GetMem(AttachmentBuffer, AttachmentCount * ES);
    FillChar(AttachmentBuffer^, AttachmentCount * ES, #0);

    //Add attachments to buffer
    I:=1;
    FI:=0;
    repeat
      //Find attachment string
      FS := Parse(Att, FDelimiters, I);

      if Length(FS)>0 then begin
        //Assign Attachment buffer
        with PMapiFileDesc(PAnsiChar(AttachmentBuffer) + (FI * ES))^ do begin
          //Assign Attachment buffer
          lpszPathName := StrAlloc(Length(FS) + 1);
          StrPCopy(lpszPathName, FS);
          LongInt(nPosition) := -1;
        end;
        Inc(FI);
      end;
    until (I>Length(Att)) OR (I<1) OR (FI=AttachmentCount);
  end;

  procedure DeallocateAttachments(AttachmentBuffer : PMapiFileDesc;
                                  AttachmentCount  : LongInt);
  var
    I  : LongInt;
    ES : LongInt;
  begin
    //Calculate element size
    ES := SizeOf(TMapiFileDesc);

    //Deallocate addresses
    for I := 0 to AttachmentCount - 1 do
      with PMapiFileDesc(PAnsiChar(AttachmentBuffer) + (I * ES))^ do StrDispose(lpszPathName);

    //Deallocate buffer
    FreeMem(AttachmentBuffer, AttachmentCount * ES);
  end;


begin

  with MAPIMessage do begin
    ulReserved         := 0;
    lpszSubject        := PAnsiChar(Subj);
    lpszNoteText       := PAnsiChar(Body);
    lpszMessageType    := nil;
    lpszDateReceived   := nil;
    lpszConversationID := nil;
    flFlags            := 0;
    lpOriginator       := nil;

    AllocateRecipients(RB, RC);

    nRecipCount        := RC;
    lpRecips           := RB;

    AllocateAttachments(AB, AC);

    nFileCount         := AC;
    lpFiles            := AB;
  end;

  //Send mail
  Result := MAPISendMail(0, Application.Handle, MAPIMessage, MAPIFlags, 0);

  //Deallocate buffers
  DeallocateRecipients(RB, RC);
  DeallocateAttachments(AB, AC);
end;


end.