delphi 自动创建TPanel卡片组（图片、商品、价格）

标签：begin end 卡片 delphi Controls lv Bmp TPanel aPanle

unit g_uCreateComponentTools;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, jpeg, DBClient, ShareObj, ExtCtrls, cxControls, cxContainer, cxEdit, cxLabel;
  
type
  TImageType = (IT_None, IT_Error, IT_Bmp, IT_JPEG, IT_GIF, IT_PCX, IT_PNG, IT_PSD, IT_RAS, IT_SGI, IT_TIFF);

function fixFull2TPanel(aParentPanel: TPanel; nRows, nCols, nALLWidth, nALLHeight: Integer): Boolean;

function fixRecd2TPanel(aParentPanel: TPanel; nRows, nCols, nPageIndex: Integer; aClientDataSet: TClientDataSet): Boolean;

implementation

function fixOptChildPanel(sOpt: string; nIndex: Integer; aParentPanel: TPanel): Boolean;
var
  i, k: Integer;
  aPanle: TPanel;
  acxLabel: TcxLabel;
  aImage: TImage;
  lv_sOpt: string;
begin
  try
    lv_sOpt := LowerCase(Trim(sOpt));
    if lv_sOpt = 'disable' then
    begin
      for i := 0 to aParentPanel.ControlCount-1 do
      begin
        if aParentPanel.Controls[i] is TPanel then
        begin
          aPanle := TPanel(aParentPanel.Controls[i]);
          if aPanle.Tag >= nIndex then
          begin
            aPanle.Visible := False;
            aPanle.Hint := '';
            for k := 0 to aPanle.ControlCount - 1 do
            begin
              if aPanle.Controls[k] is TcxLabel then
                TcxLabel(aPanle.Controls[k]).Caption := ''
              else if aPanle.Controls[k] is TImage then
                TImage(aPanle.Controls[k]).Picture.Graphic := nil;
            end;
          end;
        end;
      end;
    end else if lv_sOpt = 'free' then
    begin
      while aParentPanel.ControlCount > 0 do
      begin
        if aParentPanel.Controls[0] is TPanel then
        begin
          aPanle := TPanel(aParentPanel.Controls[0]);
          while aPanle.ControlCount > 0 do
          begin
            if aPanle.Controls[0] is TcxLabel then
            begin
              acxLabel := TcxLabel(aPanle.Controls[0]);
              acxLabel.Caption := '';
              FreeAndNil(acxLabel);
            end else if aPanle.Controls[0] is TImage then
            begin
              aImage := TImage(aPanle.Controls[0]);
              aImage.Picture.Graphic := nil;
              FreeAndNil(aImage);
            end;
          end;

          aPanle.Hint := '';
          FreeAndNil(aPanle);
        end;
      end;
    end;
  except
    on e:Exception do
    begin
      ShowMessage(e.Message);
    end;
  end;
end;

function findChildPanel(aParentPanel: TPanel): TObjectHashedList;
var
  i: Integer;
  aPanle: TPanel;
begin

  try
    Result := TObjectHashedList.Create;
    for i := 0 to aParentPanel.ControlCount-1 do
    begin
      if aParentPanel.Controls[i] is TPanel then
      begin
        aPanle := TPanel(aParentPanel.Controls[i]);
        Result.AddObject(IntToStr(aPanle.Tag), aPanle);
        aPanle := nil;
      end;
    end;
  except
    on e:Exception do
    begin

    end;
  end;
end;

function CreateMyTCardPanel(nTop, nLeft, nWidth, nHeight: Integer): TPanel;
var
  aPanel: TPanel;
  aImage: TImage;
  acxLabel1, acxLabel2: TcxLabel;
  const
    C_LABLE_HEIGHT = 50;
    C_LABLE_FONTSIZE = 24;
