Полезняшки. DevExpress Custom draw cell - подсветка поисковой строки в ячейке

Подсветка поисковой строки в CxGrid ячейке

код для включения подсветки

procedure TForm3.DBBTCustomDrawCell(Sender: TcxCustomGridTableView;
  ACanvas: TcxCanvas; AViewInfo: TcxGridTableDataCellViewInfo;
  var ADone: Boolean);
var
  idx_DATA2       : Integer;
begin
  {Основной обработчик отрисовки}
  TMyDrawEvent.MyCustomDrawCell(Sender,ACanvas,AViewInfo,ADone);

  idx_DATA2       := GetIndex('_DATA2');
  if AViewInfo.Item.Index = idx_DATA2 then
     TMyDrawEvent.HighlightMiltiTextUseCustomDrawCell(Edit1.Text,
                                                 Sender, ACanvas, AViewInfo, ADone);
end;

Класс

Type
  TMyDrawEvent = class(TObject)
  public
   class procedure MyCustomDrawCell(Sender: TcxCustomGridTableView;
                          ACanvas: TcxCanvas;
                          AViewInfo: TcxGridTableDataCellViewInfo;
                         var ADone: Boolean);   
   // Отрисовка подсветки текста при поиске
   class procedure HighlightMiltiTextUseCustomDrawCell(AText: string;
                          Sender: TcxCustomGridTableView;
                          ACanvas: TcxCanvas;
                          AViewInfo: TcxGridTableDataCellViewInfo;
                          var ADone: Boolean);
  end;


*****

class procedure TMyDrawEvent.HighlightMiltiTextUseCustomDrawCell(AText: string;
  Sender: TcxCustomGridTableView; ACanvas: TcxCanvas;
  AViewInfo: TcxGridTableDataCellViewInfo; var ADone: Boolean);
var
  R: TRect;
  H: Integer;
  brushColor, fontColor: TColor;

  procedure CanvasInitDefault;
  begin
    ACanvas.Font.Style := [];
    ACanvas.Font.Color  := fontColor;
    ACanvas.Brush.Color := brushColor; //$0080FF80;
  end;

  procedure CanvasInitSelection;
  begin
    ACanvas.Font.Style := [];
    ACanvas.Font.Color  := clBlack;  //Sender.LookAndFeelPainter.DefaultSelectionTextColor;
    ACanvas.Brush.Color := clYellow; //Sender.LookAndFeelPainter.DefaultSelectionColor;
  end;

  function GetLengthBlock(Text : String; CanvasSize : Integer; out BlockWidth : Integer) : Integer;
  var
   I : Integer;
   S : string;
  begin
   Result    := 0;
   BlockWidth:= 0;

   I := Length(Text);
   while true do
   begin
       if I < 0  then Exit;
       S := Copy(Text, 1, I);
       BlockWidth := ACanvas.TextWidth(S);
       if BlockWidth > CanvasSize then
       begin
          Dec(I);
          Continue;
       end
       else
       begin
          Result := I;
          exit;
       end
   end;
  end;

  procedure SetRectOutput(var OutRect: TRect; const AreaRect : TRect; const wBlock: Integer);
  begin
   OutRect.Left   := AreaRect.left;
   OutRect.Top    := AreaRect.Top;
   OutRect.Width  := wBlock;
   OutRect.Bottom := AreaRect.Top + H;
  end;

var
  AreaRect, OutRect: TRect;
  posFind, lT, lSearch, wSearch, wS: Integer;
  sTextAll, sSearch,  sBlock, S: string;
  p, wBlock : Integer;
