View Issue Details

IDProjectCategoryView StatusLast Update
0021493LazarusIDEpublic2012-03-28 12:01
ReporterbarloneAssigned ToPaul Ishenin 
PrioritynormalSeverityminorReproducibilitysometimes
Status closedResolutionfixed 
Product Version0.9.31 (SVN)Product Build 
Target Version1.0.0Fixed in Version0.9.31 (SVN) 
Summary0021493: JCF damages source code
DescriptionI`ve attache files, damaged by JCF, some more, some less...
TagsNo tags attached.
Fixed in Revision36187,36335
LazTarget1.0
Widgetset
Attached Files
  • psnorma_original.pas (3,444 bytes)
    {$I p1comdefs.inc}
    unit psnorma;
    
    interface
    
    uses
    	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    	StdCtrls, ExtCtrls, rsListbx, postypes, JvExControls, JvLabel;
    
    type
    	TfmNorma = class(TForm)
    		Shape1: TShape;
        lTitle: TJvLabel;
    		lbNorms: TListBox;
    		tUpdPrice: TTimer;
    		procedure lbNormsDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
    		procedure lbNormsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    		procedure tUpdPriceTimer(Sender: TObject);
       procedure FormShow(Sender: TObject);
    	end;
    
    function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;
    
    var
    	fmNorma: TfmNorma   = nil;
    
    implementation
    
    uses ptypes, pkeystrm;
    
    {$R *.DFM}
    
    var
    	COwnHandle: integer = 0;
    	CItem: TFFItem      = nil;
    	PrvII: integer      = -2;
    
    function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;
    var i,n: integer;
    		ei: TFFEI;
    		ein: string;
    begin
    	COwnHandle:=AOwnHandle;
    	CItem:=AItem;
     Result := false;
    	if (AItem.Norms = nil) or (AItem.Norms.Count < 1) then exit;
    
    	if fmNorma = nil then
    		Application.CreateForm(TfmNorma, fmNorma);
    
    
    	with fmNorma do begin
    		Top:=ATop;
    		with lbNorms, Items do begin
    			Clear;
    			BeginUpdate;
    			ei:=FFEIs.GetEIByID(AItem.EID);
    			if Assigned(ei) then ein:=ei.Name
    											else ein:='???';
    			for i:=0 to AItem.Norms.Count-1 do begin
    				n:=integer(AItem.Norms.Items[i]);
    				AddObject(Format('%5.2f %s', [n / 100, ein]), TObject(n));
    			end;
    			EndUpdate;
    			n:=IndexOfObject(TObject(AItem.Norma));
    			if n >=0 then ItemIndex:=n
    							 else ItemIndex:=0;
    		end;
    		tUpdPrice.Enabled:=true;
    		Result:=(ShowModal = mrOK);
    		AItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
    		tUpdPrice.Enabled:=false;
    	end;
    end; // SelectNorm
    // -----------------------------------------------------------------------------
    procedure TfmNorma.lbNormsDrawItem(Control: TWinControl; Index: Integer;
    	Rect: TRect; State: TOwnerDrawState);
    var 	R: TRect;
    begin
    	R:=Rect;
    	with lbNorms, Canvas do begin
    		Font.Name:=fntItemsList;
    		FillRect(Rect);
    		Font.Color:=clLime;
    		Font.Size:=22;
    		TextRect(R, Rect.Left + 20, Rect.Top, Items[Index]);
    
    		R.Right:=20;
    		Font.Color:=clAqua;
    		Font.Size:=16;
    		TextRect(R, Rect.Left+2, Rect.Top+8, IntToStr(Index+1));
    	end;
    end;
    
    procedure TfmNorma.lbNormsKeyDown(Sender: TObject; var Key: Word;
    	Shift: TShiftState);
    begin
    	case Key of
    
    		vk_Return:
    			ModalResult:=mrOk;
    
       vk_F12: begin
         CItem.WaitFlag := true;
    			ModalResult:=mrOk;
       end;
    
    		vk_Escape:
    			ModalResult:=mrCancel;
    
    		49..57: begin
    			lbNorms.ItemIndex:=Key - 49;
    			CItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
    			SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
    			ModalResult:=mrOk;
    		end;
    
    		else
    			ProcessKeyStream(Key);
    
    	end;
    end;
    
    procedure TfmNorma.tUpdPriceTimer(Sender: TObject);
    begin
    	if (lbNorms.Items.Count = 1) then begin
    		ModalResult:=mrOk;
    	end;
    
    	if lbNorms.ItemIndex = PrvII then exit;
    	CItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
    	SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
    	PrvII:=lbNorms.ItemIndex;
    end;
    
    procedure TfmNorma.FormShow(Sender: TObject);
    begin
    	CItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
    	PostMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
    end;
    
    end.
    
    psnorma_original.pas (3,444 bytes)
  • psnorma_broken.pas (3,709 bytes)
              {$I p1comdefs.inc}
    unit psnorma;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
      StdCtrls, ExtCtrls, rsListbx, postypes, JvExControls, JvLabel;
    
    type
      TfmNorma = class(TForm)
        Shape1:    TShape;
        lTitle:    TJvLabel;
        lbNorms:   TListBox;
        tUpdPrice: TTimer;
        procedure lbNormsDrawItem(Control: TWinControl; Index: integer;
          Rect: TRect; State: TOwnerDrawState);
        procedure lbNormsKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
        procedure tUpdPriceTimer(Sender: TObject);
        procedure FormShow(Sender: TObject);
      end;
    
    function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;
    
    var
      fmNorma: TfmNorma = nil;
    
    implementation
    
    uses ptypes, pkeystrm;
    
    {$R *.DFM}
    
    var
      COwnHandle: integer = 0;
      CItem: TFFItem = nil;
      PrvII: integer = -2;
    
    function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;
    var
      i, n: integer;
      ei: TFFEI;
      ein: string;
    begin
      COwnHandle := AOwnHandle;
      CItem := AItem;
      Result := False;
      if (AItem.Norms = nil) or (AItem.Norms.Count < 1) then
        exit;
    
      if fmNorma = nil then
        Application.CreateForm(TfmNorma, fmNorma);
    
    
      with fmNorma do begin
        Top := ATop;
        with lbNorms, Items do begin
          Clear;
          BeginUpdate;
          ei := FFEIs.GetEIByID(AItem.EID);
          if Assigned(ei) then
            ein := ei.Name
          else
            ein := '???';
          for i := 0 to AItem.Norms.Count - 1 do begin
            n := integer(AItem.Norms.Items[i]);
            AddObject(Format('%5.2f %s', [n / 100, ein]), TObject(n));
          end;
          EndUpdate;
          n := IndexOfObject(TObject(AItem.Norma));
          if n >= 0 then
            ItemIndex := n
          else
            ItemIndex := 0;
        end;
        tUpdPrice.Enabled := True;
        Result := (ShowModal = mrOk);
        AItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
        tUpdPrice.Enabled := False;
      end;
    end; // SelectNorm
    // -----------------------------------------------------------------------------
    procedure TfmNorma.lbNormsDrawItem(Control: TWinControl; Index: integer;
      Rect: TRect; State: TOwnerDrawState);
    var
      R: TRect;
    begin
      R := Rect;
      with lbNorms, Canvas do begin
        Font.Name := fntItemsList;
        FillRect(Rect);
        Font.Color := clLime;
        Font.Size := 22;
        TextRect(R, Rect.Left + 20, Rect.Top, Items[Index]);
    
        R.Right := 20;
        Font.Color := clAqua;
        Font.Size := 16;
        TextRect(R, Rect.Left + 2, Rect.Top + 8, IntToStr(Index + 1));
      end;
    end;
    
    procedure TfmNorma.lbNormsKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
    begin
      case Key of
    
        vk_Return:
          ModalResult := mrOk;
    
        vk_F12: begin
          CItem.WaitFlag := True;
          ModalResult := mrOk;
        end;
    
        vk_Escape:
          ModalResult := mrCancel;
    
        49..57: begin
          lbNorms.ItemIndex := Key - 49;
          CItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
          SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
          ModalResult := mrOk;
        end;
    
        else
          ProcessKeyStream(Key);
    
      end;
    end;
    
    procedure TfmNorma.tUpdPriceTimer(Sender: TObject);
    begin
      if (lbNorms.Items.Count = 1) then begin
        ModalResult := mrOk;
      end;
    
      if lbNorms.ItemIndex = PrvII then
        exit;
      CItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
      SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
      PrvII := lbNorms.ItemIndex;
    end;
    end.end;  PostMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);  CItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);beginprocedure TfmNorma.FormShow(Sender: TObject);
    
    psnorma_broken.pas (3,709 bytes)
  • faskfor_original.pas (3,016 bytes)
    {$I p1comdefs.inc}
    unit faskfor;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
      ExtCtrls;
    
    type
      TfmAskFor = class(TForm)
        sFrame: TShape;
    //    aAnim: TAAnimate;
        lTitle: TLabel;
        procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
        procedure FormClose(Sender: TObject; var Action: TCloseAction);
      end;
    
    const
      mbWarning         = 0;
      mbInformation     = 1;
      mbConfirmation    = 2;
      mbWait            = 3;
      mbError           = 4;
    
      mboContBeep       = 1;
    
      mbVideoStr: packed array [mbWarning..mbError] of pchar =(
        'MB_WARN',
        'MB_INFO',
        'MB_ASK',
        'MB_WAIT',
        'MB_ERR'
      );
    
    function AMsgBox(const AMsg: string; AType: byte): boolean;
    function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
    procedure AMsgBoxClose;
    
    implementation
    
    uses Autils;
    
    {$R *.lfm}
    
    type
      TNDBeepThread = class(TThread)
        procedure Execute; override;
      end;
    
    var
      fmAskFor: TfmAskFor = nil;
      BT: TNDBeepThread    = nil;
    
    function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
    begin
      if fmAskFor = nil then
        Application.CreateForm(TfmAskFor, fmAskFor);
    
      with fmAskFor do begin
        if Showing then begin
          Result:=false;
          Exit;
        end;
        lTitle.Caption:=AMsg;
        case AType of
    
          mbWarning:
            SpeakerBeep(2000, 200);
    
          mbConfirmation:
            SpeakerBeep(1000, 200);
    
        end;
    //    aAnim.ResHandle:=HInstance;
    //    aAnim.ResName:=mbVideoStr[AType];
    //    aAnim.Reset;
    //    aAnim.Active:=true;
    
        if (AOpts and mboContBeep <> 0) and (BT = nil) then
          BT:=TNDBeepThread.Create(false);
    
        if (AType <> mbWait)  then
          Result:=(ShowModal = mrOk)
        else begin
          Result:=true;
          Show;
        end;
      end;
    end; // AMsgBoxEx
    // -----------------------------------------------------------------------------
    
    function AMsgBox(const AMsg: string; AType: byte): boolean;
    begin
      Result:=AMsgBoxEx(AMsg, AType, 0);
    end; // AMsgBox
    // -----------------------------------------------------------------------------
    
    procedure  AMsgBoxClose;
    begin
      if Assigned(fmAskFor) and fmAskFor.Showing then fmAskFor.Close;
    end; // AMsgBoxClose
    // -----------------------------------------------------------------------------
    
    procedure TNDBeepThread.Execute;
    begin
      FreeOnTerminate:=true;
      while not Terminated do begin
        Sleep(1000);
        SpeakerBeep(2000, 500);
      end;
      BT:=nil;
    end;
    // -----------------------------------------------------------------------------
    
    procedure TfmAskFor.FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    begin
      case Key of
        vk_Return: ModalResult:=mrOk;
        vk_Escape, 106: ModalResult:=mrCancel;
      end;
    end;
    
    procedure TfmAskFor.FormClose(Sender: TObject; var Action: TCloseAction);
    begin
    //  aAnim.Active:=false;
      if Assigned(BT) then BT.Terminate;
    end;
    
    end.
    
    faskfor_original.pas (3,016 bytes)
  • faskfor_broken.pas (3,016 bytes)
    {$I p1comdefs.inc}
    unit faskfor;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
      ExtCtrls;
    
    type
      TfmAskFor = class(TForm)
        sFrame: TShape;
        //    aAnim: TAAnimate;
        lTitle: TLabel;
        procedure FormKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
        procedure FormClose(Sender: TObject; var Action: TCloseAction);
      end;
    
    const
      mbWarning = 0;
      mbInformation = 1;
      mbConfirmation = 2;
      mbWait  = 3;
      mbError = 4;
    
      mboContBeep = 1;
    
      mbVideoStr: packed array [mbWarning..mbError] of PChar = (
        'MB_WARN',
        'MB_INFO',
        'MB_ASK',
        'MB_WAIT',
        'MB_ERR'
        );
    
    function AMsgBox(const AMsg: string; AType: byte): boolean;
    function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
    procedure AMsgBoxClose;
    
    implementation
    
    uses Autils;
    
    {$R *.lfm}
    
    type
      TNDBeepThread = class(TThread)
        procedure Execute; override;
      end;
    
    var
      fmAskFor: TfmAskFor = nil;
      BT: TNDBeepThread = nil;
    
    function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
    begin
      if fmAskFor = nil then
        Application.CreateForm(TfmAskFor, fmAskFor);
    
      with fmAskFor do begin
        if Showing then begin
          Result := False;
          Exit;
        end;
        lTitle.Caption := AMsg;
        case AType of
    
          mbWarning:
            SpeakerBeep(2000, 200);
    
          mbConfirmation:
            SpeakerBeep(1000, 200);
    
        end;
        //    aAnim.ResHandle:=HInstance;
        //    aAnim.ResName:=mbVideoStr[AType];
        //    aAnim.Reset;
        //    aAnim.Active:=true;
    
        if (AOpts and mboContBeep <> 0) and (BT = nil) then
          BT := TNDBeepThread.Create(False);
    
        if (AType <> mbWait) then
          Result := (ShowModal = mrOk)
        else begin
          Result := True;
          Show;
        end;
      end;
    end; // AMsgBoxEx
    // -----------------------------------------------------------------------------
    
    function AMsgBox(const AMsg: string; AType: byte): boolean;
    begin
      Result := AMsgBoxEx(AMsg, AType, 0);
    end; // AMsgBox
    // -----------------------------------------------------------------------------
    
    procedure AMsgBoxClose;
    begin
      if Assigned(fmAskFor) and fmAskFor.Showing then
        fmAskFor.Close;
    end; // AMsgBoxClose
    // -----------------------------------------------------------------------------
    
    procedure TNDBeepThread.Execute;
    begin
      FreeOnTerminate := True;
      while not Terminated do begin
        Sleep(1000);
        SpeakerBeep(2000, 500);
      end;
      BT := nil;
    end;
    // -----------------------------------------------------------------------------
    
    procedure TfmAskFor.FormKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
    begin
      case Key of
        vk_Return: ModalResult := mrOk;
        vk_Escape, 106: ModalResult := mrCancel;
      end;
    end;
    
    procedure TfmAskFor.FormClose(Sender: TObject; var Action: TCloseAction);
    begin
      //  aAnim.Active:=false;
      if Assigned(BT) then
        BT.Terminate;
    
    end.
    
    faskfor_broken.pas (3,016 bytes)
  • pselgrp_original.pas (4,696 bytes)
    {$I p1comdefs.inc}
    unit pselgrp;
    
    interface
    
    uses
      LCLType, LCLIntf, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
      StdCtrls, ExtCtrls;
    
    type
      TfmSelectGroup = class(TForm)
        pTitle: TPanel;
        lbGroups: TListBox;
        lTitle: TLabel;
        tSlide: TTimer;
        procedure lbGroupsDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
        procedure lbGroupsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
        procedure tSlideTimer(Sender: TObject);
      end;
    
    procedure SelectItemFromGroup(AGID: integer);
    
    var
      fmSelectGroup: TfmSelectGroup = nil;
    
    implementation
    
    uses postypes, ptypes, pkeystrm, pmain;
    
    {$R *.lfm}
    
    procedure SelectItemFromGroup(AGID: integer);
    var L: TFFItems;
      G: TFFGroup;
      FFI: TFFItem;
      i: integer;
      m, mi: integer;
    begin
      if fmSelectGroup = nil then
        Application.CreateForm(TfmSelectGroup, fmSelectGroup);
    
      with fmSelectGroup do begin
        setIntState(is_SELECTFROMGROUP);
        G := FFGroups.GetGroupByID(AGID);
    {$IFDEF WINDOWS}
        Left := 1024 + 5;
    {$ELSE}
        Left := 5;
    {$ENDIF}
        Top := 50;
        Height := 650;
        Width := 1024 - 10;
        if G = nil then exit;
        lTitle.Caption := G.OnScrName + ' ';
        with lbGroups, Items do begin
          Clear;
          BeginUpdate;
          if FFItems.Count > 0 then begin
            L := TFFItems.Create;
            for i := 0 to FFItems.Count - 1 do begin
              FFI := FFItems.GetItem(i);
              if FFI.GID = AGID then begin
                FFI.Norma := 100;
                L.Add(FFI);
              end;
            end;
            while L.Count > 0 do begin
              m := MaxInt;
              mi := 0;
              for i := 0 to L.Count - 1 do begin
                FFI := L.GetItem(i);
                if FFI.Order < m then begin
                  m := FFI.Order;
                  mi := i;
                end;
              end;
              FFI := L.GetItem(mi);
              AddObject(FFI.Name, FFI);
              L.Delete(mi);
            end;
            L.Free;
          end;
          EndUpdate;
          ItemIndex := 0;
        end;
    
        if ShowModal = mrOk then begin
          i := lbGroups.ItemIndex;
          if i >= 0 then begin
            FFI := TFFItem(lbGroups.Items.Objects[i]);
            EnqueueIntCom(ic_ADDFFITEM2COUNT, FFI.IID);
          end;
        end;
      end;
    end; // SelectItemFromGroup
    // -----------------------------------------------------------------------------
    
    procedure TfmSelectGroup.lbGroupsDrawItem(Control: TWinControl;
      Index: Integer; Rect: TRect; State: TOwnerDrawState);
    var FFI: TFFItem;
      FFG: TFFGroup;
      R: TRect;
      s: string;
    begin
      with lbGroups, Canvas do begin
        FFI := TFFItem(Items.Objects[Index]);
        Font.Name := fntItemsList;
        Font.Size := fszItemsList - 5;
        R := Rect;
        FillRect(Rect);
        FFG := FFGroups.GetGroupByID(FFI.GID);
        Font.Color := FFG.Color;
        R.Right := 625;
        TextRect(R, R.Left + 40, R.Top, FFI.OnScrName);
        R.Right := 35;
        Inc(R.Top, 12);
        if Index < 10 then s := IntToStr(Index + 1)
        else s := '';
        Font.Size := 18;
        Font.Color := clAqua;
        DrawText(Handle, pchar(s), length(s), R, DT_RIGHT);
    
        R := Rect;
        R.Left := 730;
        R.Right := 790;
        Font.Size := fszItemsList - 5;
        Font.Color := $0000CACA;
        s := FFI.PriceStr;
        DrawText(Handle, pchar(s), length(s), R, DT_RIGHT);
      end;
    end; // TfmSelectGroup.lbGroupsDrawItem
    // -----------------------------------------------------------------------------
    
    procedure TfmSelectGroup.lbGroupsKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    var i: integer;
    begin
      case Key of
    
        vk_Return:
          ModalResult := mrOk;
    
        vk_Escape, vk_Back:
          ModalResult := mrCancel;
    
        49..57: begin
            i := Key - 49;
            if i < lbGroups.Items.Count then begin
              lbGroups.ItemIndex := i;
              ModalResult := mrOk;
            end;
          end;
    
        vk_Up:
          if lbGroups.ItemIndex = 0 then begin
            lbGroups.ItemIndex := lbGroups.Items.Count-1;
            Key := 0;
          end;
    
        vk_Down:
          if lbGroups.ItemIndex = lbGroups.Items.Count-1 then begin
            lbGroups.ItemIndex := 0;
            Key := 0;
          end;
    
      end;
    end; // TfmSelectGroup.lbGroupsKeyDown
    // -----------------------------------------------------------------------------
    
    procedure TfmSelectGroup.tSlideTimer(Sender: TObject);
    begin
      if Height + 100 >= 484 then begin
        Height := 484;
        tSlide.Enabled := false;
      end else
        Height := Height + 100;
      Update;
    end; // TfmSelectGroup.tSlideTimer
    // -----------------------------------------------------------------------------
    
    end.
    
    
    pselgrp_original.pas (4,696 bytes)
  • pselgrp_broken.pas (4,729 bytes)
    {$I p1comdefs.inc}
    unit pselgrp;
    
    interface
    
    uses
      LCLType, LCLIntf, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
      StdCtrls, ExtCtrls;
    
    type
      TfmSelectGroup = class(TForm)
        pTitle:   TPanel;
        lbGroups: TListBox;
        lTitle:   TLabel;
        tSlide:   TTimer;
        procedure lbGroupsDrawItem(Control: TWinControl; Index: integer;
          Rect: TRect; State: TOwnerDrawState);
        procedure lbGroupsKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
        procedure tSlideTimer(Sender: TObject);
      end;
    
    procedure SelectItemFromGroup(AGID: integer);
    
    var
      fmSelectGroup: TfmSelectGroup = nil;
    
    implementation
    
    uses postypes, ptypes, pkeystrm, pmain;
    
    {$R *.lfm}
    
    procedure SelectItemFromGroup(AGID: integer);
    var
      L: TFFItems;
      G: TFFGroup;
      FFI: TFFItem;
      i: integer;
      m, mi: integer;
    begin
      if fmSelectGroup = nil then
        Application.CreateForm(TfmSelectGroup, fmSelectGroup);
    
      with fmSelectGroup do begin
        setIntState(is_SELECTFROMGROUP);
        G := FFGroups.GetGroupByID(AGID);
    {$IFDEF WINDOWS}
        Left := 1024 + 5;
    {$ELSE}
        Left := 5;
    {$ENDIF}
        Top := 50;
        Height := 650;
        Width := 1024 - 10;
        if G = nil then
          exit;
        lTitle.Caption := G.OnScrName + ' ';
        with lbGroups, Items do begin
          Clear;
          BeginUpdate;
          if FFItems.Count > 0 then begin
            L := TFFItems.Create;
            for i := 0 to FFItems.Count - 1 do begin
              FFI := FFItems.GetItem(i);
              if FFI.GID = AGID then begin
                FFI.Norma := 100;
                L.Add(FFI);
              end;
            end;
            while L.Count > 0 do begin
              m := MaxInt;
              mi := 0;
              for i := 0 to L.Count - 1 do begin
                FFI := L.GetItem(i);
                if FFI.Order < m then begin
                  m := FFI.Order;
                  mi := i;
                end;
              end;
              FFI := L.GetItem(mi);
              AddObject(FFI.Name, FFI);
              L.Delete(mi);
            end;
            L.Free;
          end;
          EndUpdate;
          ItemIndex := 0;
        end;
    
        if ShowModal = mrOk then begin
          i := lbGroups.ItemIndex;
          if i >= 0 then begin
            FFI := TFFItem(lbGroups.Items.Objects[i]);
            EnqueueIntCom(ic_ADDFFITEM2COUNT, FFI.IID);
          end;
        end;
      end;
    end; // SelectItemFromGroup
    // -----------------------------------------------------------------------------
    
    procedure TfmSelectGroup.lbGroupsDrawItem(Control: TWinControl;
      Index: integer; Rect: TRect; State: TOwnerDrawState);
    var
      FFI: TFFItem;
      FFG: TFFGroup;
      R: TRect;
      s: string;
    begin
      with lbGroups, Canvas do begin
        FFI := TFFItem(Items.Objects[Index]);
        Font.Name := fntItemsList;
        Font.Size := fszItemsList - 5;
        R := Rect;
        FillRect(Rect);
        FFG := FFGroups.GetGroupByID(FFI.GID);
        Font.Color := FFG.Color;
        R.Right := 625;
        TextRect(R, R.Left + 40, R.Top, FFI.OnScrName);
        R.Right := 35;
        Inc(R.Top, 12);
        if Index < 10 then
          s := IntToStr(Index + 1)
        else
          s := '';
        Font.Size := 18;
        Font.Color := clAqua;
        DrawText(Handle, PChar(s), length(s), R, DT_RIGHT);
    
        R := Rect;
        R.Left := 730;
        R.Right := 790;
        Font.Size := fszItemsList - 5;
        Font.Color := $0000CACA;
        s := FFI.PriceStr;
        DrawText(Handle, PChar(s), length(s), R, DT_RIGHT);
      end;
    end; // TfmSelectGroup.lbGroupsDrawItem
    // -----------------------------------------------------------------------------
    
    procedure TfmSelectGroup.lbGroupsKeyDown(Sender: TObject; var Key: word;
      Shift: TShiftState);
    var
      i: integer;
    begin
      case Key of
    
        vk_Return:
          ModalResult := mrOk;
    
        vk_Escape, vk_Back:
          ModalResult := mrCancel;
    
        49..57: begin
          i := Key - 49;
          if i < lbGroups.Items.Count then begin
            lbGroups.ItemIndex := i;
            ModalResult := mrOk;
          end;
        end;
    
        vk_Up:
          if lbGroups.ItemIndex = 0 then begin
            lbGroups.ItemIndex := lbGroups.Items.Count - 1;
            Key := 0;
          end;
    
        vk_Down:
          if lbGroups.ItemIndex = lbGroups.Items.Count - 1 then begin
            lbGroups.ItemIndex := 0;
            Key := 0;
          end;
    
      end;
    end; // TfmSelectGroup.lbGroupsKeyDown
    // -----------------------------------------------------------------------------
    
    procedure TfmSelectGroup.tSlideTimer(Sender: TObject);
    begin
      if Height + 100 >= 484 then begin
        Height := 484;
        tSlide.Enabled := False;
        Height := Height + 100;
      Update;
    end; // TfmSelectGroup.tSlideTimer
    // -----------------------------------------------------------------------------
    
    end.
      end else
    
    pselgrp_broken.pas (4,729 bytes)

Relationships

related to 0019754 acknowledged Jedi Code Format (JCF) parser needs to be replaced with codetools parser 

Activities

2012-03-16 14:12

 

psnorma_original.pas (3,444 bytes)
{$I p1comdefs.inc}
unit psnorma;

interface

uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
	StdCtrls, ExtCtrls, rsListbx, postypes, JvExControls, JvLabel;

type
	TfmNorma = class(TForm)
		Shape1: TShape;
    lTitle: TJvLabel;
		lbNorms: TListBox;
		tUpdPrice: TTimer;
		procedure lbNormsDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
		procedure lbNormsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
		procedure tUpdPriceTimer(Sender: TObject);
   procedure FormShow(Sender: TObject);
	end;

function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;

var
	fmNorma: TfmNorma   = nil;

implementation

uses ptypes, pkeystrm;

{$R *.DFM}

var
	COwnHandle: integer = 0;
	CItem: TFFItem      = nil;
	PrvII: integer      = -2;

function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;
var i,n: integer;
		ei: TFFEI;
		ein: string;
begin
	COwnHandle:=AOwnHandle;
	CItem:=AItem;
 Result := false;
	if (AItem.Norms = nil) or (AItem.Norms.Count < 1) then exit;

	if fmNorma = nil then
		Application.CreateForm(TfmNorma, fmNorma);


	with fmNorma do begin
		Top:=ATop;
		with lbNorms, Items do begin
			Clear;
			BeginUpdate;
			ei:=FFEIs.GetEIByID(AItem.EID);
			if Assigned(ei) then ein:=ei.Name
											else ein:='???';
			for i:=0 to AItem.Norms.Count-1 do begin
				n:=integer(AItem.Norms.Items[i]);
				AddObject(Format('%5.2f %s', [n / 100, ein]), TObject(n));
			end;
			EndUpdate;
			n:=IndexOfObject(TObject(AItem.Norma));
			if n >=0 then ItemIndex:=n
							 else ItemIndex:=0;
		end;
		tUpdPrice.Enabled:=true;
		Result:=(ShowModal = mrOK);
		AItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
		tUpdPrice.Enabled:=false;
	end;
end; // SelectNorm
// -----------------------------------------------------------------------------
procedure TfmNorma.lbNormsDrawItem(Control: TWinControl; Index: Integer;
	Rect: TRect; State: TOwnerDrawState);
var 	R: TRect;
begin
	R:=Rect;
	with lbNorms, Canvas do begin
		Font.Name:=fntItemsList;
		FillRect(Rect);
		Font.Color:=clLime;
		Font.Size:=22;
		TextRect(R, Rect.Left + 20, Rect.Top, Items[Index]);

		R.Right:=20;
		Font.Color:=clAqua;
		Font.Size:=16;
		TextRect(R, Rect.Left+2, Rect.Top+8, IntToStr(Index+1));
	end;
end;

procedure TfmNorma.lbNormsKeyDown(Sender: TObject; var Key: Word;
	Shift: TShiftState);
begin
	case Key of

		vk_Return:
			ModalResult:=mrOk;

   vk_F12: begin
     CItem.WaitFlag := true;
			ModalResult:=mrOk;
   end;

		vk_Escape:
			ModalResult:=mrCancel;

		49..57: begin
			lbNorms.ItemIndex:=Key - 49;
			CItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
			SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
			ModalResult:=mrOk;
		end;

		else
			ProcessKeyStream(Key);

	end;
end;

procedure TfmNorma.tUpdPriceTimer(Sender: TObject);
begin
	if (lbNorms.Items.Count = 1) then begin
		ModalResult:=mrOk;
	end;

	if lbNorms.ItemIndex = PrvII then exit;
	CItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
	SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
	PrvII:=lbNorms.ItemIndex;
end;

procedure TfmNorma.FormShow(Sender: TObject);
begin
	CItem.Norma:=integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
	PostMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
end;

end.
psnorma_original.pas (3,444 bytes)

2012-03-16 14:13

 

psnorma_broken.pas (3,709 bytes)
          {$I p1comdefs.inc}
unit psnorma;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, rsListbx, postypes, JvExControls, JvLabel;

type
  TfmNorma = class(TForm)
    Shape1:    TShape;
    lTitle:    TJvLabel;
    lbNorms:   TListBox;
    tUpdPrice: TTimer;
    procedure lbNormsDrawItem(Control: TWinControl; Index: integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure lbNormsKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
    procedure tUpdPriceTimer(Sender: TObject);
    procedure FormShow(Sender: TObject);
  end;

function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;

var
  fmNorma: TfmNorma = nil;

implementation

uses ptypes, pkeystrm;

{$R *.DFM}

var
  COwnHandle: integer = 0;
  CItem: TFFItem = nil;
  PrvII: integer = -2;

function SelectNorm(var AItem: TFFItem; ATop, AOwnHandle: integer): boolean;
var
  i, n: integer;
  ei: TFFEI;
  ein: string;
begin
  COwnHandle := AOwnHandle;
  CItem := AItem;
  Result := False;
  if (AItem.Norms = nil) or (AItem.Norms.Count < 1) then
    exit;

  if fmNorma = nil then
    Application.CreateForm(TfmNorma, fmNorma);


  with fmNorma do begin
    Top := ATop;
    with lbNorms, Items do begin
      Clear;
      BeginUpdate;
      ei := FFEIs.GetEIByID(AItem.EID);
      if Assigned(ei) then
        ein := ei.Name
      else
        ein := '???';
      for i := 0 to AItem.Norms.Count - 1 do begin
        n := integer(AItem.Norms.Items[i]);
        AddObject(Format('%5.2f %s', [n / 100, ein]), TObject(n));
      end;
      EndUpdate;
      n := IndexOfObject(TObject(AItem.Norma));
      if n >= 0 then
        ItemIndex := n
      else
        ItemIndex := 0;
    end;
    tUpdPrice.Enabled := True;
    Result := (ShowModal = mrOk);
    AItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
    tUpdPrice.Enabled := False;
  end;
end; // SelectNorm
// -----------------------------------------------------------------------------
procedure TfmNorma.lbNormsDrawItem(Control: TWinControl; Index: integer;
  Rect: TRect; State: TOwnerDrawState);
var
  R: TRect;
begin
  R := Rect;
  with lbNorms, Canvas do begin
    Font.Name := fntItemsList;
    FillRect(Rect);
    Font.Color := clLime;
    Font.Size := 22;
    TextRect(R, Rect.Left + 20, Rect.Top, Items[Index]);

    R.Right := 20;
    Font.Color := clAqua;
    Font.Size := 16;
    TextRect(R, Rect.Left + 2, Rect.Top + 8, IntToStr(Index + 1));
  end;
end;

procedure TfmNorma.lbNormsKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
begin
  case Key of

    vk_Return:
      ModalResult := mrOk;

    vk_F12: begin
      CItem.WaitFlag := True;
      ModalResult := mrOk;
    end;

    vk_Escape:
      ModalResult := mrCancel;

    49..57: begin
      lbNorms.ItemIndex := Key - 49;
      CItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
      SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
      ModalResult := mrOk;
    end;

    else
      ProcessKeyStream(Key);

  end;
end;

procedure TfmNorma.tUpdPriceTimer(Sender: TObject);
begin
  if (lbNorms.Items.Count = 1) then begin
    ModalResult := mrOk;
  end;

  if lbNorms.ItemIndex = PrvII then
    exit;
  CItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);
  SendMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);
  PrvII := lbNorms.ItemIndex;
end;
end.end;  PostMessage(COwnHandle, WM_UPDATEPRICE, 0, 0);  CItem.Norma := integer(lbNorms.Items.Objects[lbNorms.ItemIndex]);beginprocedure TfmNorma.FormShow(Sender: TObject);
psnorma_broken.pas (3,709 bytes)

2012-03-16 14:15

 

faskfor_original.pas (3,016 bytes)
{$I p1comdefs.inc}
unit faskfor;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TfmAskFor = class(TForm)
    sFrame: TShape;
//    aAnim: TAAnimate;
    lTitle: TLabel;
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  end;

const
  mbWarning         = 0;
  mbInformation     = 1;
  mbConfirmation    = 2;
  mbWait            = 3;
  mbError           = 4;

  mboContBeep       = 1;

  mbVideoStr: packed array [mbWarning..mbError] of pchar =(
    'MB_WARN',
    'MB_INFO',
    'MB_ASK',
    'MB_WAIT',
    'MB_ERR'
  );

function AMsgBox(const AMsg: string; AType: byte): boolean;
function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
procedure AMsgBoxClose;

implementation

uses Autils;

{$R *.lfm}

type
  TNDBeepThread = class(TThread)
    procedure Execute; override;
  end;

var
  fmAskFor: TfmAskFor = nil;
  BT: TNDBeepThread    = nil;

function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
begin
  if fmAskFor = nil then
    Application.CreateForm(TfmAskFor, fmAskFor);

  with fmAskFor do begin
    if Showing then begin
      Result:=false;
      Exit;
    end;
    lTitle.Caption:=AMsg;
    case AType of

      mbWarning:
        SpeakerBeep(2000, 200);

      mbConfirmation:
        SpeakerBeep(1000, 200);

    end;
//    aAnim.ResHandle:=HInstance;
//    aAnim.ResName:=mbVideoStr[AType];
//    aAnim.Reset;
//    aAnim.Active:=true;

    if (AOpts and mboContBeep <> 0) and (BT = nil) then
      BT:=TNDBeepThread.Create(false);

    if (AType <> mbWait)  then
      Result:=(ShowModal = mrOk)
    else begin
      Result:=true;
      Show;
    end;
  end;
end; // AMsgBoxEx
// -----------------------------------------------------------------------------

function AMsgBox(const AMsg: string; AType: byte): boolean;
begin
  Result:=AMsgBoxEx(AMsg, AType, 0);
end; // AMsgBox
// -----------------------------------------------------------------------------

procedure  AMsgBoxClose;
begin
  if Assigned(fmAskFor) and fmAskFor.Showing then fmAskFor.Close;
end; // AMsgBoxClose
// -----------------------------------------------------------------------------

procedure TNDBeepThread.Execute;
begin
  FreeOnTerminate:=true;
  while not Terminated do begin
    Sleep(1000);
    SpeakerBeep(2000, 500);
  end;
  BT:=nil;
end;
// -----------------------------------------------------------------------------

procedure TfmAskFor.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  case Key of
    vk_Return: ModalResult:=mrOk;
    vk_Escape, 106: ModalResult:=mrCancel;
  end;
end;

procedure TfmAskFor.FormClose(Sender: TObject; var Action: TCloseAction);
begin
//  aAnim.Active:=false;
  if Assigned(BT) then BT.Terminate;
end;

end.
faskfor_original.pas (3,016 bytes)

2012-03-16 14:15

 

faskfor_broken.pas (3,016 bytes)
{$I p1comdefs.inc}
unit faskfor;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TfmAskFor = class(TForm)
    sFrame: TShape;
    //    aAnim: TAAnimate;
    lTitle: TLabel;
    procedure FormKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  end;

const
  mbWarning = 0;
  mbInformation = 1;
  mbConfirmation = 2;
  mbWait  = 3;
  mbError = 4;

  mboContBeep = 1;

  mbVideoStr: packed array [mbWarning..mbError] of PChar = (
    'MB_WARN',
    'MB_INFO',
    'MB_ASK',
    'MB_WAIT',
    'MB_ERR'
    );

function AMsgBox(const AMsg: string; AType: byte): boolean;
function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
procedure AMsgBoxClose;

implementation

uses Autils;

{$R *.lfm}

type
  TNDBeepThread = class(TThread)
    procedure Execute; override;
  end;

var
  fmAskFor: TfmAskFor = nil;
  BT: TNDBeepThread = nil;

function AMsgBoxEx(const AMsg: string; AType: byte; Aopts: integer): boolean;
begin
  if fmAskFor = nil then
    Application.CreateForm(TfmAskFor, fmAskFor);

  with fmAskFor do begin
    if Showing then begin
      Result := False;
      Exit;
    end;
    lTitle.Caption := AMsg;
    case AType of

      mbWarning:
        SpeakerBeep(2000, 200);

      mbConfirmation:
        SpeakerBeep(1000, 200);

    end;
    //    aAnim.ResHandle:=HInstance;
    //    aAnim.ResName:=mbVideoStr[AType];
    //    aAnim.Reset;
    //    aAnim.Active:=true;

    if (AOpts and mboContBeep <> 0) and (BT = nil) then
      BT := TNDBeepThread.Create(False);

    if (AType <> mbWait) then
      Result := (ShowModal = mrOk)
    else begin
      Result := True;
      Show;
    end;
  end;
end; // AMsgBoxEx
// -----------------------------------------------------------------------------

function AMsgBox(const AMsg: string; AType: byte): boolean;
begin
  Result := AMsgBoxEx(AMsg, AType, 0);
end; // AMsgBox
// -----------------------------------------------------------------------------

procedure AMsgBoxClose;
begin
  if Assigned(fmAskFor) and fmAskFor.Showing then
    fmAskFor.Close;
end; // AMsgBoxClose
// -----------------------------------------------------------------------------

procedure TNDBeepThread.Execute;
begin
  FreeOnTerminate := True;
  while not Terminated do begin
    Sleep(1000);
    SpeakerBeep(2000, 500);
  end;
  BT := nil;
end;
// -----------------------------------------------------------------------------

procedure TfmAskFor.FormKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
begin
  case Key of
    vk_Return: ModalResult := mrOk;
    vk_Escape, 106: ModalResult := mrCancel;
  end;
end;

procedure TfmAskFor.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  //  aAnim.Active:=false;
  if Assigned(BT) then
    BT.Terminate;

end.
faskfor_broken.pas (3,016 bytes)

barlone

2012-03-16 14:18

reporter   ~0057725

Problem occurs only with IDE compled by FPC 2.7 (svn r20475 in my case)

Paul Ishenin

2012-03-21 05:13

manager   ~0057865

Please test and close if ok.

barlone

2012-03-22 11:58

reporter   ~0057911

Thanks, been better, but the some problems remains, i`ve attached files, look at the end...

