onsdag den 30. november 2011

Slet tomme mapper

I dag stod jeg over for en sjov udfordring på arbejde. Jeg havde en mappe struktur med en masse filer i, som skulle lægges i en database. Det i sig selv er ikke ret svært, og er ikke relevant i forhold til mit indlæg. Det, der er meget mere interessant, er BAGEFTER - når der skal ryddes op på harddisken. Jeg ønsker at slette alle de tomme mapper, men kun de tomme mapper. Hvis der ligger en eller flere filer i en mappe eller dens under mappe, skal mappen ikke slettes.

Jeg startede min søgen i IOUtils.pas, som kom i Delphi 2009. Helt konkret kiggede jeg på TDirectory, hvori jeg forventede at finde noget der kunne bruges til formålet. Det var nu ikke tilfældet, så måtte jeg skrive en selv.

Det vil dette blogindlæg handle om.

Først skal jeg have sat en test case op (endnu et fint dansk ord ;o)). Jeg har lavet den følgende mappestruktur i roden af mit D-drev:


Mappenavnene fortæller om eventuelt indhold.

Jeg ønsker at bruge den følgende syntaks: TDirectory.DeleteEmptyDirectories('D:\Test');
Primært fordi jeg synes metoden logisk hører hjemme på TDirectory.

Type definitionen kommer til at se sådan ud:

uses
  IOUtils, Types;

type
  TTDirectoryHelper = record helper for TDirectory
  public
    class function DeleteEmptyDirectories
    (
      const aRoot: string; aSearchPattern: string = '*'; 
       aSearchOption: TSearchOption = TSearchOption.soAllDirectories
    ): TStringDynArray; static;
  end;
På TDirectory er der nogle metoder jeg vil benytte mig af :

  • TDirectory.Exists()
    Skal bruges til at tjekke eksistensen af en given sti 
  • TDirectory.GetDirectories()
    Skal bruges til at hente alle under mapper i forhold til en given sti.
  • TDirectory.IsEmpty()
    Skal bruges til at tjekke om en folder er tom eller ej
  • TDirectory.Delete()
    Sletter en mappe, samt eventuelle under mapper
Med disse byggesten i hånden er det "bare" at gå i gang.

Metoden er meget kort fortalt, at løbe en mappe med under mapper igennem. Det kan gøres med TDirectory.GetDirectories(aRoot, aSearchPattern, aSearchOption). For hver af disse mapper skal man tjekke om de eventuelt er tomme, og i så fald slette dem. Hvis man støder på en mappe som ikke er tom, skal denne føjes til en liste så man undgår et uendeligt loop.

Personligt kan jeg nemt miste overblikket over en algoritme, hvis den bliver penslet ud i tekst. Så det vil jeg undlade her, blot vise koden i sin fulde udstrækning, og så i øvrigt henvise til kommentarene i koden.

unit FileAndFolderUtilsU;
interface

uses
  IOUtils, Types;

type
  TTDirectoryHelper = record helper for TDirectory
  public
    class function DeleteEmptyDirectories
    (
      const aRoot: string; aSearchPattern: string = '*'; 
       aSearchOption: TSearchOption = TSearchOption.soAllDirectories
    ): TStringDynArray; static;
  end;
implementation uses Sysutils, Classes; { TTDirectoryHelper }
class function TTDirectoryHelper.DeleteEmptyDirectories
(
  const aRoot: string; aSearchPattern: string = '*'; 
   aSearchOption: TSearchOption = TSearchOption.soAllDirectories
): TStringDynArray; static;
var Directory, Tmp: string; Directories: TStringDynArray; Stop: Boolean; DirBuffer: TStringList; begin // Hvis det ikke en en gyldig sti, så exit if not TDirectory.Exists(aRoot) then exit; DirBuffer := TStringList.Create; { DirDuffer skal bruges til at samle alle de mapper op,
    som enten ikke er tomme, eller det ikke lykkes at slette.
    Dette gøres fordi det skal bruges en "stop kondition",
    så vi undgår uendeligt loop: Hvis de foldere der er tilbage
    i vores struktur alle findes i listen, så er der ikke mere 
    vi kan gøre.
  }
  try
    Directories := TDirectory.GetDirectories(
      aRoot, aSearchPattern, aSearchOption);
    Stop := Length(Directories) = 0;

    if Stop then
      TDirectory.Delete(aRoot);

    {
      Hent en liste over alle subfolders.
      Hvis der ingen er, så slet "dig selv" og forlad funktionen
    }
    while not Stop do
    begin
      for Directory in Directories do
        if TDirectory.Exists(Directory) then
        {
          Det er nødvendigt at tjekke på mappens fortsatte eksistens
          idet funktionen her er rekursiv, og mappen kan være slettet
          i en af de andre rekursioner.
        }
          if TDirectory.IsEmpty(Directory) then
          begin
            TDirectory.Delete(Directory, True); //Slet den tomme folder.
            {
              Hvis den overordnet mappe nu er tom, skal den slettes.
              Det gøres ved at kalde funktionen igen, så herved slettes
              eventuelle mapper som NU er tomme som følge af den nylige
              slettede mappe.
            }
            DeleteEmptyDirectories(aRoot, aSearchPattern, aSearchOption);
            if TDirectory.Exists(Directory) then
              DirBuffer.Add(Directory);
            {
              Hvis folderen fortsat eksisterer efter seltning, er det fordi
              den er låst af en anden process. I det tilfælde tilføjes den 
              bare på DirBuffer.
            }
          end
          else
            DirBuffer.Add(Directory);
           //Hvis mappen ikke er tom skal den også bare tilføjes til DirBuffer.

      Directories := TDirectory.GetDirectories(
        aRoot, aSearchPattern, aSearchOption);
     //Hent en liste over alle de foldere der nu er tilbage

      Stop := True;
      for Directory in Directories do
        Stop := Stop and (DirBuffer.IndexOf(Directory) >= 0);
      //Hvis alle de resterende mapper enten er i brug eller har et indhold, så exit.

      DirBuffer.Clear;
      //Ryd DirBuffer til en eventuel ny omgang.
    end;
  finally
    FreeAndNil(DirBuffer); //Oprydning.
  end;

  //Returner en liste over de mapper der er tilbage - altså dem 
  //der ikke kunne slettes (var i brug) eller ikke var tomme.
  Result := TDirectory.GetDirectories(aRoot, aSearchPattern, aSearchOption);