begin
  Result := nil;
  try
    aPanel := TPanel.Create(nil);
    aPanel.BevelInner := bvNone;
    aPanel.BevelOuter := bvNone;
    aPanel.Color := clGreen;
    aPanel.SetBounds(nLeft, nTop, nWidth, nHeight);

    acxLabel1 := TcxLabel.Create(nil);
    acxLabel1.Parent := aPanel;
    acxLabel1.AutoSize := False;
    acxLabel1.Height := C_LABLE_HEIGHT;
    acxLabel1.Properties.Alignment.Horz := taCenter;
    acxLabel1.Properties.Alignment.Vert := taVCenter;
    acxLabel1.Style.Font.Size := C_LABLE_FONTSIZE;
    acxLabel1.SetBounds(0, nHeight-C_LABLE_HEIGHT, nWidth, C_LABLE_HEIGHT);
    acxLabel1.Tag := 0;

    acxLabel2 := TcxLabel.Create(nil);
    acxLabel2 := TcxLabel.Create(nil);
    acxLabel2.Parent := aPanel;
    acxLabel2.AutoSize := False;
    acxLabel2.Height := C_LABLE_HEIGHT;
    acxLabel2.Properties.Alignment.Horz := taCenter;
    acxLabel2.Properties.Alignment.Vert := taVCenter;
    acxLabel2.Style.Font.Size := C_LABLE_FONTSIZE;
    acxLabel2.SetBounds(0, nHeight-C_LABLE_HEIGHT*2, nWidth, C_LABLE_HEIGHT);
    acxLabel2.Tag := 1;

    aImage := TImage.Create(nil);
    aImage.Parent := aPanel;
    aImage.SetBounds(0, 0, nWidth, nHeight-C_LABLE_HEIGHT*2);

    Result := aPanel;
  except
    on e:Exception do
    begin

    end;
  end;
end;

function FindImageType(Buffer: Word): TImageType;
begin
  case Buffer of
    $4D42:
      Result := IT_Bmp;
    $D8FF:
      Result := IT_JPEG;
    $4947:
      Result := IT_GIF;
    $050A:
      Result := IT_PCX;
    $5089:
      Result := IT_PNG;
    $4238:
      Result := IT_PSD;
    $A659:
      Result := IT_RAS;
    $DA01:
      Result := IT_SGI;
    $4949:
      Result := IT_TIFF;
  else
    Result := IT_None;
  end;
end;

function doJpgAndBmp2TBitmap(sPicPath: string; nWidth, nHeight: Integer): TBitmap;
var
  aBuffre: Word;
  aImageType: TImageType;
  aStream: TMemoryStream;
  Jpg: TJPEGImage;
  Bmp: TBitmap;
begin
  Result := nil;
  try
    if FileExists(sPicPath) then
    begin
      aStream := TMemoryStream.Create;
      aStream.LoadFromFile(sPicPath);
      aStream.Position := 0;
      aStream.ReadBuffer(aBuffre, 2);
      try
        aImageType := FindImageType(aBuffre);
        if aImageType = IT_JPEG then
        begin
          Jpg := TJPEGImage.Create;
          Bmp := TBitmap.Create;
          try
            Jpg.LoadFromFile(sPicPath);
            Bmp.Width := nWidth;
            Bmp.Height:= nHeight;
            Bmp.Canvas.StretchDraw(Rect(0, 0, nWidth, nHeight), Jpg);
            Jpg.Assign(Bmp);
            Result := TBitmap.Create;
            Result.Assign(Jpg);
          finally
            FreeAndNil(Bmp);
            FreeAndNil(Jpg);
          end;
        end else if aImageType = IT_Bmp then
        begin
          Result := TBitMap.Create;
          Result.LoadFromFile(sPicPath);
          Bmp := TBitMap.Create;
          try
            Bmp.Width := nWidth;
            Bmp.Height := nHeight;
            Bmp.Canvas.StretchDraw(rect(0, 0, nWidth, nHeight), Result);
            Result.Assign(Bmp);
          finally
            Bmp.Free;
          end;
        end else begin
          Result := TBitMap.Create;
          Result.Height := nWidth;
          Result.Width := nHeight;
        end;
      finally
        FreeAndNil(aStream);
      end;
    end;
  except
    on e: Exception do
    begin

    end;
  end;
end;

function doTBitMapDrawPolygon(Bmp: TBitMap; sText: string): TBitMap;
var
  lf: TLogFont;
  tf: TFont;
  nWidth, nHeight: Integer;
  aPoints: array[0..2] of TPoint;
  lv_bRet: Boolean;
  lv_stemp: string;
const
  C_CORNER_LENGTH = 45;
  C_FONT_SIZE = 9;
begin
  Result := nil;
  try
    if not Assigned(Bmp) then
      Bmp := TBitmap.Create;
    if Bmp.Empty then
    begin
      Bmp.Height := 120;
      Bmp.Width := 120;
    end;
    nWidth := Bmp.Width;
    nHeight := 0;
    aPoints[0] := Point(nWidth, 0);
    aPoints[1] := Point(nWidth, C_CORNER_LENGTH);
    aPoints[2] := Point(nWidth - C_CORNER_LENGTH, 0);
    with Bmp.Canvas do
    begin
      Pen.Width := 1;
      Pen.Color := clWhite;
      Brush.Color := clMenuHighlight;
      Polygon(aPoints);
    end;
    with Bmp.Canvas do
    begin
      Font.Color := clWhite;
      Font.Size := C_FONT_SIZE;
      Font.Name := '宋体';
      tf := TFont.Create;
      tf.Assign(Font);
      GetObject(tf.Handle, sizeof(lf), @lf);
      lf.lfEscapement := -450;
      lf.lfOrientation := -450;
      tf.Handle := CreateFontIndirect(lf);
      Font.Assign(tf);
      tf.Free;
      TextOut(Bmp.Width - (C_CORNER_LENGTH div 3), 2, sText);
    end;
    Result := Bmp;
  except
    on e: Exception do
    begin

    end;
  end;