2012-03-22 11:59

 

pselgrp_original.pas (4,696 bytes)
{$I p1comdefs.inc}
unit pselgrp;

interface

uses
  LCLType, LCLIntf, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TfmSelectGroup = class(TForm)
    pTitle: TPanel;
    lbGroups: TListBox;
    lTitle: TLabel;
    tSlide: TTimer;
    procedure lbGroupsDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
    procedure lbGroupsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure tSlideTimer(Sender: TObject);
  end;

procedure SelectItemFromGroup(AGID: integer);

var
  fmSelectGroup: TfmSelectGroup = nil;

implementation

uses postypes, ptypes, pkeystrm, pmain;

{$R *.lfm}

procedure SelectItemFromGroup(AGID: integer);
var L: TFFItems;
  G: TFFGroup;
  FFI: TFFItem;
  i: integer;
  m, mi: integer;
begin
  if fmSelectGroup = nil then
    Application.CreateForm(TfmSelectGroup, fmSelectGroup);

  with fmSelectGroup do begin
    setIntState(is_SELECTFROMGROUP);
    G := FFGroups.GetGroupByID(AGID);
{$IFDEF WINDOWS}
    Left := 1024 + 5;
{$ELSE}
    Left := 5;
{$ENDIF}
    Top := 50;
    Height := 650;
    Width := 1024 - 10;
    if G = nil then exit;
    lTitle.Caption := G.OnScrName + ' ';
    with lbGroups, Items do begin
      Clear;
      BeginUpdate;
      if FFItems.Count > 0 then begin
        L := TFFItems.Create;
        for i := 0 to FFItems.Count - 1 do begin
          FFI := FFItems.GetItem(i);
          if FFI.GID = AGID then begin
            FFI.Norma := 100;
            L.Add(FFI);
          end;
        end;
        while L.Count > 0 do begin
          m := MaxInt;
          mi := 0;
          for i := 0 to L.Count - 1 do begin
            FFI := L.GetItem(i);
            if FFI.Order < m then begin
              m := FFI.Order;
              mi := i;
            end;
          end;
          FFI := L.GetItem(mi);
          AddObject(FFI.Name, FFI);
          L.Delete(mi);
        end;
        L.Free;
      end;
      EndUpdate;
      ItemIndex := 0;
    end;

    if ShowModal = mrOk then begin
      i := lbGroups.ItemIndex;
      if i >= 0 then begin
        FFI := TFFItem(lbGroups.Items.Objects[i]);
        EnqueueIntCom(ic_ADDFFITEM2COUNT, FFI.IID);
      end;
    end;
  end;