end;

end.



Til sidst er der blot tilbage at kalde funktionen:


uses
  IoUtils, FileAndFolderUtilsU;

procedure TForm1.FormCreate(Sender: TObject);
begin
  TDirectory.DeleteEmptyDirectories('D:\Test');
end;



 Jens Borrisholt

tirsdag den 8. november 2011

cxGridExtentionU - En faktor 60 !

Det er vist ingen hemmelighed, at jeg er stor fan af Developer Express, og bruger deres komponenter alle de steder, jeg kan komme afsted med det. Enkelte steder er der nogle "uhensigtsmæssigheder", som kunne være gjort smartere/bedre/hurtigere, men det ER ikke mange steder. Og generelt er der så mange ting, vi får foræret, når vi bruger DevExpress, at det på ingen måde ødelægger "billedet".

Når man udvikler database-applikationer af alverdens slags, er der som regel altid brug for at præsentere data i grids. Det bliver pænest og mest overskueligt, når data-kolonnerne er spredt ud over hele grid'et - i stedet for at være klumpet sammen i venstre side. Og jeg vil også gerne have, at når jeg resize'r min form - og dermed også grid'et, skal kolonnerne "strækkes" med.

I slutningen af mit sidste indlæg afsluttede jeg med at fortælle om nogle performance-problemer i et TcxGrid, når der skal laves en ApplyBestFit på en kolonne. Med udgangspunkt i det givne dataset tog det næsten 14 sekunder for et TcxGrid at tilpasse kolonne-bredden til data. Personligt finder jeg det for uacceptabelt lang tid.

Som jeg skrev, har jeg en løsning på problemet. Den samlede tid kan bringes ned på omkring 250 ms for selv samme handling. Dette blogindlæg handler om den løsning.

Først skal jeg bruge nogle data, dem henter jeg fra "min" baseball database. Denne gang har jeg eksporteret to tabeller, BattingPost og Batting, for at vise et master/detail-forhold mellem to tabeller - samt at vise hvordan man udfører en ApplyBestFit på et detail grid.

Først skal jeg have hentet data ind. De første 5 felter i tekstfilen "BattingPost.txt" og de første 5 felter i "Batting.txt" danner datagrundlag for det følgende.

Igen her benytter jeg en TStringList til parsning. Jeg har tidligere beskrevet i detaljer hvordan jeg gør, så det vil jeg udelade denne gang. Jeg har taget en TcxGrid-komponent og sat to niveauer på med hver deres view. De to views har jeg bundet sammen i et master-detail forhold, hvor RecID er primær nøglen i master-dataset'et, og PlayerId er fremmed nøgle. En temmelig triviel opgave, som jeg ikke vil gå i detalje med her. I stedet vil jeg blot vise min applikation:


Som det fremgår er kolonne-bredden ikke tilpasset ikke tilpasset mit grid. Dette kan gøres med en ApplyBestFit på hver række. I mit eksempel vil jeg implementere den på GridResize-eventet, idet jeg hermed opnår en skalerbar applikation. Det gøres nemt og enkelt sådan her:

procedure TMainForm.cxGrid1Resize(Sender: TObject);
begin
  cxGrid1DBTableView1.ApplyBestFit;
end; 

Problemet er bare, at der går en evighed hver gang. Efter at have gravet lidt (lidt meget) i kildekoden til cxGrid har jeg lokaliseret problemet: Problemet er at TcxGrid måler bredden på indholdet i hver celle med en Canvas.TextWidth(). Hvis man kigger efter i TcxCustomGridTableItem.CalculateBestFitWidth 
vil man hurtigt opdage, at dette er en stærkt forsimplet udgave af virkeligheden, men det udstiller meget godt problemet.

Jeg har derfor skrevet en procedure, som gør det anderledes. Jeg finder den længste streng, måler længden på den - for så at lægge lidt "luft" til, så teksten ikke kommer til at stå helt klods op ad højre/venstre celle-kant. Som det ses i den efterfølgende procedure, har det været nødvendigt at indføre et par "hacker-kontroller", altså nogle nedarvninger af eksisterende datatyper, for at gøre protected properties tilgængelige.

type
  THackPainter = class(TcxCustomGridPainter);
  THackColumn = class(TcxGridColumn);

procedure FastColumnApplyBestFit(GridColumn: TcxGridColumn);
var
  i, FIndex: Integer;
  AValue: Variant;
  ARecord: TcxCustomGridRecord;
  AIsCalcByValue: Boolean;
  SaveValue: string;
begin
  AIsCalcByValue := (@GridColumn.OnGetDataText = nil) or (GridColumn.GetProperties.GetEditValueSource(False) = evsValue);
  FIndex := GridColumn.Index;
  SaveValue := GridColumn.Caption;

  for i := 0 to THackColumn(GridColumn).ViewData.RowCount - 1 do
  begin
    ARecord := GridColumn.GridView.ViewData.Records[i];

    if AIsCalcByValue then
      AValue := ARecord.Values[FIndex]
    else
      AValue := ARecord.DisplayTexts[FIndex];

    if Length(SaveValue) < Length(AValue) then
      SaveValue := AValue;
  end;

  GridColumn.Width := THackPainter(GridColumn.GridView.Painter).Canvas.TextWidth(SaveValue);
  if GridColumn.Options.Filtering then
    GridColumn.Width := GridColumn.Width + 25
  else
    GridColumn.Width := GridColumn.Width + 10;
end;

Så skal den bare kaldes, f.eks. med PlayerID-kolonnen:

FastColumnApplyBestFit(cxGrid1DBTableView1PlayerID);