end;

procedure fixProperties2MyTCardPanel(aPanel: TPanel; sGoodsCode, sGoodsName, sPicName: string; cGoodsPrice: Currency; nFixTag: Integer);
var
  i: Integer;
  Bmp: TBitMap;
  lv_sAppPath, lv_sPicPath: string;
begin
  try
    lv_sAppPath := ExtractFilePath(ParamStr(0));
    aPanel.Hint := sGoodsCode;
    for i:= 0 to aPanel.ControlCount - 1 do
    begin
      if aPanel.Controls[i] is TcxLabel then
      begin
        if TcxLabel(aPanel.Controls[i]).Tag = 0 then
          TcxLabel(aPanel.Controls[i]).Caption := '￥' + CurrToStr(cGoodsPrice)
        else
          TcxLabel(aPanel.Controls[i]).Caption := sGoodsName;
      end else if aPanel.Controls[i] is TImage then
      begin
        lv_sPicPath := lv_sAppPath + sPicName;
        case nFixTag of
          1: Bmp := doTBitMapDrawPolygon(doJpgAndBmp2TBitmap(lv_sPicPath, TImage(aPanel.Controls[i]).Width, TImage(aPanel.Controls[i]).Height), '套餐');
          2: Bmp := doTBitMapDrawPolygon(doJpgAndBmp2TBitmap(lv_sPicPath, TImage(aPanel.Controls[i]).Width, TImage(aPanel.Controls[i]).Height), '配比');
          else
          Bmp := doJpgAndBmp2TBitmap(lv_sPicPath, TImage(aPanel.Controls[i]).Width, TImage(aPanel.Controls[i]).Height);
        end;
        TImage(aPanel.Controls[i]).Stretch := False;
        TImage(aPanel.Controls[i]).Picture.Assign(Bmp);
        Bmp.Free;
      end;
    end;
  except
    on e:Exception do
    begin

    end;
  end;
end;

function fixFull2TPanel(aParentPanel: TPanel; nRows, nCols, nALLWidth, nALLHeight: Integer): Boolean;
var
  x, y, k: Integer;
  lv_nSingleWidth, lv_nSingleHeight: Integer;
  aPanle: TPanel;
begin
  Result := False;
  try
    lv_nSingleWidth := nALLWidth div nCols;
    lv_nSingleHeight := nALLHeight div nRows;
    k := 1;
    for x := 1 to nRows do
    begin
      for y := 1 to nCols do
      begin
        aPanle := CreateMyTCardPanel((x-1)*lv_nSingleHeight, (y-1)*lv_nSingleWidth, lv_nSingleWidth, lv_nSingleHeight);
        aPanle.Parent := aParentPanel;
        aPanle.Visible := False;
        aPanle.Tag := k;
        aPanle.Caption := IntToStr(k);

        aPanle := nil;
        Inc(k);
      end;
    end;
    Result := k > 0;
  except
    on e:Exception do
    begin

    end;
  end;
end;

function fixRecd2TPanel(aParentPanel: TPanel; nRows, nCols, nPageIndex: Integer; aClientDataSet: TClientDataSet): Boolean;
var
  i, nTag, nIndex1, nIndex2: Integer;
  aHashMapTPanel: TObjectHashedList;
  aPanle: TPanel;
  lv_nTagFalg: Integer;
  lv_cGoodsPrice: Currency;
  lv_sGoodsCode, lv_sGoodsName, lv_sImageName, lv_sTmp: string;
begin
  Result := False;
  try
    nIndex1 := (nPageIndex - 1) * (nRows * nCols) + 1;
    nIndex2 := nPageIndex * (nRows * nCols);
    try
      aClientDataSet.Filtered := False;
      aClientDataSet.Filter := 'CySortNo >= ' + IntToStr(nIndex1) + ' and CySortNo <= ' + IntToStr(nIndex2);
      aClientDataSet.Filtered := True;
      if aClientDataSet.RecordCount > 0 then
      begin
        aHashMapTPanel := findChildPanel(aParentPanel);
        if aHashMapTPanel.Count > 0 then
        begin