begin
  R          := AViewInfo.Bounds; // Общая область
  sTextAll   := AViewInfo.Text;   // Текст общий

  sSearch := AText; // поисковый запрос
  posFind := AnsiPos(AnsiUpperCase(sSearch), AnsiUpperCase(sTextAll));
  if posFind < 1 then  Exit;

  ADone := True;

  // Цвет и канва
  fontColor  := ACanvas.Font.Color;
  brushColor := ACanvas.Brush.Color;

  // Затираем все
  ACanvas.FillRect(R);
  // Высота текста
  H  := ACanvas.TextHeight(sTextAll);
  // Основная область отрисовки
  AreaRect.Left   := R.Left + 1;
  AreaRect.Top    := R.Top  + 2;
  AreaRect.Right  := R.Right - 1;
  AreaRect.Bottom := R.Bottom - 2;

  CanvasInitDefault;
  sBlock := Copy(sTextAll, 1, PosFind-1);
  if sBlock <> '' then
  begin
      repeat
        // Нужно определить сколь символов влезает в блок текста
        p := GetLengthBlock(sBlock, AreaRect.Width, wBlock);
        s := Copy(sBlock,1, p);

        SetRectOutput(OutRect, AreaRect,wBlock);
        ACanvas.Canvas.TextRect(OutRect, OutRect.Left, OutRect.Top, s);

        Delete(sBlock, 1, p);
        // текст в основной блок не влез, сдвигает вниз
        if sBlock <> '' then
        begin
           Inc(AreaRect.Top, H);
           AreaRect.Left := R.Left + 1;
           if (AreaRect.Bottom - AreaRect.Top) < H then Exit;
        end
        else
           Inc(AreaRect.Left, wBlock)
      until (sBlock = '');
  end;

  CanvasInitSelection;
  sBlock := sSearch;
  repeat
    // Нужно определить сколь символов влезает в блок текста
    p := GetLengthBlock(sBlock, AreaRect.Width, wBlock);
    s := Copy(sBlock,1, p);

    SetRectOutput(OutRect, AreaRect,wBlock);
    ACanvas.Canvas.TextRect(OutRect, OutRect.Left, OutRect.Top, s);

    Delete(sBlock, 1, p);
    // текст в основной блок не влез, сдвигает вниз
    if sBlock <> '' then
    begin
       Inc(AreaRect.Top, H);
       AreaRect.Left := R.Left + 1;
       if (AreaRect.Bottom - AreaRect.Top) < H then Exit;
    end
    else
       Inc(AreaRect.Left, wBlock)
  until (sBlock = '');

  CanvasInitDefault;
  sBlock := Copy(sTextAll, PosFind + Length(sSearch), Length(sTextAll));
  if sBlock <> '' then
  begin
   repeat
    // Нужно определить сколь символов влезает в блок текста
    p := GetLengthBlock(sBlock, AreaRect.Width, wBlock);
    s := Copy(sBlock,1, p);

    SetRectOutput(OutRect, AreaRect,wBlock);
    ACanvas.Canvas.TextRect(OutRect, OutRect.Left, OutRect.Top, s);

    Delete(sBlock, 1, p);
    // текст в основной блок не влез, сдвигает вниз
    if sBlock <> '' then
    begin
       Inc(AreaRect.Top, H);
       AreaRect.Left := R.Left + 1;
       if (AreaRect.Bottom - AreaRect.Top) < H then Exit;
    end
    else
       Inc(AreaRect.Left, wBlock)
   until (sBlock = '');
  end;
end;

Полезняшки: CadesCom. Подписание и проверка XML (XMLDSig) по GOST R 34.10-2012 256 bit

unit main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, CAdESCOM_TLB, CAPICOM_TLB, ComObj,
  ActiveX, oleauto, EncdDecd;

Const
 SUBJECT = 'Иванов Иван Иванович';

 CAPICOM_CURRENT_USER_STORE = 2;
 CAPICOM_MY_STORE = 'My';
 CAPICOM_STORE_OPEN_MAXIMUM_ALLOWED = 2;
 CAPICOM_CERTIFICATE_FIND_SUBJECT_NAME = 1;
 CADESCOM_XML_SIGNATURE_TYPE_ENVELOPED = 0;
 CADESCOM_XML_SIGNATURE_TYPE_ENVELOPING = 1;

 // Криптопровайдер: Crypto-Pro GOST R 34.10-2012 Cryptographic Service Provider
 signMethod   = 'urn:ietf:params:xml:ns:cpxmlsec:algorithms:gostr34102012-gostr34112012-256';
 digestMethod = 'urn:ietf:params:xml:ns:cpxmlsec:algorithms:gostr34112012-256';

type
  TForm3 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    Procedure AddLog(S : String);
  public
    { Public declarations }
    function GetCertificateBySubjectName(certSubjectName : String) : ICPCertificate;
    function SignCreate(Certificate : ICPCertificate; dataToSign : WideString) : WideString;
    function Verify(SignedMessage : WideString)  : boolean;
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

procedure TForm3.AddLog(S: String);
begin
 Memo1.Lines.Add(S);
end;

procedure TForm3.Button1Click(Sender: TObject);
var
 Certificate : ICPCertificate;
 fnXMLSource, fnXMLSigned : string;
 SL : TStringList;