Når jeg vil have kolonnerne spredt ud over hele grid'et til enhver tid, så gælder det også, hvis grid'et bliver mindre en det, som data fylder. Det betyder, at jeg ønsker at alle rækkerne skal tilpasse sig data på nær én, som jeg ønsker skal fylde "resten"... eller som er den kolonne, der skal "spises" af, når ikke der er plads til at vise alle data.

Det har jeg også skrevet en procedure der kan. Den benytter sig internt af FastColumnApplyBestFit. Implementeringen er triviel, så den vil jeg bringe her uden yderligere kommentarer.

procedure VirtualGridColumnApplyBestFit(const aView: TOriginalcxGridTableView; 
  const RestGridColumn: TOriginalcxGridColumn);
var
  i: Integer;
  Tmp: Integer;
begin
  if aView.VisibleColumnCount = 0 then
  begin
    aView.OptionsView.ColumnAutoWidth := True;
    Exit;
  end
  else
    aView.OptionsView.ColumnAutoWidth := False;

  Tmp := 0;

  for i := 0 to aView.VisibleColumnCount - 1 do
    if RestGridColumn <> aView.VisibleColumns[i] then
    begin
      FastColumnApplyBestFit(aView.VisibleColumns[i]);
      inc(Tmp, aView.VisibleColumns[i].Width);
    end;

  // Antager at grupperede kolonner altid er 17 pixels brede.
  inc(Tmp, aView.GroupedColumnCount * 17);

  if RestGridColumn <> nil then
  begin
    // Workarround for BUG:
    // aView.ViewInfo.ClientWidth bliver først opdateret når en Col 
    // ændre størrelse.
    RestGridColumn.Width := RestGridColumn.Width + 1;
    RestGridColumn.Width := aView.ViewInfo.ClientWidth - Tmp;
  end;
end; 

Nu ville det være rart, hvis cxGrid selv kaldte de nye og hurtigere metoder. Dette kan opnås ved hjælp af en nedarvning af TcxGridDBColumn og TcxGridColumn. Men her kommer så et smart lille trick...

I stedet for at oprette en ny klasse sådan her:

type
  TMyGridDBColumn = cxGridDBTableView.TcxGridDBColumn;
   
- så kalder jeg den nedarvede klasse det samme som originalen:

type
  TcxGridDBColumn = cxGridDBTableView.TcxGridDBColumn;

Det betyder nemlig, at jeg ikke skal lave casts frem og tilbage, når de skal benyttes. Og hvis man blot lægger den slags kode i en unit for sig selv er det til at styre.

På et tidspunkt risikerer jeg at få brug for "original-klasserne", så for at kunne kende forskel på "min" udgave af TcxGridDBColumn og den originale, laver jeg en kopi af alle de datatyper, som jeg senere vil nedarve.

type
  TOriginalcxGridTableView = cxGridTableView.TcxGridTableView;
  TOriginalcxGridDBTableView = cxGridDBTableView.TcxGridDBTableView;
  TOriginalcxGridColumn = cxGridTableView.TcxGridColumn;
  TOriginalcxGridDBColumn = cxGridDBTableView.TcxGridDBColumn;


Jeg viser kun her for TcxGridColumn i det koden for en TcxDBGridColumn vil være magen til:

type
  ...

  TcxGridColumn = class(TOriginalcxGridColumn)
  public
    procedure ApplyBestFit(ACheckSizingAbility: Boolean = False; 
      AFireEvents: Boolean = False); override;
  end;

...

implementation

...

procedure TcxGridColumn.ApplyBestFit(ACheckSizingAbility, AFireEvents: Boolean);
begin
  FastColumnApplyBestFit(Self);
end;

Der foruden har jeg tilføjet en metode ColumnsApplyBestFit på TcxGridDBTableView, som bare kalder  VirtualGridColumnApplyBestFit. Her lister jeg den komplette unit, som jeg har opbygget.

Hvis man ønsker at se hele det komplette eksempel med data, kan det findes her.

unit cxGridExtentionU;

interface

uses
  cxGrid, cxGridLevel, cxGridTableView, cxGridDBTableView, cxGridCustomTableView;

{$M+}

type
  TOriginalcxGridTableView = cxGridTableView.TcxGridTableView;
  TOriginalcxGridDBTableView = cxGridDBTableView.TcxGridDBTableView;
  TOriginalcxGridColumn = cxGridTableView.TcxGridColumn;
  TOriginalcxGridDBColumn = cxGridDBTableView.TcxGridDBColumn;

  TcxGridColumn = class(TOriginalcxGridColumn)
  public
    procedure ApplyBestFit(ACheckSizingAbility: Boolean = False; AFireEvents: 
     Boolean = False); override;
  end;

  TcxGridDBColumn = class(TOriginalcxGridDBColumn)
  public
    procedure ApplyBestFit(ACheckSizingAbility: Boolean = False; AFireEvents: 
      Boolean = False); override;
  end;

  TcxGridDBTableView = class(TOriginalcxGridDBTableView)
  public
    procedure ColumnsApplyBestFit(RestGridColumn: TOriginalcxGridColumn = nil); 
      overload;
  end;

procedure VirtualGridColumnApplyBestFit(
  const aView: TOriginalcxGridTableView; 
   const RestGridColumn: TOriginalcxGridColumn); overload;
procedure FastColumnApplyBestFit(GridColumn: TOriginalcxGridColumn);

implementation

uses
  cxDataUtils // evsValue
    , cxGridCustomView // TcxCustomGridPainter
    ;

{ TcxGridDBTableView }

procedure TcxGridDBTableView.
  ColumnsApplyBestFit(RestGridColumn: TOriginalcxGridColumn);
begin
  VirtualGridColumnApplyBestFit(Self, RestGridColumn);
end;

{ TcxGridColumn }

procedure TcxGridColumn.ApplyBestFit(ACheckSizingAbility, AFireEvents: Boolean);
begin
  FastColumnApplyBestFit(Self);
end;

{ TcxGridDBColumn }