//          fixOptChildPanel('disable', aParentPanel);
          with aClientDataSet do
          begin
            First;
            i := 1;
            while not Eof do
            begin
              lv_sTmp := IntToStr(FieldByName('CySortNo').AsInteger);
              lv_sImageName := FieldByName('CyImageName').AsString;
              lv_sGoodsCode := FieldByName('CyGoodsCode').AsString;
              lv_sGoodsName := FieldByName('CyGoodsName').AsString;
              lv_cGoodsPrice := FieldByName('CyGoodsPrice').AsCurrency;
              if FieldByName('CyPackageFlag').AsInteger = 1 then
                lv_nTagFalg := 1
              else if FieldByName('CyProportionFlag').AsInteger = 1 then
                lv_nTagFalg := 2
              else
                lv_nTagFalg := 0;
              aPanle := TPanel(aHashMapTPanel.GetByCode(IntToStr(i)));
              if aPanle <> nil then
              begin
                aPanle.Visible := True;
                fixProperties2MyTCardPanel(aPanle, lv_sGoodsCode, lv_sGoodsName, lv_sImageName, lv_cGoodsPrice, lv_nTagFalg);
              end;
            
              aPanle := nil;
              Inc(i);
              Next;
            end;
          end;
          if i <= nRows*nCols then
            fixOptChildPanel('disable', i ,aParentPanel);
        end else
          Exit;
      end else
        Exit;
      Result := i > 0;
    finally
      aClientDataSet.Filtered := False;
      aClientDataSet.Filter := '';
      aClientDataSet.Filtered := True;
    end;
  except
    on e:Exception do
    begin

    end;
  end;
end;

end.

g_uCreateComponentTools

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, cxControls, cxContainer, cxEdit, cxLabel, StdCtrls, Jpeg, DBClient, DB;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
    fv_aClientDataSet: TClientDataSet;
  public
    { Public declarations }

  end;

var
  Form1: TForm1;

implementation
uses
  g_uCreateComponentTools;
  
{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  fv_aClientDataSet := TClientDataSet.Create(nil);
  with fv_aClientDataSet do
  begin
    FieldDefs.Add('CySortNo', ftInteger, 0, False);
    FieldDefs.Add('CyGoodsCode', ftString, 512, False);
    FieldDefs.Add('CyGoodsName', ftString, 512, False);
    FieldDefs.Add('CyGoodsPrice', ftCurrency, 0, False);
    FieldDefs.Add('CyImageName', ftString, 512, False);
    FieldDefs.Add('CyPackageFlag', ftInteger, 0, False);
    FieldDefs.Add('CyProportionFlag', ftInteger, 0, False);
    CreateDataSet;
    IndexFieldNames:= 'CySortNo';  //索引
  end;
  for i := 1 to 40 do
  begin
    with fv_aClientDataSet do
    begin
      Append;
      FieldByName('CySortNo').AsInteger := i;
      FieldByName('CyGoodsCode').AsString := '商品编码' + IntToStr(i);
      FieldByName('CyGoodsName').AsString := '商品名称' + IntToStr(i);
      FieldByName('CyGoodsPrice').AsCurrency := i;
      FieldByName('CyImageName').AsString := 'GoodsName.bmp';
      FieldByName('CyPackageFlag').AsInteger := 1;
      FieldByName('CyProportionFlag').AsInteger := 1;
      Post;
    end;
  end;

  Panel1.Tag := 1;
  fixFull2TPanel(Panel1, 3, 4, Panel1.Width, Panel1.Height);
  fixRecd2TPanel(Panel1, 3, 4, Panel1.Tag, fv_aClientDataSet);
  Edit1.Text := '当前是：首页';
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if Panel1.Tag > 1 then
  begin
    if fixRecd2TPanel(Panel1, 3, 4, Panel1.Tag-1, fv_aClientDataSet) then
    begin
      Panel1.Tag := Panel1.Tag - 1;
      Edit1.Text := '当前是：第' + IntToStr(Panel1.Tag) + '页';
    end;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  if Panel1.Tag > 0 then
  begin
    if fixRecd2TPanel(Panel1, 3, 4, Panel1.Tag+1, fv_aClientDataSet) then
    begin
      Panel1.Tag := Panel1.Tag + 1;
      Edit1.Text := '当前是：第' + IntToStr(Panel1.Tag) + '页';
    end;
  end;
end;

end.

Unit1

 

标签：begin,end,卡片,delphi,Controls,lv,Bmp,TPanel,aPanle
From： https://www.cnblogs.com/studycode/p/16815320.html