begin
 Memo1.Clear;
 Certificate := GetCertificateBySubjectName(SUBJECT);
 if Certificate= nil then Exit;

 fnXMLSource := ExtractFilePath(ParamStr(0)) + 'XML\test_canon.xml';
 fnXMLSigned := ExtractFilePath(ParamStr(0)) + 'XML\test_signed.xml';

 try
   SL := TStringList.Create;
   if FileExists(fnXMLSource) then
   begin
     SL.LoadFromFile(fnXMLSource);
     AddLog('-------------------------------------------------------------------');
     AddLog('XML для подписания');
     AddLog('-------------------------------------------------------------------');
     AddLog(SL.Text);

     SL.Text := SignCreate(Certificate, SL.Text);
     AddLog('-------------------------------------------------------------------');
     AddLog('XML sign');
     AddLog('-------------------------------------------------------------------');
     AddLog(SL.Text);
     SL.SaveToFile(fnXMLSigned);
   end;

   if FileExists(fnXMLSigned) then
   begin
     SL.LoadFromFile(fnXMLSigned);
     AddLog('-------------------------------------------------------------------');
     AddLog('XML проверка подписания');
     AddLog('-------------------------------------------------------------------');
     if Verify(SL.Text) then
        AddLog('Подпись валидна!')
     else
        AddLog('Подпись недействительна!')
   end;
 finally
   if Assigned(SL) then FreeAndNil(SL);
 end;
end;

function TForm3.GetCertificateBySubjectName(certSubjectName : String): ICPCertificate;
var
 Store : CPStore;  //IStore3
 Certificates : ICertificates2;
begin
 Store := CoCPStore.Create;
 Store.Open(CAPICOM_CURRENT_USER_STORE, CAPICOM_MY_STORE, CAPICOM_STORE_OPEN_MAXIMUM_ALLOWED);
 Certificates := Store.Certificates as ICertificates2;
 Certificates.Find(CAPICOM_CERTIFICATE_FIND_SUBJECT_NAME, certSubjectName, True);
 if Certificates.Count = 0 then
 begin
    AddLog('Сертификат не найден: SN=' + certSubjectName);
    Result := nil;
    Exit;
 end
 else
 begin
    AddLog('Сертификат найден: SN=' + certSubjectName);
    Result := IInterface(Certificates.Item[1]) as ICPCertificate;
    AddLog('Валидность: ' + DateToStr(Result.ValidFromDate) + '-' + DateToStr(Result.ValidToDate));
    Store.Close();
 end;
end;

function TForm3.SignCreate(Certificate: ICPCertificate; dataToSign: WideString): WideString;
var
 Signer : ICPSigner;
 SignedXML : ISignedXML;
begin
 // Создаем объект CAdESCOM.CPSigner
 Signer := CoCPSigner.Create;
 Signer.Certificate := Certificate;

 // Создаем объект CAdESCOM.SignedXML
 SignedXML := CoSignedXML.Create;
 SignedXML.Content := dataToSign;
 // Указываем тип подписи - в данном случае вложенная
 SignedXML.SignatureType   := CADESCOM_XML_SIGNATURE_TYPE_ENVELOPED;
 // Указываем алгоритм подписи
 SignedXML.SignatureMethod := signMethod;
 // Указываем алгоритм хэширования
 SignedXML.DigestMethod    := digestMethod;
 try
   Result := SignedXML.Sign(Signer, '');
 except
   on E: Exception do
   begin
      AddLog('Ошибка подписания: ' + E.Message);
   end;
 end;
end;

function TForm3.Verify(SignedMessage : WideString)  : boolean;
var
 SignedXML : ISignedXML;
begin
 // Создаем объект CAdESCOM.SignedXML
 SignedXML := CoSignedXML.Create;
 try
   SignedXML.Verify(SignedMessage,'');
   Result := true;
 except
   on E: Exception do
   begin
      AddLog('Ошибка проверки ЭЦП: ' + E.Message);
      Result := False;
   end;
 end;
end;

end.

OTL на заметку: параллельное выполнение функции в потоках, каждый со своими параметрами

Сама идея:

Запустит несколько паралельных потоков для выполнения некой общей задачи, причем каждый поток должен получить свои параметры для работы. 

Применение на будущее: например одновременно сканирование файлов в нескольких директориях, понятно что имя директории для сканирования для каждого потока должно быть свое. Хоть и алгоритм сканирования общий. 