procedure TcxGridDBColumn.ApplyBestFit(ACheckSizingAbility, AFireEvents: Boolean);
begin
  FastColumnApplyBestFit(Self);
end;

type
  THackPainter = class(TcxCustomGridPainter);
  THackColumn = class(TOriginalcxGridColumn);
  THackTableView = class(TOriginalcxGridTableView);

procedure FastColumnApplyBestFit(GridColumn: TOriginalcxGridColumn);
var
  i, FIndex: Integer;
  AValue: Variant;
  ARecord: TcxCustomGridRecord;
  AIsCalcByValue: Boolean;
  SaveValue: string;
begin
  AIsCalcByValue := (@GridColumn.OnGetDataText = nil) or 
    (GridColumn.GetProperties.GetEditValueSource(False) = evsValue);
  FIndex := GridColumn.Index;
  SaveValue := GridColumn.Caption;

  for i := 0 to THackColumn(GridColumn).ViewData.RowCount - 1 do
  begin
    ARecord := GridColumn.GridView.ViewData.Records[i];

    if AIsCalcByValue then
      AValue := ARecord.Values[FIndex]
    else
      AValue := ARecord.DisplayTexts[FIndex];

    if Length(SaveValue) < Length(AValue) then
      SaveValue := AValue;
  end;

  GridColumn.Width := 
    THackPainter(GridColumn.GridView.Painter).Canvas.TextWidth(SaveValue);
  if GridColumn.Options.Filtering then
    GridColumn.Width := GridColumn.Width + 25
  else
    GridColumn.Width := GridColumn.Width + 10;
end;

procedure VirtualGridColumnApplyBestFit
  (const aView: TOriginalcxGridTableView; 
     const RestGridColumn: TOriginalcxGridColumn);
var
  i: Integer;
  Tmp: Integer;
const
  GroupByButtonWidth = 17;
begin
  if aView.VisibleColumnCount = 0 then
  begin
    aView.OptionsView.ColumnAutoWidth := True;
    Exit;
  end
  else
    aView.OptionsView.ColumnAutoWidth := False;

  Tmp := 0;

  for i := 0 to aView.VisibleColumnCount - 1 do
    if RestGridColumn <> aView.VisibleColumns[i] then
    begin
      FastColumnApplyBestFit(aView.VisibleColumns[i]);
      inc(Tmp, aView.VisibleColumns[i].Width);
    end;

  // Antager at grupperede kolonner altid er 17 pixels brede.
  inc(Tmp, aView.GroupedColumnCount * GroupByButtonWidth);

  if RestGridColumn <> nil then
  begin
    // Workarround for BUG:
   // aView.ViewInfo.ClientWidth bliver først opdateret når en Col ændre størrelse.

    RestGridColumn.Width := RestGridColumn.Width + 1;
    RestGridColumn.Width := aView.ViewInfo.ClientWidth - Tmp - 
      (TcxGridLevel(THackTableView(aView).Level).Count * GroupByButtonWidth);
  end;
end;

end.

Når koden skal anvendes i formen, gøres det således:
Tilføj cxGridExtentionU i den øverste uses sektion, men EFTER cxGrid. Så sker trylle kunsten af sig selv, og et kald til cxGrid1DBTableView1.ApplyBestFit som før tog 14 sekunder, tager nu 250 ms UDEN at man skal lave andre modifikationer i koden.

Som jeg skrev før, ønsker man som oftest at en kolonne skal udfylde resten af sit grid, efter de resterende kolonner har tilpasset sig efter data. Dette kan passende gøres på GridResize-eventet:

procedure TMainForm.cxGrid1Resize(Sender: TObject);
begin
 cxGrid1DBTableView1.ColumnsApplyBestFit(cxGrid1DBTableView1PlayerID); 
end;


Til slut er der blot at få vores detail view tilpasset. "Problemet" med et detail view, er at det i sagens natur kun findes på runtime. At man kan oprette og tilpasse et detail view på design time, er kun af hensyn til den generelle indstilling/opsætning. På runtime bliver detail views autogenereret, bl.a. fordi der jo kan være flere af dem. Af samme årsag kan vi ikke sådan lige nemt tilgå det/dem, med det navn det har på designtime.

Detail viewet skal i stedet "fanges", når man pakker det ud. Det sker i eventet
cxGrid1DBTableView1DataControllerDetailExpanded. Klik på cxGrid1DBTableView1 og find eventet via  DataController-->OnDetailExpanded i event-fanen i object inspectoren.

Koden ses her:

procedure TMainForm.cxGrid1DBTableView1DataControllerDetailExpanded
  (ADataController: TcxCustomDataController; ARecordIndex: Integer);
var
  DetailGridView: TcxGridDBTableView;
  DetailDataController: TcxGridDBDataController;