end; // SelectItemFromGroup
// -----------------------------------------------------------------------------

procedure TfmSelectGroup.lbGroupsDrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
var FFI: TFFItem;
  FFG: TFFGroup;
  R: TRect;
  s: string;
begin
  with lbGroups, Canvas do begin
    FFI := TFFItem(Items.Objects[Index]);
    Font.Name := fntItemsList;
    Font.Size := fszItemsList - 5;
    R := Rect;
    FillRect(Rect);
    FFG := FFGroups.GetGroupByID(FFI.GID);
    Font.Color := FFG.Color;
    R.Right := 625;
    TextRect(R, R.Left + 40, R.Top, FFI.OnScrName);
    R.Right := 35;
    Inc(R.Top, 12);
    if Index < 10 then s := IntToStr(Index + 1)
    else s := '';
    Font.Size := 18;
    Font.Color := clAqua;
    DrawText(Handle, pchar(s), length(s), R, DT_RIGHT);

    R := Rect;
    R.Left := 730;
    R.Right := 790;
    Font.Size := fszItemsList - 5;
    Font.Color := $0000CACA;
    s := FFI.PriceStr;
    DrawText(Handle, pchar(s), length(s), R, DT_RIGHT);
  end;
end; // TfmSelectGroup.lbGroupsDrawItem
// -----------------------------------------------------------------------------

