Tag: code

In Friday in our SIM (Shareware Information System) I added the possibility to drag’n’drop the mail content from external mailer (MS Outlook, Outlook Express etc)

To add this feature you need:
1. declare two new Cliboard formats that need to be registered:

var
  CF_FILECONTENTS,
  CF_FILEDESCRIPTOR: Integer;initialization

  // Initialize the OLE libraries
  OleInitialize(nil);

  // Register the clipboard formats that we need to handle in the
  // OLE drag drop operation
  CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  CF_FILEDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);

finalization
  OleUninitialize;

2. in OnCreate event for your form allow window to accept drop events. Just execute the next code:

OleCheck(RegisterDragDrop(Handle, Self));

3. for your form you need implement a few methods for IDropTarget interface:

type
  TfrmOrderWizard = class(TForm, IDropTarget)
  ...
  private
    { IDropTarget }
    function DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
                       var dwEffect: Longint): HResult; stdcall;
    function DragOver(grfKeyState: Longint; pt: TPoint;
                      var dwEffect: Longint): HResult; stdcall;
    function DragLeave: HResult; stdcall;
    function Drop(const dataObj: IDataObject;
                  grfKeyState: Longint; pt: TPoint;
                  var dwEffect: Longint): HResult; stdcall;
    { IUnknown
     Ignore referance counting }
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    ...

where:

function TfrmOrderWizard.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
     var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_COPY;
  Result  := S_OK;
end;

function TfrmOrderWizard.DragOver(grfKeyState: Longint; pt: TPoint;
     var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_COPY;
  Result := S_OK;
end;

function TfrmOrderWizard.DragLeave: HResult;
begin
  Result := S_OK;
end;

function TfrmOrderWizard._AddRef: Integer;
begin
   Result := 1;
end;

function TfrmOrderWizard._Release: Integer;
begin
  Result := 1;
end;

function TfrmOrderWizard.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
  var dwEffect: Longint): HResult;
const
  PT_TSTRING = ULONG(30);
  PT_UNICODE = ULONG(31);
  PR_BODY    = PT_TSTRING or ($1000 shl 16);
  PR_BODY_W  = PT_UNICODE or ($1000 shl 16);
var
  aFmtEtc: TFORMATETC;
  aStgMed, stgmitem: TSTGMEDIUM;
  pData: PChar;
  pfgd: PFileGroupDescriptor;
  dwCount, dwfetch: Integer;

  stat: STATSTG;
  pstg: IStorage;
  pstm: IStream;
begin
  {Make certain the data rendering is available}
  if (dataObj = nil) then
    raise Exception.Create('IDataObject-Pointer is not valid!');
  with aFmtEtc do
  begin
    cfFormat := CF_TEXT;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  {Get the data}
  OleCheck(dataObj.GetData(aFmtEtc, aStgMed));
  try
    {Lock the global memory handle to get a pointer to the data}
    pData := GlobalLock(aStgMed.hGlobal);
    { Replace Text }
    MemoOrder.Text := pData;
  finally
    {Finished with the pointer}
    GlobalUnlock(aStgMed.hGlobal);
    {Free the memory}
    ReleaseStgMedium(aStgMed);
  end;

  // Get the file descriptors
  with aFmtEtc do
  begin
    cfFormat := CF_FILEDESCRIPTOR;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  OleCheck(dataObj.GetData(aFmtEtc, aStgMed));
  try
    pfgd := PFileGroupDescriptor(GlobalLock(aStgMed.hGlobal));
    // Iterate each of the files
    for dwCount := 0 to pfgd.cItems-1 do
    begin
      // Set up for getting the file data
      with aFmtEtc do
      begin
        cfFormat := CF_FILECONTENTS;
        ptd := nil;
        dwAspect := DVASPECT_CONTENT;
        lindex := dwCount;
        tymed := TYMED_ISTORAGE;
      end;
      if (dataObj.GetData(aFmtEtc, stgmitem) = S_OK) then
      begin
        // IStorage (handle the outlook item)
        pstg := IStorage(stgmitem.stg);
        // Hard coded to open the outlook message item stream
        if (pstg.OpenStream('__substg1.0_1000001F', nil, STGM_SHARE_EXCLUSIVE or STGM_READ, 0, pstm) = S_OK) or
           (pstg.OpenStream('__substg1.0_1000001E', nil, STGM_SHARE_EXCLUSIVE or STGM_READ, 0, pstm) = S_OK) then
        begin
          pstm.Stat(stat, STATFLAG_DEFAULT);
          pData := AllocMem(stat.cbSize);
          try
            pstm.Read(pData, stat.cbSize, @dwFetch);
            // Set the msg body
            MemoOrder.Lines.Add(String(pData));
          finally
            // Free buffer memory
            FreeMem(pData);
          end;
          // Free the stream
          pstm := nil;
        end;
        // Free the storage
        pstg := nil;
        // Release the storage medium
        ReleaseStgMedium(stgmitem);
      end;
    end;
  finally
    // Unlock the memory
    GlobalUnLock(aStgMed.hGlobal);
    // Release the storage medium
    ReleaseStgMedium(aStgMed);
  end;

  Result := S_OK;
end;

{returns an integer value (0 to 100) rating the key quality}
function PasswordQuality(const strPassword: string): Integer;
var
  i, j, intLen: Integer;
  QC: Double;
  boolUpper, boolLower: Boolean;