begin
  DetailDataController := ADataController.GetDetailDataController(ARecordIndex, 0
as TcxGridDBDataController;
  DetailGridView := DetailDataController.GetOwner as TcxGridDBTableView;
  VirtualGridColumnApplyBestFit(DetailGridView, 
   DetailGridView.GetColumnByFieldName('PlayerID'));
end;




I det ovenstående har jeg dels vist, hvordan jeg kunne øge hastistigheden på en ApplyBestfit med næsten 60 gange, ved hjælp af et par enkelte tiltag. Endivdere har jeg vist, hvordan man lavet et cxGrid skalerbart. Slutteligt er der blot tilbage at vise et billede af applikationen:


Og så skal jeg da lige minde om, at den komplette kode med data kan hentes her.

torsdag den 3. november 2011

Dynamiske filtre i et TcxGrid

I dette indlæg vil jeg vise, hvordan man bygger filtre op dynamisk i et TcxGrid på runtime.

I et TcxGrid er standard funktionaliteten, at man kan vælge en lille drop down på en kolonnes header og vælge, hvilke værdier man vil have grid'et filtreret efter. Når man klikker på checkboxene i den lille drop down, genereres et filter, som bliver synligt i bunden af grid'et.

Her illustreret med et skærmbillede:




For at eksemplet giver mening, skal vi først have fyldt noget data i vores grid. I en anden forbindelse fald jeg over denne database over baseball resultater: http://baseball1.com/statistics/. Den har en fin størrelse, og man behøver ikke at vide noget om baseball for at bruge den. Jeg ved fx intet om det ;o)

For nemt at kunne bruge databasen, har jeg hentet den nyeste Access-version, importeret baseball-databasen hertil, og siden eksporteret tabellen "Batting" ud i en tekstfil.

De første 5 felter i tekstfilen danner datagrundlag for det følgende. Jeg har oprettet en TdxMemtable med en tabel-definition som modsvarer det, der ses i grid'et ovenfor. Det komplette eksempel - med data - kan i øvrigt hentes her.

For at indlæse og parse tekstfilen, har jeg gjort som vist i koden herunder.

Som det ses, bruger jeg en TStringList til parsningen. Det er både nemt og hurtigt. Det tager omkring 1800 ms at parse de knap 94.000  rækker, der er i tekstfilen. Det kan muligvis gøres hurtigere med andre teknikker, men det er ikke vigtigt i forhold til mit eksempel.

procedure TMainForm.LoadData;
var
  Buffer: TStringList;
  LineParser: TStringList;
  Line: String;
begin
  Buffer := TStringList.Create;
  Buffer.LoadFromFile('Batting.txt');
  LineParser := TStringList.Create;
  LineParser.LineBreak := ';';

  dxMemData1.Close;
  dxMemData1.Open;
  DataSource1.DataSet.DisableControls;
  try
    for Line in Buffer do
    begin
      LineParser.Text := Line;
      dxMemData1.Append;
      dxMemData1PlayerID.AsString := LineParser[0];
      dxMemData1YearID.AsString := LineParser[1];
      dxMemData1Stint.AsString := LineParser[2];
      dxMemData1TeamID.AsString := LineParser[3];
      dxMemData1LgID.AsString := LineParser[4];
      dxMemData1.Post;
    end;

  finally
    DataSource1.DataSet.EnableControls;
    FreeAndNil(Buffer);
  end;
end;

Mit mål er nu at opbygge en liste over alle de værdier, der er i en given kolonne, og vise dem i en ChecklistBox. Når der så klikkes på et element i CheckListBoxen skal det slå igennem som et filter på mit grid.

Jeg har valgt at opbygge data til min CheckListBox, når jeg klikker på en kolonne overskrift.

Lad mig starte med at vise proceduren, der opbygger listen over de forskellige værdier fra kolonnen:

procedure TMainForm.BuildFilters(const cxGridDBColumn: TcxGridDBColumn);
var
  FilterStrings: TStringList;
  ValueList: TcxGridFilterValueList;
  i: Integer;
begin
  if cxGridDBColumn = nil then
    exit;

  FilterStrings := TStringList.Create;
  ValueList := cxGridDBColumn.GridView.ViewData.CreateFilterValueList;
  cxCheckListBox1.Tag := Integer(cxGridDBColumn);

  dxMemData1.DisableControls;

  cxCheckListBox1.Items.BeginUpdate;
  cxCheckListBox1.Items.Clear;
  try
    TcxGridDBTableView(cxGridDBColumn.GridView).DataController.Filter.Root.Clear;
    cxGridDBColumn.DataBinding.GetFilterStrings(FilterStrings, ValueList);
    
    for i := 0 to FilterStrings.Count - 1 do
    begin
      if ValueList[i].Kind <> fviValue then
        continue;

      with cxCheckListBox1.Items.Add do
        Text := ValueList[i].DisplayText;
    end;
  finally
    cxCheckListBox1.Items.EndUpdate;
    dxMemData1.EnableControls;
    FreeAndNil(ValueList);
    FreeAndNil(FilterStrings);
  end;
end;

En grid-kolonne (TcxDBGridColumn) har en klasse på sig, kaldet DataBinding. På DataBinding er en funktion, som returnerer en liste over de forskellige værdier, der ligger kolonnen. Funktionen skal have to parametre:

  • En liste af typen TcxGridFilterValueList
  • En TStringlist som er oprettet på traditionel vis

En TcxGridFilterValueList er en liste af TcxFilterValueItem records...:

type
  TcxFilterValueItem = record
    Kind: TcxFilterValueItemKind;
    Value: Variant;
    DisplayText: string;
  end;

... og den kan man få "udleveret" af det view kolonnen ligger på. Sådan her :

var 
  ValueList: TcxGridFilterValueList;

...


  ValueList := cxGridDBColumn.GridView.ViewData.CreateFilterValueList;


Elementernes "Kind"-property angiver, som navnet siger, typen på de enkelte elementer. Den kan have en række forskellige værdier, alt efter hvad der er stoppet i listen. Det vil føre for vidt her at gennemgå alle type'erne her - jeg vil blot nøjes med at koncentrere mig om dem der indeholder en data værdi: Kind = fviValue.

Således har jeg nu med ovenstående BuildFilters-procedure fået udfyldt min CheckListBox i venstre side, så den indeholder de samme elementer (med Kind = fviValue), som i den lille drop down på kolonnens header (billede 1 øverst på siden).



Næste skridt er, at når jeg tilføjer et nyt filter via mit grid, skal det slå igennem ovre i ChecklistBoxen. Helt kort skal man bare implementere et OnchangeEvent på filteret. Jeg vælger mit View i designeren, og trykker F11 for Object Inspectoren. Her vælges DataController-->Filter-->OnChange.


Jeg indsætter flg. kode:

procedure TMainForm.cxGrid1DBTableView1DataControllerFilterChanged(Sender: TObject);

  procedure CheckItemList(Root: TcxFilterCriteriaItemList);
  var
    i, j: Integer;
  begin
    i := 0;
    while i < Root.Count do
    begin
      if (Root.Items[i] is TcxFilterCriteriaItemList) then
        CheckItemList(TcxFilterCriteriaItemList(Root.Items[i]))
      else
        for j := 0 to cxCheckListBox1.Items.Count - 1 do
          if cxCheckListBox1.Items[j].Text = 
            String(TcxFilterCriteriaItem(Root.Items[i]).Value) then
          begin
            cxCheckListBox1.Items[j].Checked := True;
            Break;
          end;

      Inc(i);
    end;
  end;

var
  Filter: TcxDBDataFilterCriteria;
  SavedFilterChangedEvent: TNotifyEvent;
  i: Integer;
begin
  cxCheckListBox1.Items.BeginUpdate;
  try
    for i := 0 to cxCheckListBox1.Items.Count - 1 do
      cxCheckListBox1.Items[i].Checked := False;

    Filter := TcxDBDataFilterCriteria(Sender);
    SavedFilterChangedEvent := Filter.OnChanged;
    Filter.OnChanged := nil;
    CheckItemList(Filter.Root);
    Filter.OnChanged := SavedFilterChangedEvent;
  finally
    cxCheckListBox1.Items.EndUpdate;
  end;
end;

Jeg vil ikke knytte mange kommentarer til proceduren, da der ikke er ret meget i den. Dog vil jeg lige gøre opmærksom på, at min TcxFilterCriteriaItemList kan indeholde to slags elementer: TcxFilterCriteriaItemList og TcxFilterCriteriaItem. Derfor kalder den (rekursive) subprocedure sig selv, hvis den møder en TcxFilterCriteriaItemList i listen. For at undgå et uendeligt loop, sætter jeg Filter's OnchangeEvent til nil, mens jeg arbejder med filteret.


Sidste skridt er at gå den anden vej. Altså når man klikker på et element i ChecklistBoxen, skal det også slå igennem i grid'et, således at begge filtre "følges ad".

Da jeg fyldte data i ChecklistBox'en (mis?)brugte jeg dens Tag-property til at gemme min kolonne's adresse. Det er ikke en praksis jeg kan anbefale, men det var bare en hurtig genvej i mit eksempel.

Jeg har til formålet lavet en procedure, som kan traversere min CheckListBox igennem og opbygge et filter udfra de elementer der er valgt:

procedure TMainForm.ApplyFiltersToGrid(cxGridDBColumn : TcxGridDBColumn);
var
  Filter: TcxDBDataFilterCriteria;
  i: Integer;
  cxCheckListBoxItem: TcxCheckListBoxItem;
  SavedFilterChangedEvent: TNotifyEvent;
begin
  if cxGridDBColumn = nil then
    exit;

  Filter := TcxGridDBTableView(cxGridDBColumn.GridView).DataController.Filter;
  SavedFilterChangedEvent := Filter.OnChanged;

  Filter.OnChanged := nil;
  try
    Filter.BeginUpdate;

    Filter.Root.Clear;
    Filter.Root.BoolOperatorKind := fboOr;

    for i := 0 to cxCheckListBox1.Items.Count - 1 do
    begin
      cxCheckListBoxItem := cxCheckListBox1.Items[i];
      if not cxCheckListBoxItem.Checked then
        continue;

      Filter.Root.AddItem(cxGridDBColumn, foEqual, cxCheckListBoxItem.Text, 
        cxCheckListBoxItem.Text);
    end;

  finally
    Filter.Active := True;
    Filter.EndUpdate;
    Filter.OnChanged := SavedFilterChangedEvent;
  end;
end;

Der er ikke meget at sige om selve proceduren, udover at jeg igen sætter filterets OnChange-event til nil mens jeg arbejder på det, for at undgå et uendeligt loop.

Således kan jeg nu med det ovenstående bygge et filter dynamisk op og anvende det på et grid.

---

Man opdager hurtigt, at når man arbejder med et TcxGrid med mange datarækker i, som fx i det ovenstående, hvor i der er knap 94.000 rækker, at det at tilpasse kolonners brede efter teksten, kan være en tung omgang. Det er også et problem, som er rapporteret til DevExpress nogle gange, men deres forslag er flg.:

procedure TForm1.cxButton1Click(Sender: TObject);
begin
  cxGrid1.BeginUpdate;
  try
    cxGrid1DBTableView1.ApplyBestFit();
  finally
    cxGrid1.EndUpdate;
  end
end;

Dette er næsten 14 sekunder (13.600 ms) om at blive udført. I min optik er det uholdbart lang tid, fordi det gør det stort set umuligt at lave skalerbare applikationer, hvis der er RIGTIGT mange datarækker i grid'et. Men "Der er ingen sløsning, når Borrisholt finder en løsning" - så fortvivl ikke ;o) Jeg har en løsning på problemet, således at den ovenstående kode kan udføres på 250 ms, altså godt og vel en faktor 54.

Det komplette eksempel, med data, kan i øvrigt hentes her.

Den løsning bliver så genstand for mit næste indlæg. Stay tuned!

Jens Borrisholt

onsdag den 2. november 2011

Thumbnails!

Thumbnails! Et godt dansk ord til en god dansk Delphi blog ;-) Men det var nu det bedste ord jeg kunne finde.

