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
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
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