begin
  Result := 0;

  intLen := Length(strPassword);
  QC := 4*intLen;

  {at least 5 characters in password required}
  if (intLen > 4) then
  begin
    {check for repetitions (abcabc, aaaaa, 121212, etc}
    for i := 1 to (intLen div 2) do
    begin
      j := i+1;
      while (j <= intLen ) do
      begin
        if (Copy(strPassword, 1, i) = Copy(strPassword, j, i)) then exit;
        Inc(j, i);
      end
    end;

    {check the upper/lower cases}
    boolUpper := False;
    boolLower := False;
    for i := 1 to intLen do
    begin
      if (strPassword[i] in [‘A’..’Z’]) then
        boolUpper := True;
      if (strPassword[i] in [‘a’..’z’]) then
        boolLower := True;
    end;
    if boolUpper and boolLower then
      QC := 1.5*QC;

    {check the numbers}
    for i := 1 to intLen do
    begin
      if (strPassword[i] in [‘0’..’9′]) then
        if (boolUpper or boolLower) then
          QC := 1.5*QC;
    end;

    {check the signs}
    for i := 1 to intLen do
    begin
      if (strPassword[i] < ‘0’) or (strPassword[i] > ‘z’) or
         ((strPassword[i] > ‘9’) and (strPassword[i] < ‘A’)) then
        QC := 1.5*QC;
    end;

    if (QC > 100) then
      QC := 100;
    Result := Trunc(QC);
  end;
end;

Sample to use:
  i := PasswordQuality(edPassword.Text);
  lblPWQuality.Caption := IntToStr(i);
  if (i < 30) then
    lblPWQuality.Font.Color := clRed
  else
  if (i < 60) then
    lblPWQuality.Font.Color := clYellow
  else
    lblPWQuality.Font.Color := clWindowText;

Returns true if the file specified is a real CLR type, otherwise false is returned.

function IsDotNetAssembly(const AFileName: string): Boolean;
var
  fs: TFileStream;
  peHeader, peHeaderSignature,
  timestamp, pSymbolTable, noOfSymbol: dWord;
  machine, sections, optionalHeaderSize, characteristics: Word;
  dataDictionaryRVA: array[0..14] of dWord;
  dataDictionarySize: array[0..14] of dWord;
  i: Integer;
begin
  fs := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    //PE Header starts @ 0x3C (60). Its a 4 byte header.
    fs.Seek($3C, soFromBeginning);
    fs.Read(peHeader, SizeOf(peHeader));
    //Moving to PE Header start location...
    fs.Position := peHeader;
    fs.Read(peHeaderSignature, SizeOf(peHeaderSignature));
    //We can also show all these value, but we will be
    //limiting to the CLI header test.
    fs.Read(machine, SizeOf(machine));
    fs.Read(sections, SizeOf(sections));
    fs.Read(timestamp, SizeOf(timestamp));
    fs.Read(pSymbolTable, SizeOf(pSymbolTable));
    fs.Read(noOfSymbol, SizeOf(noOfSymbol));
    fs.Read(optionalHeaderSize, SizeOf(optionalHeaderSize));
    fs.Read(characteristics, SizeOf(characteristics));

    { Now we are at the end of the PE Header and from here, the
    PE Optional Headers starts...
    To go directly to the datadictionary, we'll increase the
    stream's current position to with 96 (0x60). 96 because,
    28 for Standard fields
    68 for NT-specific fields
    From here DataDictionary starts...and its of total 128 bytes.
    DataDictionay has 16 directories in total,
    doing simple maths 128/16 = 8.
    So each directory is of 8 bytes.

    In this 8 bytes, 4 bytes is of RVA and 4 bytes of Size.
    btw, the 15th directory consist of CLR header! if its 0,
    it is not a CLR file }

    fs.Seek($60, soFromCurrent);
    for i := 0 to 14 do
    begin
      fs.Read(dataDictionaryRVA[i], SizeOf(dataDictionaryRVA[i]));
      fs.Read(dataDictionarySize[i], SizeOf(dataDictionarySize[i]));
    end;
  finally
    fs.Free
  end;
  Result := (dataDictionaryRVA[14] <> 0)
end;

Created in Delphi from http://www.codeproject.com/KB/cs/AutoDiagrammer.aspx

function TranslateCharsetInfo(lpSrc: integer;
  var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall;
  external ‘gdi32.dll’ name ‘TranslateCharsetInfo’;

function GetDefaultCharset: TFontCharset;
var
  dwCodePage: dWord;
  CharSetInfo: TCharSetInfo;
begin
  {get default codepage}
  dwCodePage := StrToIntDef(GetLocaleStr(GetUserDefaultLCID, LOCALE_IDEFAULTANSICODEPAGE, ”), 0);
  if dwCodePage = 0 then
    dwCodePage := StrToIntDef(GetLocaleStr(GetSystemDefaultLCID, LOCALE_IDEFAULTANSICODEPAGE, ”), GetACP());
  {convert codepage into charset}
  if TranslateCharsetInfo(dwCodePage, CharSetInfo, TCI_SRCCODEPAGE) then
    Result := CharSetInfo.ciCharset
  else
    Result := 0
end;

For example, if you have some TRichEdit instance and you want to change some substring there but do not change the formatting (color/font etc) for this text, you may use this code:

var
  i: Integer;
begin
  if SameText(strNewValue, strOldValue) then exit;
  repeat
    i := Pos(strOldValue, yourRichEdit.Lines.Text);
    if (i > 0) then
    begin
      yourRichEdit.SelStart := i-1;
      yourRichEdit.SelLength := Length(strOldValue);
      yourRichEdit.SelText := strNewValue;
    end;
  until (i = 0)
end;

PS: if use the next code, then formatting will be lost:
yourRichEdit.Lines.Text := StringReplace(yourRichEdit.Lines.Text, strOldValue, strNewValue, [rfIgnoreCase, rfReplaceAll])