Jeg vil i dette indlæg behandle lidt forskelligt. Dels vil jeg vise, hvordan man tilgår data i en TBitmap ved hjælp af "Scanlines", og dels vil jeg vise hvordan man får Windows til at genere thumbnails for billeder der ligger på harddisken.

Jeg vil angive nogle eksekverings tider, det er tider tager fra min egen udviklings-pc. Det er ikke nogen super hurtigt maskine, men blot en ganske almindelig pc:

Processor : AMD Athlon II x2 255. 3.1 GHz.
Ram : 4 GB.
OS: Windows 7 64 bit
HD hastighed: 5200 omdrejninger
... altså ikke noget stort og voldsomt.

For at genere nogle thumbnails, skal jeg have noget at genere dem af. Til det formål har jeg skrevet en procedure, der laver en bitmap på størrelse med skærmen, bestående af random pixels. Som det fremgår af koden, bruger jeg "Scanline-metoden" til at tilgå de enkelte pixels.

De enkelte steps er forklaret i koden.

procedure GeneratePictures(Antal: Integer);
var
  bmpWidth, bmpHeight, i, j: Integer;
  Bitmap: TBitmap;
  OutputDir: String;
  Scanline: pScanline;
begin
  bmpWidth := GetSystemMetrics(SM_CXSCREEN);
  bmpHeight := GetSystemMetrics(SM_CYSCREEN);

  //opret en 32 bits bitmap
  Bitmap := TBitmap.Create;
  Bitmap.Width := bmpWidth;
  Bitmap.Height := bmpHeight;
  Bitmap.PixelFormat := pf32bit;

  OutputDir := ExtractFilePath(ParamStr(0)) + 'Images\';
  ForceDirectories(OutputDir);

  while Antal > 0 do
  begin
    for i := 0 to bmpHeight - 1 do
    begin
      j := 0;
      //Hent adressen til den første pixel i linje "i"
      Scanline := Bitmap.Scanline[i];

      while j < bmpWidth do
      begin
        //Beregn adressen på den pixel du vil tilgå:
        //Adressen på Pixel #0 i din linje gange antal pixel gange med størrelsen på en pixel
        with pRGBQuad(Integer(@Scanline[0]) + (j * Sizeof(TRGBQuad)))^ do
        begin
          //farvelæg din pixel
          rgbBlue := Random(255);
          rgbGreen := Random(255);
          rgbRed := Random(255);
          rgbReserved := 0;
        end;

        inc(j); //næste pixel
      end;
    end;

    //Dumme billeder har dumme navne ;o)
    Bitmap.SaveToFile(OutputDir + IntToStr(Antal) + '.bmp');
    Dec(Antal);
  end;

  FreeAndNil(Bitmap);