Демо: передача параметров через блокирующую коллекцию, использование параметров через record (обертка), передаются два параметра частота и длительность, функция выполняющаяся в потоке получает эти параметры и 10 раз проигрывает сигнал с такой частотой и длительностью.

Потоков на запуск 4, работают одновременно 2....

unit Main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
  OTLParallel, OtlTaskControl, OtlCollections, OtlCommon;

type
  TParametersForProc = record
                        Hz : Integer;
                        Duration : Integer;
                       end;

  TForm3 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    Join : IOmniParallelJoin;
    CollectionParams : IOmniBlockingCollection;
  public
    { Public declarations }
    procedure JoinProcExecute;
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

procedure Go(Hz, Duration : Integer);
var
  I: Integer;
begin
 for I := 0 to 10 do
 begin
     Sleep(1000);
     Winapi.Windows.Beep(Hz, Duration);
 end
end;

procedure TForm3.JoinProcExecute;
var
 Value     : TOmniValue;
 ParamProc : TParametersForProc;
begin
 // Взять из коллекции параметры
 CollectionParams.Take(Value);
 // Преобразовать обратно
 ParamProc := Value.Unwrap;
 // Запустить процедуру с переданными  параметрами
 Go(ParamProc.Hz, ParamProc.Duration);
 // вывести параметры
 Memo1.Lines.Add(Format('Hz : %d; duration: %d',[ParamProc.Hz, ParamProc.Duration]));
end;

procedure TForm3.Button1Click(Sender: TObject);
var
 arrayProc : array of TProc;
 I: Integer;
 Value : TOmniValue;
 ParamProc : TParametersForProc;
begin
 CollectionParams := TOmniBlockingCollection.Create;
 SetLength(arrayProc, 4);
 for I := Low(arrayProc) to High(arrayProc) do
 begin
     // Для каждого потока свои параметры, поэтому перед запуском потоков
     // в коллекцию добавляем параметры, функция выполняющаяся в потоке будет
     // брать параметр для себя из коллекции
     ParamProc.Hz       := (I+1) * 1000;
     ParamProc.Duration := (I+1) * 20;
     // обернуть рекорд к TOmniValue
     Value := TOmniValue.Wrap(ParamProc);
     // Добавим в параметры
     CollectionParams.Add(Value);
     arrayProc[i] := JoinProcExecute;
 end;
 CollectionParams.CompleteAdding;       // добавление завершено
 // NumTasks(2) - два потока выполняются одновременно
 Join := Parallel.Join(arrayProc).NumTasks(2).NoWait.Execute; // запуск параллельных потоков
end;

end.

Полезняшки: Использование анонимных методов в Delphi в качестве обработчиков событий....

Сама идея:

Использовать классические обработчики событий, через анонимные методы. То есть сократить количество кода в обработчиках, там где реакцией на событие должно быть исполнение немногих строк кода. 
Например, по событию нужно просто подать сигнал, или вывести сообщение.
Избавиться от объявления процедур обработки в классе, вызывающих замусоривание листинга.

unit Main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TOnNotify = reference to procedure; // анонимный метод

  TDemoNotify = class
  private
    fOnNotify: TOnNotify;
  public
   procedure SendNotify;
  published
   property OnNotify : TOnNotify read  fOnNotify write fOnNotify;
  end;

  TfrmNotify = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    demo :  TDemoNotify;
  public
    { Public declarations }
    procedure _onNotify;
  end;

var
  frmNotify: TfrmNotify;

implementation

{$R *.dfm}

{ TDemoNotify }

procedure TfrmNotify.FormCreate(Sender: TObject);
begin
 demo := TDemoNotify.Create;
end;

procedure TfrmNotify.FormDestroy(Sender: TObject);
begin
 if Assigned(demo) then FreeAndNil(demo);
end;

procedure TfrmNotify._onNotify;
begin
 ShowMessage('Сработало классика!');
end;

procedure TDemoNotify.SendNotify;
begin
 if Assigned(fOnNotify) then fOnNotify;
end;


procedure TfrmNotify.Button1Click(Sender: TObject);
begin
 // Классический подход
 demo.OnNotify := _onNotify;
 demo.SendNotify;
end;

procedure TfrmNotify.Button2Click(Sender: TObject);
begin
 // Обработчик через анонимную функцию
 demo.OnNotify :=
  procedure
  begin
   ShowMessage('Сработало анонимная процедура!');
  end;
 demo.SendNotify;