procedure TfmSelectGroup.lbGroupsKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var i: integer;
begin
  case Key of

    vk_Return:
      ModalResult := mrOk;

    vk_Escape, vk_Back:
      ModalResult := mrCancel;

    49..57: begin
        i := Key - 49;
        if i < lbGroups.Items.Count then begin
          lbGroups.ItemIndex := i;
          ModalResult := mrOk;
        end;
      end;

    vk_Up:
      if lbGroups.ItemIndex = 0 then begin
        lbGroups.ItemIndex := lbGroups.Items.Count-1;
        Key := 0;
      end;

    vk_Down:
      if lbGroups.ItemIndex = lbGroups.Items.Count-1 then begin
        lbGroups.ItemIndex := 0;
        Key := 0;
      end;

  end;
end; // TfmSelectGroup.lbGroupsKeyDown
// -----------------------------------------------------------------------------

procedure TfmSelectGroup.tSlideTimer(Sender: TObject);
begin
  if Height + 100 >= 484 then begin
    Height := 484;
    tSlide.Enabled := false;
  end else
    Height := Height + 100;
  Update;
end; // TfmSelectGroup.tSlideTimer
// -----------------------------------------------------------------------------

end.

pselgrp_original.pas (4,696 bytes)

2012-03-22 11:59

 