end;

Herefter er det blot at kalde koden:


procedure TMainForm.Button1Click(Sender: TObject);
var
  Start, Stop: DWORD;
begin
  Start := GetTickCount;
  GeneratePictures(50);
  Caption := IntToStr(GetTickCount - Start)
end;
En ganske uvidenskabelig test på min computer viser, at jeg skal bruge omkring 1200-1400 millisekunder på at lave og gemme de 50 billeder.

Nu hvor billederne er genereret, skal der laves thumbnails. I stedet for at "hive dem op" i CPU'en og lade dén beregne på det, kan man få Windows til at gøre det. Det er ganske hurtigt. Eneste "ulempe" er, at sådan noget  kode der interagerer med Windows shell'en, dels ikke er ret kønt og dels ikke er ret læsevenligt. Jeg har dog gjort det nemt at bruge.

Jeg vil ikke bruge en masse plads på at forklare mig her, idet jeg har sat kommentarer i koden, og hvis det virkelig interesserer nogen hvad de enkelte Windows funktioner laver, kan jeg så afgjort anbefale at slå det op i MSDN.

unit FileThumbU;

interface

uses
  Graphics;

Type
  TFileThumb = Class
  protected
    FhImageList48: Cardinal;
    FSize, FIconSize: Integer;
    FBmp: TBitmap;
    FFilePath: String;
    procedure SetFile(const Value: String);
    procedure SetSize(Value: Integer);
    procedure GetThumb;
  public
    property Size: Integer read FSize write SetSize;
    property ThumbBmp: TBitmap read FBmp;
    property FilePath: String read FFilePath write SetFile;
    Constructor Create;
    Destructor Destroy; override;
  end;

implementation

uses
  Windows, SysUtils, ActiveX, ShellApi, commCtrl, ShlObj;

// http://msdn.microsoft.com/en-us/library/windows/desktop/bb761848(v=vs.85).aspx
// IExtractImage Interface er implementeret i Windows' Shell32.dll (fra version 4.70)
type
  IExtractImage = interface
    ['{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}']
    function GetLocation(pszwPathBuffer: PWideChar; cch: DWORD; var dwPriority: DWORD; var rgSize: TSize; dwRecClrDepth: DWORD; var dwFlags: DWORD): HResult; stdcall;
    function Extract(var hBmpThumb: HBITMAP): HResult; stdcall;
  end;

const
  MinSize = 52;
  MaxSize = 256;
  ColorFormat: DWORD = 24;
  IEIFLAG_OFFLINE = 8;
  IEIFLAG_SCREEN = $20;

Constructor TFileThumb.Create;
var
  hImagList16, hImagList32: Cardinal;
  pfsi: TShFileInfo;
  icHgt, icWid: Integer;