end;

end.

Delphi и Android. Странная бага в TSQLConnection dbExpress .

Решил прикрутить SQLite к программе на андроид.
Делал все как по инструкции Using SQLite (iOS_and_Android), однако когда у свойства Connected
объекта TSQLConnection выставляю True и запускаю прогу на устройство, программа android  уходит в черный экран и зависает до появления предложения ОС Android о закрытии зависшего приложения.

При этом в дизайнере все показывается нормально (я имею ввиду информацию с БД - в List.Item - Дачный дом берется из записи таблицы БД). Если отключить подключение к БД (Connected - False) и запустить приложение то все нормально.
В Deployment тоже все настроено по инструкции:

Код подключения для к БД для Android аналогичный примеру.

procedure TfrmMain.SQLConnectionBeforeConnect(Sender: TObject);
begin
  {$IF DEFINED(iOS) or DEFINED(ANDROID)}
  SQLConnection.Params.Values['ColumnMetadataSupported'] := 'False';
  SQLConnection.Params.Values['Database'] :=
      TPath.Combine(TPath.GetDocumentsPath, 'Ksital.s3db');
  {$ENDIF}
end;

В общем третий день чудеса. Может кто встречался с такой проблемой?

PS. Скриншот с эмулятора. 

Android и Delphi XE. Хранение пользовательских данных Preferens. Аналог INI-файлов Windows

Пользовательские данные в Androide могут хранится либо в пользовательских файлах Preferens либо в БД Sql Lite, либо в обычных файлах  (например на SD-карте). Для начала рассмотрим хранение в пользовательских файлах Preferens поддерживающихся OC Android.Код простой:

unit Main;
 
interface
 
uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls,
  FMX.Edit, FMX.DateTimeCtrls,
  AndroidApi.Jni.JavaTypes, AndroidApi.Jni.App,
  AndroidApi.Jni.GraphicsContentViewText,
  FMX.Helpers.Android;
 
type
  TForm1 = class(TForm)
    Edit1: TEdit;
    NumberBox1: TNumberBox;
    CalendarEdit1: TCalendarEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    Prefs: JSharedPreferences;
  public
    { Public declarations }
    Procedure Save;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.fmx}
 
procedure TForm1.Button1Click(Sender: TObject);
begin
 Save;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  // Cохранение данных. Сначала с помощью метода getSharedPreferences получаем объект sPref класса SharedPreferences,
  // который позволяет работать с данными (читать и писать). Константа MODE_PRIVATE используется для настройки доступа и означает,
  // что после сохранения, данные будут видны только этому приложению.
 
  // MyData - имя файла для хранения данных.
  Prefs  := SharedActivity.getSharedPreferences(StringToJString('MyData'),  TJActivity.JavaClass.MODE_PRIVATE);
 
  Edit1.Text  := JStringToString(Prefs.getString(StringToJString('Edit1'), StringToJString('')));
  NumberBox1.Value := Prefs.getFloat(StringToJString('NumberBox1'), 0);
  CalendarEdit1.Date := StrToDate(
                  JStringToString(Prefs.getString(StringToJString('CalendarEdit1'), StringToJString('10.01.2014'))));
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
 Save;
end;
 
procedure TForm1.Save;
var
  Editor: JSharedPreferences_Editor;
begin
  // Чтобы редактировать данные, необходим объект Editor – получаем его из sPref.
  Editor := Prefs.edit;
  Editor.putString(StringToJString('Edit1'), StringToJString(Edit1.Text));
  Editor.putFloat(StringToJString('NumberBox1'), NumberBox1.Value);
  Editor.putString(StringToJString('CalendarEdit1'), StringToJString(DateToStr(CalendarEdit1.Date)));
  Editor.apply;
end;

Помимо getSharedPreferences использовать getPreferences, если хотите не выдумывать имя файла. Имя файла будет задана автоматом по имени текущего окна.
Использовать getSharedPreferences, нужно когда данные - общие для нескольких окон, а также если сами хотите выбирать имя файла для сохранения.

Полезняшки. Shell-расширения для файлов Delphi и Lazarus

Случайно нашел интересный проект http://code.google.com/p/delphi-dev-shell-tools/
который в контекстное меню для файлов .pas, .dpr, .inc, .pp, .dpk, . dproj, .frm, .fmx, .rc  добавляет различные действия сильно облегчающие жизнь Delphi/Lazarus-программисту.
Причем все это гибко настраивается.