pselgrp_broken.pas (4,729 bytes)
{$I p1comdefs.inc}
unit pselgrp;

interface

uses
  LCLType, LCLIntf, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TfmSelectGroup = class(TForm)
    pTitle:   TPanel;
    lbGroups: TListBox;
    lTitle:   TLabel;
    tSlide:   TTimer;
    procedure lbGroupsDrawItem(Control: TWinControl; Index: integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure lbGroupsKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
    procedure tSlideTimer(Sender: TObject);
  end;

procedure SelectItemFromGroup(AGID: integer);

var
  fmSelectGroup: TfmSelectGroup = nil;

implementation

uses postypes, ptypes, pkeystrm, pmain;

{$R *.lfm}

procedure SelectItemFromGroup(AGID: integer);
var
  L: TFFItems;
  G: TFFGroup;
  FFI: TFFItem;
  i: integer;
  m, mi: integer;
begin
  if fmSelectGroup = nil then
    Application.CreateForm(TfmSelectGroup, fmSelectGroup);

  with fmSelectGroup do begin
    setIntState(is_SELECTFROMGROUP);
    G := FFGroups.GetGroupByID(AGID);
{$IFDEF WINDOWS}
    Left := 1024 + 5;
{$ELSE}
    Left := 5;
{$ENDIF}
    Top := 50;
    Height := 650;
    Width := 1024 - 10;
    if G = nil then
      exit;
    lTitle.Caption := G.OnScrName + ' ';
    with lbGroups, Items do begin
      Clear;
      BeginUpdate;
      if FFItems.Count > 0 then begin
        L := TFFItems.Create;
        for i := 0 to FFItems.Count - 1 do begin
          FFI := FFItems.GetItem(i);
          if FFI.GID = AGID then begin
            FFI.Norma := 100;
            L.Add(FFI);
          end;
        end;
        while L.Count > 0 do begin
          m := MaxInt;
          mi := 0;
          for i := 0 to L.Count - 1 do begin
            FFI := L.GetItem(i);
            if FFI.Order < m then begin
              m := FFI.Order;
              mi := i;
            end;
          end;
          FFI := L.GetItem(mi);
          AddObject(FFI.Name, FFI);
          L.Delete(mi);
        end;
        L.Free;
      end;
      EndUpdate;
      ItemIndex := 0;
    end;

    if ShowModal = mrOk then begin
      i := lbGroups.ItemIndex;
      if i >= 0 then begin
        FFI := TFFItem(lbGroups.Items.Objects[i]);
        EnqueueIntCom(ic_ADDFFITEM2COUNT, FFI.IID);
      end;
    end;
  end;
end; // SelectItemFromGroup
// -----------------------------------------------------------------------------

procedure TfmSelectGroup.lbGroupsDrawItem(Control: TWinControl;
  Index: integer; Rect: TRect; State: TOwnerDrawState);
var
  FFI: TFFItem;
  FFG: TFFGroup;
  R: TRect;
  s: string;
begin
  with lbGroups, Canvas do begin
    FFI := TFFItem(Items.Objects[Index]);
    Font.Name := fntItemsList;
    Font.Size := fszItemsList - 5;
    R := Rect;
    FillRect(Rect);
    FFG := FFGroups.GetGroupByID(FFI.GID);
    Font.Color := FFG.Color;
    R.Right := 625;
    TextRect(R, R.Left + 40, R.Top, FFI.OnScrName);
    R.Right := 35;
    Inc(R.Top, 12);
    if Index < 10 then
      s := IntToStr(Index + 1)
    else
      s := '';
    Font.Size := 18;
    Font.Color := clAqua;
    DrawText(Handle, PChar(s), length(s), R, DT_RIGHT);

    R := Rect;
    R.Left := 730;
    R.Right := 790;
    Font.Size := fszItemsList - 5;
    Font.Color := $0000CACA;
    s := FFI.PriceStr;
    DrawText(Handle, PChar(s), length(s), R, DT_RIGHT);
  end;
end; // TfmSelectGroup.lbGroupsDrawItem
// -----------------------------------------------------------------------------

procedure TfmSelectGroup.lbGroupsKeyDown(Sender: TObject; var Key: word;
  Shift: TShiftState);
var
  i: integer;
begin
  case Key of

    vk_Return:
      ModalResult := mrOk;

    vk_Escape, vk_Back:
      ModalResult := mrCancel;

    49..57: begin
      i := Key - 49;
      if i < lbGroups.Items.Count then begin
        lbGroups.ItemIndex := i;
        ModalResult := mrOk;
      end;
    end;

    vk_Up:
      if lbGroups.ItemIndex = 0 then begin
        lbGroups.ItemIndex := lbGroups.Items.Count - 1;
        Key := 0;
      end;

    vk_Down:
      if lbGroups.ItemIndex = lbGroups.Items.Count - 1 then begin
        lbGroups.ItemIndex := 0;
        Key := 0;
      end;

  end;
end; // TfmSelectGroup.lbGroupsKeyDown
// -----------------------------------------------------------------------------

procedure TfmSelectGroup.tSlideTimer(Sender: TObject);
begin
  if Height + 100 >= 484 then begin
    Height := 484;
    tSlide.Enabled := False;
    Height := Height + 100;
  Update;
end; // TfmSelectGroup.tSlideTimer
// -----------------------------------------------------------------------------

end.
  end else
pselgrp_broken.pas (4,729 bytes)

Paul Ishenin

2012-03-26 03:39

manager   ~0058024

Please test and close if ok.

Issue History

Date Modified Username Field Change
2012-03-16 14:12 barlone New Issue
2012-03-16 14:12 barlone File Added: psnorma_original.pas
2012-03-16 14:13 barlone File Added: psnorma_broken.pas
2012-03-16 14:15 barlone File Added: faskfor_original.pas
2012-03-16 14:15 barlone File Added: faskfor_broken.pas
2012-03-16 14:18 barlone Note Added: 0057725
2012-03-16 15:43 Vincent Snijders LazTarget => 1.0
2012-03-16 15:43 Vincent Snijders Assigned To => Paul Ishenin
2012-03-16 15:43 Vincent Snijders Status new => assigned
2012-03-16 15:43 Vincent Snijders Target Version => 1.0.0
2012-03-21 05:13 Paul Ishenin Fixed in Revision => 36187
2012-03-21 05:13 Paul Ishenin Status assigned => resolved
2012-03-21 05:13 Paul Ishenin Fixed in Version => 0.9.31 (SVN)
2012-03-21 05:13 Paul Ishenin Resolution open => fixed
2012-03-21 05:13 Paul Ishenin Note Added: 0057865
2012-03-22 11:58 barlone Status resolved => assigned
2012-03-22 11:58 barlone Resolution fixed => reopened
2012-03-22 11:58 barlone Note Added: 0057911
2012-03-22 11:59 barlone File Added: pselgrp_original.pas
2012-03-22 11:59 barlone File Added: pselgrp_broken.pas
2012-03-22 18:22 Juha Manninen Relationship added related to 0019754
2012-03-26 03:39 Paul Ishenin Fixed in Revision 36187 => 36187,36335
2012-03-26 03:39 Paul Ishenin Status assigned => resolved
2012-03-26 03:39 Paul Ishenin Resolution reopened => fixed
2012-03-26 03:39 Paul Ishenin Note Added: 0058024
2012-03-28 12:01 barlone Status resolved => closed