begin
  //Default thumbnail størrelse
  FSize := 100;
  FFilePath := '';
  {
    Henter et handle til den imagelist, som Windows internt bruger til Iconer. Yderligere information:
    http://msdn.microsoft.com/en-us/library/bb762179(VS.85).aspx
    Parameteren SHGFI_SYSICONINDEX er den centrale
  }
  hImagList32 := SHGetFileInfo('dummy.txt', FILE_ATTRIBUTE_NORMAL, pfsi, SizeOf(pfsi), SHGFI_LARGEICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
  hImagList16 := SHGetFileInfo('dummy.txt', FILE_ATTRIBUTE_NORMAL, pfsi, SizeOf(pfsi), SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
  FhImageList48 := hImagList16 + (hImagList16 - hImagList32);

  if ImageList_GetIconSize(FhImageList48, icHgt, icWid) and (icHgt = 48) then
    FIconSize := 48
  else
  begin
    FhImageList48 := hImagList32;
    if ImageList_GetIconSize(hImagList32, icHgt, icWid) then
      FIconSize := icHgt
    else
      FIconSize := 32;
  end;

  FBmp := Graphics.TBitmap.Create;
  FBmp.Canvas.Brush.Color := GetSysColor(COLOR_WINDOW);
  FBmp.Width := FSize;
  FBmp.Height := FSize;
  FBmp.PixelFormat := pf24Bit;
end;

destructor TFileThumb.Destroy;
begin
  FreeAndNil(FBmp);
  inherited Destroy;
end;

procedure TFileThumb.SetFile(const Value: String);
begin
  if Value = FFilePath then
    Exit;
  FFilePath := Value;
  GetThumb;
end;

procedure TFileThumb.SetSize(Value: Integer);
begin
  if Value = FSize then
    Exit;

  if Value > MaxSize then
    FSize := MaxSize
  else if Value < MinSize then
    FSize := MinSize
  else
    FSize := Value;

  FBmp.Width := FSize;
  FBmp.Height := FSize;
  GetThumb;
end;

procedure TFileThumb.GetThumb;
var
  Path, Name: String;
  FolderISF, DesktopISF: IShellFolder;
  IExtractImg: IExtractImage;
  Attrib, Eaten: DWORD;
  pItemIDL: PItemIDList;
  MemAlloc: IMalloc;
  CharBuf: array [0 .. 2047] of WideChar;
  hBmp: HBITMAP;
  Size1: TSize;
  Priority, Flags: Cardinal;
  GLResult: HResult;
  Mid: Integer;
  ShInfo1: TShFileInfo;
begin
  FBmp.Width := FSize;
  FBmp.Height := FSize;

  if (FFilePath = '') or (not FileExists(FFilePath)) then
  begin
    FBmp.Canvas.Rectangle(0, 0, FSize, FSize);
    Exit;
  end;

  Path := ExtractFilePath(FFilePath);
  Name := ExtractFileName(FFilePath);
  Mid := (FSize shr 1) - (FIconSize shr 1);
  FBmp.Canvas.Rectangle(-1, -1, FSize + 3, FSize + 3);

  //Lad Windows shell'en til at genere en thumbnail
  SHGetFileInfo(PChar(FFilePath), FILE_ATTRIBUTE_NORMAL, ShInfo1, SizeOf(ShInfo1), SHGFI_LARGEICON or SHGFI_SYSICONINDEX);

  //Tegn den på bitmap'en
  ImageList_Draw(FhImageList48, ShInfo1.iIcon, FBmp.Canvas.Handle, Mid, Mid, ILD_TRANSPARENT);

  // Krav: Mindst Windows 2000
  if (Win32Platform <> VER_PLATFORM_WIN32_NT) or (Win32MajorVersion < 6) then
    Exit;

  if (SHGetMalloc(MemAlloc) <> NOERROR) or (MemAlloc = nil) or (SHGetDesktopFolder(DesktopISF) <> NOERROR) then
    Exit;

  //Oversæt Path til PItemIDList, den skal vi bruge senere
  if DesktopISF.ParseDisplayName(0, nil, StringToOleStr(Path), Eaten, pItemIDL, Attrib) <> NOERROR then
    Exit;

  //Bind vores PItemIDList til Windows Shell
  DesktopISF.BindToObject(pItemIDL, nil, IShellFolder, FolderISF);
  MemAlloc.Free(pItemIDL);

  //Oversæt navn til PItemIDList, den skal vi bruge senere
  if FolderISF.ParseDisplayName(0, nil, StringToOleStr(Name), Eaten, pItemIDL, Attrib) <> NOERROR then
    Exit;

  //Tag fat i billedet og generer en thumbnail
  FolderISF.GetUIObjectOf(0, 1, pItemIDL, IExtractImage, nil, IExtractImg);
  MemAlloc.Free(pItemIDL);

  if IExtractImg = nil then
    Exit;

  Size1.cx := FSize;
  Size1.cy := FSize;

  Flags := IEIFLAG_SCREEN or IEIFLAG_OFFLINE;
  Priority := 0;

  //Hent path til vores billede, og vær sikker på at vores Thumbnail bitmap har det rigtige handle
  GLResult := IExtractImg.GetLocation(CharBuf, SizeOf(CharBuf), Priority, Size1, ColorFormat, Flags);

  if (GLResult = NOERROR) or (GLResult = E_PENDING) then
  begin
    if (IExtractImg.Extract(hBmp) <> NOERROR) or (hBmp = 0) then
      Exit;

    FBmp.Handle := hBmp;
  end;

end;

end.



Jeg sagde jo koden ikke var ret køn ;o) Men som det fremgår af eksemplet, har jeg lagt det i en unit for sig selv, således at det er "pakket" væk.

Tilbage er der blot at kalde koden:

uses
  FileThumbU, IOUtils;

procedure TMainForm.Button2Click(Sender: TObject);
var
  Start, Stop: DWORD;
  BitmapFile, NewFileName: String;
begin
  Start := GetTickCount;
  for BitmapFile in TDirectory.GetFiles(ExtractFilePath(ParamStr(0)) + 'Images\', '*.bmp') do
    With TFileThumb.Create do
      try
        NewFileName := ExtractFilePath(BitmapFile) + 'th_' + ExtractFileName(BitmapFile);
        FilePath := BitmapFile;
        ThumbBmp.SaveToFile(NewFileName);
      finally
        Free;
      end;

  Caption := IntToStr(GetTickCount - Start)
end;


Tests fortaget på min computer viser at det tager ca. 1400-1500 millisekunder at udføre.

Den opmærksomme læser bemærker sikkert, at jeg benytter mig af IOUtils.pas i eksempelt, som først er tilgængelig i Delphi 2009. Det er gjort fordi det er en nem måde at traversere en folder igennem efter filer. Det er så også det eneste kode, der ikke kan køre på en ældre version af Delphi. Skulle nogen få brug for det, kan man nemt selv omskrive til et "FindFirst .. FindNext .. FindClose"-loop, som man brugte før i tiden.

Så alt i alt har jeg genereret 50 billeder med random pixels, smidt dem på harddisken og lavet thumbnails ud af dem på under 3 sekunder. Ikke dumt når man tager billedernes størrelse i betragtning.

Thumbnail-generatoren kan også bruges på JPEGs og andre formater som din Windows kan lave thumbnails af. Under alle omstændigheder får man en Bitmap ud af det, som så selv må lave om til det ønskede format. I mit eksempel har jeg blot holdt mig til bitmaps for ikke at sløre billedet.

Jens Borrisholt