I am doing a project for school. I have written code to populate two string grids in a calendar style. The second string grid (StringGrid2) shows the month after the first (StringGrid1). This is all done in the following upDateCalendar() procedure that receives an integer iMonthChange to indicate if the user wants to view one month forward (iMonthchange := 1) or one month back (iMonthChange := -1).
Here is the populating procedure:
procedure TStudentDashboard.upDateCalendar(iMonthChange: integer);
var
iNumDaysinMonth, iWeekCount: integer;
tNewMonthStart, tTempMonth: TDateTime;
tYear, tMonth, tDay: Word;
I, ARow: integer;
begin
// date inputs
tFirstStudyDate := dtpicker.Date;
updateCheckBoxes;
iStudySessionDuration :=
strToInt((cmbStudySessionLength.Items[cmbStudySessionLength.ItemIndex][1] +
cmbStudySessionLength.Items[cmbStudySessionLength.ItemIndex][2]));
tLastStudyDate := arrCourses[iCourseArrayPointer].lastStudyDate
(tFirstStudyDate, iStudySessionDuration, arrWeekDaysSelected);
bDrawPastTestDate := false;
// populate fixed row
for I := 0 to StringGrid1.RowCount - 1 do
StringGrid1.Rows[I].Clear;
StringGrid1.Cells[0, 0] := 'Mon';
StringGrid1.Cells[1, 0] := 'Tue';
StringGrid1.Cells[2, 0] := 'Wed';
StringGrid1.Cells[3, 0] := 'Thu';
StringGrid1.Cells[4, 0] := 'Fri';
StringGrid1.Cells[5, 0] := 'Sat';
StringGrid1.Cells[6, 0] := 'Sun';
// increment month
tNewMonthStart := IncMonth(tCurrentShowMonthStart, iMonthChange);
iWeekCount := 1;
tTempMonth := tNewMonthStart;
for I := 1 to DaysInMonth(tNewMonthStart) do
begin
tTempMonth := IncDay(tNewMonthStart, I - 1);
if (arrCourses[iCourseArrayPointer].getTestDate <> 'click here to book') or
(bBookingTest = true) then
begin
if (arrCourses[iCourseArrayPointer].getTestDate <> 'click here to book') then
begin
tTestDate := strToDate(arrCourses[iCourseArrayPointer].getTestDate);
end
else
begin
tTestDate := dtpckerTestDate.Date;
end;
if tTempMonth = tTestDate then
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
iCalendarATestDateXVal := DayOfTheWeek(tTempMonth) - 1;
iCalendarATestDateYVal := iWeekCount;
bDrawPastTestDate := true;
end
else
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
end;
if (tTempMonth < StrToDate(arrCourses[iCourseArrayPointer].getTestDate))
and (I = DaysInMonth(tNewMonthStart)) then
begin
bDrawPastTestDate := true;
iCalendarATestDateXVal := 6;
iCalendarATestDateYVal := 6;
end;
if (tTempMonth > StrToDate(arrCourses[iCourseArrayPointer].getTestDate))
and (I = 1) then
begin
bDrawPastTestDate := true;
iCalendarATestDateXVal := 0;
iCalendarATestDateYVal := 0;
end;
end
else
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
bDrawPastTestDate := false;
end;
if (tTempMonth < tLastStudyDate) and (I = DaysInMonth(tNewMonthStart)) then
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set at last cell because date to stop colouring is on next stringgrid/month
iCalendarALastStudyDateXVal := 6;
iCalendarALastStudyDateYVal := 6;
end;
if (tTempMonth > tLastStudyDate) and (I = 1) then
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set at last cell because date to stop colouring is on previous month
iCalendarALastStudyDateXVal := 0;
iCalendarALastStudyDateYVal := 0;
end;
if tTempMonth = tLastStudyDate then
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
iCalendarALastStudyDateXVal := DayOfTheWeek(tTempMonth) - 1;
iCalendarALastStudyDateYVal := iWeekCount;
end;
if (tTempMonth < tFirstStudyDate) and (I = DaysInMonth(tNewMonthStart)) then
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set at last cell because date to stop colouring is on next stringgrid/month
iCalendarAFirstStudyDateXVal := 6;
iCalendarAFirstStudyDateYVal := 6;
end;
if (tTempMonth > tFirstStudyDate) and (I = 1) then
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set at last cell because date to stop colouring is on previous month
iCalendarAFirstStudyDateXVal := 0;
iCalendarAFirstStudyDateYVal := 0;
end;
if tTempMonth = tLastStudyDate then
begin
StringGrid1.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set date x and y values to be highlighted
iCalendarAFirstStudyDateXVal := DayOfTheWeek(tTempMonth) - 1;
iCalendarAFirstStudyDateYVal := iWeekCount;
end;
if DayOfTheWeek(tTempMonth) = 7 then
begin
Inc(iWeekCount);
end;
end;
// iMonth1LastXVal := DayOfWeek(IncDay(tNewMonthStart,
// (DaysInMonth(tNewMonthStart) - 1) - 1)) - 1;
// iMonth1LastYVal := iWeekCount;
tCurrentShowMonthStart := tNewMonthStart;
lblMonth1.Caption := LongMonthNames[MonthOf(tCurrentShowMonthStart)];
lblMonth2.Caption := LongMonthNames
[MonthOf(IncMonth(tCurrentShowMonthStart))];
lblYear1.Caption := IntToStr(YearOf(tCurrentShowMonthStart));
lblYear2.Caption := IntToStr(YearOf(IncMonth(tCurrentShowMonthStart)));
// populate fixed row
for I := 0 to StringGrid2.ColCount - 1 do
StringGrid2.Cols[I].Clear;
with StringGrid2 do
begin
Cells[0, 0] := 'Mon';
Cells[1, 0] := 'Tue';
Cells[2, 0] := 'Wed';
Cells[3, 0] := 'Thu';
Cells[4, 0] := 'Fri';
Cells[5, 0] := 'Sat';
Cells[6, 0] := 'Sun';
end;
// increment to month after first stringgrid
tNewMonthStart := IncMonth(tCurrentShowMonthStart, 1);
iWeekCount := 1;
tTempMonth := tNewMonthStart;
for I := 1 to DaysInMonth(tNewMonthStart) do
begin
tTempMonth := IncDay(tNewMonthStart, I - 1);
if arrCourses[iCourseArrayPointer].getTestDate <> 'click here to book' then
begin
if tTempMonth = strToDate(arrCourses[iCourseArrayPointer].getTestDate) then
begin
// save x and y values if test date is on this stringgrid
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
iCalendarBTestDateXVal := DayOfTheWeek(tTempMonth) - 1;
iCalendarBTestDateYVal := iWeekCount;
bDrawPastTestDate := true;
end
else
begin
// otherwise just populate
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
end;
if (tTempMonth < StrToDate(arrCourses[iCourseArrayPointer].getTestDate))
and (I = DaysInMonth(tNewMonthStart)) then
begin
// set x and y values to last cell because date to be highlightted is in next month
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
bDrawPastTestDate := true;
iCalendarBTestDateXVal := 6;
iCalendarBTestDateYVal := 6;
end;
if (tTempMonth > StrToDate(arrCourses[iCourseArrayPointer].getTestDate))
and (I = 1) then
begin
// set x and y values to first because date to be highlightted is in prior month/stringgrid
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
bDrawPastTestDate := true;
iCalendarBTestDateXVal := 0;
iCalendarBTestDateYVal := 0;
end;
end
else
begin
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// otherwise just populate
bDrawPastTestDate := false;
end;
if (tTempMonth < tLastStudyDate) and (I = DaysInMonth(tNewMonthStart)) then
begin
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set x and y values to last cell because last cell to be higlighted is in next month
iCalendarBLastStudyDateXVal := 6;
iCalendarBLastStudyDateYVal := 6;
end;
if (tTempMonth > tLastStudyDate) and (I = 1) then
begin
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set x and y values to last cell because last cell to be higlighted is in prior month/stringgrid
iCalendarBLastStudyDateXVal := 0;
iCalendarBLastStudyDateYVal := 0;
end;
if tTempMonth = tLastStudyDate then
begin
StringGrid2.Cells[DayOfTheWeek(tTempMonth) - 1, iWeekCount] :=
IntToStr(DayOfTheMonth(tTempMonth));
// set x and y values to current cell
iCalendarBLastStudyDateXVal := DayOfTheWeek(tTempMonth) - 1;
iCalendarBLastStudyDateYVal := iWeekCount;
end;
if DayOfTheWeek(tTempMonth) = 7 then
begin
Inc(iWeekCount);
end;
end;
// iMonth2LastXVal := DayOfWeek(IncDay(tNewMonthStart,
// (DaysInMonth(tNewMonthStart) - 1) - 1)) - 1;
// iMonth2LastYVal := iWeekCount;
StringGrid1.refresh;
StringGrid2.refresh;
// ShowMessage(IntToStr(iCal2LastStudyDateXVal));
// ShowMessage(IntToStr(iCal2LastStudyDateYVal));
end;
The next procedure is the OnDrawCell procedure that runs every time something on a string grid changes. It is basically identical for StringGrid1 as StringGrid2, except that wherever a variable is iCalendarB... it would be iCalendarA... for StringGrid1DrawCell().
Read the comments for further explanation on how the cell colouring works. But basically, it uses the x and y values saved by the upDateCalendar() procedure to determine which cells should be highlighted. See the image below for the result.
My issue is that somewhere the OnDrawCell is constantly being called, or something is causing the StringGrids to continuously update.
procedure TStudentDashboard.StringGrid2DrawCell(Sender: TObject;
ACol, ARow: integer; Rect: TRect; State: TGridDrawState);
begin
StringGrid2.Selection := TGridRect(Rect);
// if the cell is not empty or fixed
if (StringGrid2.Cells[ACol, ARow] <> '') and (ARow > 0) then
begin
// if the weekday of the cell corresponds with checkboxes
if (arrWeekDaysSelected[ACol] = true) then
begin
// if the cell has these x and y values make it yellow
if (ACol = iCalendarBLastStudyDateXVal) and
(ARow = iCalendarBLastStudyDateYVal) then
begin
StringGrid2.Canvas.Brush.Color := $008BECFA; // yellow
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
// StringGrid2.Cells[ACol, ARow] := Copy(StringGrid2.Cells[ACol, ARow],1,StringGrid2.Cells[ACol, ARow].Length-1);
end
// only colour the following if the cell has x and y values smaller than i...LastStudyDate..X/Yval
else if (ARow < iCalendarBLastStudyDateYVal) or
((ACol < iCalendarBLastStudyDateXVal) and
(ARow = iCalendarBLastStudyDateYVal)) then
begin
// if the cell has x and y values larger than i...TestDate..X/Yval make red
if (bDrawPastTestDate = true) and
(((ARow >= iCalendarBTestDateYVal) and (ACol > iCalendarBTestDateXVal)
) or (ARow > iCalendarBTestDateYVal)) then
begin
StringGrid2.Canvas.Brush.Color := $00A49FF9; // red
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
end
// otherwise make it green
else
begin
StringGrid2.Canvas.Brush.Color := $00A4F99F; // green
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
end;
end
// otherwise make white
else
begin
StringGrid2.Canvas.Brush.Color := $00F1FFFB;
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
end;
end
// if cell is the test date make blue
else if (ACol = iCalendarBTestDateXVal) and (ARow = iCalendarBTestDateYVal)
then
begin
StringGrid2.Canvas.Brush.Color := $00F9A49F; // blue
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
// StringGrid2.Cells[ACol, ARow] := copy(StringGrid2.Cells[ACol, ARow],1,StringGrid2.Cells[ACol, ARow].Length-1);
bDrawPastTestDate := true;
end
//otherwise make white
else
begin
StringGrid2.Canvas.Brush.Color := $00F1FFFB;
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
end;
end
else if gdFixed in State then
begin
end
//otherwise make white
else if gdSelected in State then
begin
StringGrid2.Canvas.Brush.Color := $00F1FFFB;
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
end
//otherwise make white
else
begin
StringGrid2.Canvas.Brush.Color := $00F1FFFB;
StringGrid2.Canvas.Font.Name := 'Roboto Lt';
StringGrid2.Canvas.FillRect(Rect);
StringGrid2.Canvas.TextOut(Rect.Left + 3, Rect.Top + 3,
StringGrid2.Cells[ACol, ARow]);
end;
end;
My goal is to stop the redraw loop and flickering. The flickering I can easily remove using DoubleBuffered := true, however the event still runs continuously keeping other controls from updated (for example, the CheckBoxes work, but you don't see the tick). I assume that's because of the loop?
Related
I am trying to animate a dropdown menu of 7 images using a for loop, using a different component to change after each iteration of the code inside the for loop. For example, the first time the loop runs: imgCourses7.Top is used, but the second time the loop runs (when I = 1) then imgCourses6.Top should be used instead.
iCoursesCount := 7;
iTotalLength := (6+41)*iCoursesCount;
imgCourses7.Top := 6;
imgCourses6.Top := 6;
imgCourses5.Top := 6;
imgCourses4.Top := 6;
imgCourses3.Top := 6;
imgCourses2.Top := 6;
imgCourses1.Top := 6;
for I := 0 to iCoursesCount -1 do
begin
while not(imgCourses7.Top = iTotalLength - 41*(I+1)) do
begin
imgCourses8.Top := imgCourses8.Top + 6;
sleep(8);
application.ProcessMessages;
if imgCourses7.Top >= iTotalLength - 41*(I+1) then
begin
imgCourses7.Top := iTotalLength - 41*(I+1);
break;
end;
end;
end;
Like #AndreasRejbrand said in a comment, you can use an array, eg:
var
Images: array[0..6] of TImage;
TargetTop: Integer;
...
...
Images[0] := imgCourses7;
Images[1] := imgCourses6;
Images[2] := imgCourses5;
Images[3] := imgCourses4;
Images[4] := imgCourses3;
Images[5] := imgCourses2;
Images[6] := imgCourses1;
iCoursesCount := Length(Images);
TargetTop := 6+(41*iCoursesCount);
for I := 0 to iCoursesCount-1 do begin
Images[I].Top := 6;
end;
for I := 0 to iCoursesCount-1 do
begin
Dec(TargetTop, 41);
while Images[I].Top <> TargetTop do
begin
Images[I].Top := Images[I].Top + 6;
Sleep(8);
Application.ProcessMessages;
if Images[I].Top >= TargetTop then
begin
Images[I].Top := TargetTop;
Break;
end;
end;
end;
That being said, you really shouldn't be using a sleeping loop that requires Application.ProcessMessages() on each iteration. You might consider using a TTimer or TThread.ForceQueue() instead. Don't block the main UI thread unnecessarily. For example:
published
procedure FormCreate(Sender: TObject);
private
Images: array[0..6] of TImage;
TargetTop: Integer;
CurrentImage: Integer;
procedure StartAnimatingMenu;
procedure StartAnimatingNextMenuItem;
procedure StepAnimateCurrentMenuItem;
...
...
procedure TMyForm.FormCreate(Sender: TObject);
begin
Images[0] := imgCourses7;
Images[1] := imgCourses6;
Images[2] := imgCourses5;
Images[3] := imgCourses4;
Images[4] := imgCourses3;
Images[5] := imgCourses2;
Images[6] := imgCourses1;
end;
procedure TMyForm.StartAnimatingMenu;
var
I: Integer;
begin
for I := Low(Images) to High(Images) do begin
Images[I].Top := 6;
end;
TargetTop := 6+(41*Length(Images));
CurrentImage := -1;
StartAnimatingNextMenuItem;
end;
procedure TMyForm.StartAnimatingNextMenuItem;
begin
Inc(CurrentImage);
if CurrentImage < Length(Images) then
begin
Dec(TargetTop, 41);
StepAnimateCurrentMenuItem;
end;
end;
procedure TMyForm.StepAnimateCurrentMenuItem;
begin
if Images[CurrentImage].Top <> TargetTop then
begin
Images[CurrentImage].Top := Images[CurrentImage].Top + 6;
TThread.ForceQueue(nil, StepAnimateCurrentMenuItem, 8);
end
else if Images[CurrentImage].Top >= TargetTop then
begin
Images[CurrentImage].Top := TargetTop;
StartAnimatingNextMenuItem;
end;
end;
So how do you write the records of a database (from a TADOTable component) into a String grid? (the record's fields are all strings)
I tried something like this but to no avail:
procedure TfrmPuntehou.WriteToList(tbl: TADOTable;grid:TStringGrid);
var
iNewRowCount:integer;
i,j,m: Integer;
const
separator = ',';
begin
tempList:= TStringList.Create;
try
tbl.First;
while not (tbl.Eof) do
begin
tempList.Add(tbl['Car Number']+separator+tbl['Racer Name']+separator+tbl['Licence']);
tbl.Next;
end;
for j:= 1 to (tempList.Count - 1) do
begin
grid.Rows[j].Text := tempList.Strings[(J-1)] ;
end;
finally
tempList.Free;
end;
//fill the row numbers
for m := 1 to grid.rowcount do
begin
grid.Cells[0,m]:= IntToStr(m);
end;
end;
Example of the output I'm trying to get on startup: (Row number column is not part of the db)
Thanks in advance for the help!
Kind Regards
PrimeBeat
You're going through far too much work. You don't need the separate stringlist at all, and your code could be much simpler.
var
i, Row: Integer;
begin
// Populate header row
Grid.Cells[0, 0] := 'Row';
Row := 0;
for i := 0 to Tbl.FieldCount - 1 do
Grid.Cells[i + 1, Row] := Tbl.Fields[i].FieldName; // The +1 skips the Row column
Inc(Row);
// Populate cells
Tbl.First;
while not Tbl.Eof do
begin
for i := 0 to Tbl.FieldCount - 1 do
begin
Grid.Cells[i, Row] := IntToStr(i); // Populate Row number
Grid.Cells[i + 1, Row] := Tbl.Fields[i].AsString; // Fill rest of row with table data
end;
Inc(Row);
Tbl.Next;
end;
end;
Here is an example using TADOQuery and a StringGrid:
procedure TForm1.Button1Click(Sender: TObject);
var
I : Integer;
ARow : Integer;
begin
ADOConnection1.Open('user', 'pass');
ADOQuery1.SQL.Text := 'SELECT * FROM dbo.Person';
ADOQuery1.Open;
if ADOQuery1.Eof then begin
ShowMessage('Data not found');
Exit;
end;
SGrid.RowCount := 1;
SGrid.ColCount := ADOQuery1.Fields.Count + 1;
// Create titles of row 0
for I := 0 to ADOQuery1.Fields.Count - 1 do
SGrid.Cells[I + 1, 0] := ADOQuery1.Fields[I].DisplayName;
// Populate the cells with data from result set
ARow := 1;
while not ADOQuery1.Eof do begin
Inc(ARow);
SGrid.RowCount := ARow + 1;
SGrid.Cells[0, ARow] := ARow.ToString;
for I := 0 to ADOQuery1.Fields.Count - 1 do
SGrid.Cells[I + 1, ARow] := ADOQuery1.Fields[I].AsString;
ADOQuery1.Next;
end;
end;
Thanks to Ken White's answer, I managed to solve the problem!
procedure TfrmPuntehou.WriteToList(tbl: TADOTable;grid:TStringGrid);
var
Row: Integer;
begin
tbl.Active:=True;
Row := 1;
// Populate cells
Tbl.First;
while not Tbl.Eof do
begin
grid.Cells[0,Row]:= IntToStr(Row);
grid.Cells[1,Row]:= tbl.fields[0].AsString;
grid.Cells[2,Row]:= tbl.fields[1].AsString;
grid.Cells[3,Row]:= tbl.fields[2].AsString;
Inc(Row);
IncreaseRowCount(grid);
Tbl.Next;
end;
tbl.Active:=false;
end;
I have an array of integer and string fields. To make it distinct I currently copy line by line into new array and with each record I check if the record already exists in new, if not I copy it. At the end I copy new array back to original.
It works, but is slow. Is there any faster, easier way to do this?
TArrayMixed = record
Field1: integer;
Field2: integer;
Field3: integer;
Field4: string;
Field5: string;
Field6: string;
end;
procedure TForm1.Button10Click(Sender: TObject);
var
ArrayMixed, ArrayMixed_tmp: array of TArrayMixed;
i, j, vIdx: integer;
vExists: boolean;
begin
SetLength(ArrayMixed, 100000);
for i := 0 to 99999 do
begin
ArrayMixed[i].Field1 := 1 + Random(5);
ArrayMixed[i].Field2 := 1 + Random(5);
ArrayMixed[i].Field3 := 1 + Random(5);
ArrayMixed[i].Field4 := 'String';
ArrayMixed[i].Field5 := 'Another string';
ArrayMixed[i].Field6 := 'New string';
end;
// Sort
TArray.Sort<TArrayMixed > (ArrayMixed, TComparer<TArrayMixed > .Construct(function(const Left, Right: TArrayMixed): Integer
begin
Result := MyCompareAMixed(Left, Right);
end
));
// Distinct
SetLength(ArrayMixed_tmp, Length(ArrayMixed));
vIdx := 0;
for i := Low(ArrayMixed) to High(ArrayMixed) do
begin
vExists := False;
for j := Low(ArrayMixed_tmp) to vIdx - 1 do
if (ArrayMixed_tmp[j].Field1 = ArrayMixed[i].Field1) and
(ArrayMixed_tmp[j].Field2 = ArrayMixed[i].Field2) and
(ArrayMixed_tmp[j].Field3 = ArrayMixed[i].Field3) and
(ArrayMixed_tmp[j].Field4 = ArrayMixed[i].Field4) and
(ArrayMixed_tmp[j].Field5 = ArrayMixed[i].Field5) and
(ArrayMixed_tmp[j].Field6 = ArrayMixed[i].Field6) then
begin
vExists := True;
Break;
end;
if not vExists then
begin
ArrayMixed_tmp[vIdx] := ArrayMixed[i];
Inc(vIdx);
end;
end;
SetLength(ArrayMixed_tmp, vIdx);
// now copy back to original array
SetLength(ArrayMixed, 0);
SetLength(ArrayMixed, Length(ArrayMixed_tmp));
for i := Low(ArrayMixed_tmp) to High(ArrayMixed_tmp) do
ArrayMixed[i] := ArrayMixed_tmp[i];
sleep(0);
end;
Edit:
Since in real data the strings are not all the same, the part where it makes distinct array is slower when original array is filled like this:
Edit #2: (copied wrong code in Edit #1)
for i := 0 to 999999 do
begin
ArrayMixed[i].Field1 := 1 + Random(5);
ArrayMixed[i].Field2 := 1 + Random(5);
ArrayMixed[i].Field3 := 1 + Random(5);
ArrayMixed[i].Field4 := 'String'+IntToStr(i mod 5);
ArrayMixed[i].Field5 := 'Another string'+IntToStr(i mod 5);
ArrayMixed[i].Field6 := 'New string'+IntToStr( i mod 5);
end;
Edit #3: Publishing code for sorting - only first 3 fields are sorted!
TMyArray3 = array[1..3] of Integer;
function CompareIntegerArray3(const lhs, rhs: TMyArray3): Integer;
var
i: Integer;
begin
Assert(Length(lhs) = Length(rhs));
for i := low(lhs) to high(lhs) do
if lhs[i] < rhs[i] then
exit(-1)
else if lhs[i] > rhs[i] then
exit(1);
exit(0);
end;
function GetMyArrayAMixed(const Value: TArrayMixed): TMyArray3;
begin
Result[1] := Value.Field1;
Result[2] := Value.Field2;
Result[3] := Value.Field3;
end;
function MyCompareAMixed(const lhs, rhs: TArrayMixed): Integer;
begin
Result := CompareIntegerArray3(GetMyArrayAMixed(lhs), GetMyArrayAMixed(rhs));
end;
Implement some methods (equality check, hashcode) for the record to get away with a lot of boilerplate code
type
TArrayMixed = record
Field1: integer;
Field2: integer;
Field3: integer;
Field4: string;
Field5: string;
Field6: string;
class operator Equal( const a, b: TArrayMixed ): Boolean;
class function Compare( const L, R: TArrayMixed ): integer; overload; static;
function Compare( const Other: TArrayMixed ): integer; overload;
function GetHashCode( ): integer;
end;
{ TArrayMixed }
class function TArrayMixed.Compare( const L, R: TArrayMixed ): integer;
begin
Result := L.Compare( R );
end;
function TArrayMixed.Compare( const Other: TArrayMixed ): integer;
begin
Result := Field1 - Other.Field1;
if Result = 0
then
begin
Result := Field2 - Other.Field2;
if Result = 0
then
begin
Result := Field3 - Other.Field3;
if Result = 0
then
begin
Result := CompareStr( Field4, Other.Field4 );
if Result = 0
then
begin
Result := CompareStr( Field5, Other.Field5 );
if Result = 0
then
begin
Result := CompareStr( Field6, Other.Field6 );
end;
end;
end;
end;
end;
end;
class operator TArrayMixed.Equal( const a, b: TArrayMixed ): Boolean;
begin
Result := true
{} and ( a.Field1 = b.Field1 )
{} and ( a.Field2 = b.Field2 )
{} and ( a.Field3 = b.Field3 )
{} and ( a.Field4 = b.Field4 )
{} and ( a.Field5 = b.Field5 )
{} and ( a.Field6 = b.Field6 );
end;
function TArrayMixed.GetHashCode: integer;
begin
{$IFOPT Q+}
{$Q-}
{$DEFINE SET_Q_ON}
{$ENDIF}
Result := 17;
Result := Result * 31 + Field1;
Result := Result * 31 + Field2;
Result := Result * 31 + Field3;
Result := Result * 31 + Field4.GetHashCode;
Result := Result * 31 + Field5.GetHashCode;
Result := Result * 31 + Field6.GetHashCode;
{$IFDEF SET_Q_ON}
{$Q+}
{$UNDEF SET_Q_ON}
{$ENDIF}
end;
Use a TDictionary as a HashSet to check for duplicates
procedure Test;
var
arr1, arr2: TArray<TArrayMixed>;
idx : integer;
lst : TDictionary<TArrayMixed, integer>;
begin
// fill the array
SetLength( arr1, 100000 );
for idx := low( arr1 ) to high( arr1 ) do
begin
arr1[ idx ].Field1 := 1 + Random( 5 );
arr1[ idx ].Field2 := 1 + Random( 5 );
arr1[ idx ].Field3 := 1 + Random( 5 );
arr1[ idx ].Field4 := 'String' + IntToStr( idx mod 5 );
arr1[ idx ].Field5 := 'Another string' + IntToStr( idx mod 5 );
arr1[ idx ].Field6 := 'New string' + IntToStr( idx mod 5 );
end;
// distinct
lst := TDictionary<TArrayMixed, integer>.Create( TEqualityComparer<TArrayMixed>.Construct(
function( const L, R: TArrayMixed ): Boolean
begin
Result := ( L = R );
end,
function( const i: TArrayMixed ): integer
begin
Result := i.GetHashCode( );
end ) );
try
for idx := low( arr1 ) to high( arr1 ) do
begin
lst.AddOrSetValue( arr1[ idx ], 0 );
end;
arr2 := lst.Keys.ToArray;
finally
lst.Free;
end;
end;
I would do something like this. You basically create the result on the fly and sort at the same time using a binary search to remove the duplicates.
function RemoveDuplicates(aSourceArray: TArray<TArrayMixed>): TArray<TArrayMixed>;
var
i: Integer;
index: Integer;
sortList: TList<TArrayMixed>;
begin
sortList := TList<TArrayMixed>.Create;
try
for i := Low(aSourceArray) to High(aSourceArray) do
begin
if not sortList.BinarySearch(aSourceArray[i], index,
TDelegatedComparer<TArrayMixed>.Construct(
function(const L, R: TArrayMixed): integer
begin
Result := L.Field1 - R.Field1;
if Result <> 0 then Exit;
Result := L.Field2 - R.Field2;
if Result <> 0 then Exit;
Result := L.Field3 - R.Field3;
if Result <> 0 then Exit;
Result := CompareStr(L.Field4, R.Field4);
if Result <> 0 then Exit;
Result := CompareStr(L.Field5, R.Field5);
if Result <> 0 then Exit;
Result := CompareStr(L.Field6, R.Field6);
end)) then
begin
sortList.Insert(index, aSourceArray[i]);
end;
end;
Result := sortList.ToArray;
finally
sortList.Free;
end;
end;
To use this code you could do something like this:
procedure TForm1.Button10Click(Sender: TObject);
var
ArrayMixed, ArrayMixed_tmp: TArray<TArrayMixed>;
i: Integer;
begin
SetLength(ArrayMixed, 100000);
for i := 0 to 999999 do
begin
ArrayMixed[i].Field1 := 1 + Random(5);
ArrayMixed[i].Field2 := 1 + Random(5);
ArrayMixed[i].Field3 := 1 + Random(5);
ArrayMixed[i].Field4 := 'String'+IntToStr(i mod 5);
ArrayMixed[i].Field5 := 'Another string'+IntToStr(i mod 5);
ArrayMixed[i].Field6 := 'New string'+IntToStr( i mod 5);
end;
ArrayMixed_tmp := RemoveDuplicates(ArrayMixed);
end;
Just check for duplicates next to the prior index, since the array is sorted. Here is the sorting comparer reused as well.
function RemoveDuplicates(const anArray: array of TArrayMixed): TArray<TArrayMixed>;
var
j, vIdx: integer;
begin
// Sort
TArray.Sort<TArrayMixed > (anArray, TComparer<TArrayMixed >.Construct(function(const Left, Right: TArrayMixed): Integer
begin
Result := MyCompareAMixed(Left, Right);
end
));
// Distinct
SetLength(Result, Length(anArray));
vIdx := 0;
j := 0;
while (j <= High(anArray) do
begin
Result[vIdx] := anArray[j];
Inc(j);
While (j <= High(anArray)) and (MyCompareAMixed(Result[vIdx],anArray[j]) = 0) do
Inc(j);
Inc(vIdx);
end;
SetLength(Result, vIdx);
end;
Update:
In an update to the question it is stated that the array is only partially sorted. One way to reduce the number of iterations to remove duplicates would then be to:
Find start and stop index to items that share the first sorting criteria.
Iterate among them to sort out duplicates.
Since you already sort ArrayMixed you don't need to compare each item with each other in order to find duplicates. The duplicates are already placed next to each other. So you simply need to iterate over ArrayMixed and compare the current item to the last item in ArrayMixed_tmp.
Hence, copying the distinct items can be proceed much faster and looks like that:
vIdx := 0;
for i := Low(ArrayMixed) to High(ArrayMixed) do
begin
if (vIdx = 0) or // the first item can never be a duplicate
(ArrayMixed_tmp[vIdx].Field1 <> ArrayMixed[i].Field1) or
(ArrayMixed_tmp[vIdx].Field2 <> ArrayMixed[i].Field2) or
(ArrayMixed_tmp[vIdx].Field3 <> ArrayMixed[i].Field3) or
(ArrayMixed_tmp[vIdx].Field4 <> ArrayMixed[i].Field4) or
(ArrayMixed_tmp[vIdx].Field5 <> ArrayMixed[i].Field5) or
(ArrayMixed_tmp[vIdx].Field6 <> ArrayMixed[i].Field6) then
begin
ArrayMixed_tmp[vIdx] := ArrayMixed[i];
Inc(vIdx);
end;
end;
You have not posted the code for your MyCompareAMixed() function so it is not possible to test the performance of your actual code including this undefined function, including the current sort performance.
However, since your posted duplicate detection approach is not dependent upon the array being sorted I simply removed the sort from the code.
Without any further optimisation the resulting de-duplication process completed in well under 50 msecs, which is not "slow" in my book for de-duping 100,000 complex items. i.e. not single values but items that are records of multiple values.
If the sort is necessary for other reasons then you could retain the sorting and optimise the de-dupe process based on the answers given by others, but I would first question why you think the process is slow and if sub 50 msecs really is slow, what is the target you are aiming at ?
It is possible that it is the sorting that is adding the overhead (as I say, without your compare function we cannot quantify the overhead this is adding) so if this sorting is not necessary for other reasons and if sub 50-msecs is acceptable for de-duping this array, then I would move on to other tasks.
How to send files from two different locations via only one TCP-Server, I managed to send files from one location only.
This the code to send from one directory ...
procedure TForm1.Timer1Timer(Sender: TObject);
var
fs: TFileStream;
fn: string;
sr: TSearchRec;
I: integer;
begin
I := 0;
if FindFirst('C:/*.jpg', faAnyFile, sr) = 0 then
begin
with StringGrid1 do
begin
ListBox1.Items.Add('C:/' + sr.Name);
while FindNext(sr) = 0 do
begin
ListBox1.Items.Add('C:/' + sr.Name);
Inc(I);
if I = 7 then
Break;
end;
FindClose(sr);
idTCPClient1.Connect;
for fn in ListBox1.Items do
begin
fs := TFileStream.Create(fn, fmOpenRead or fmShareDenyWrite);
try
idTCPClient1.IOHandler.WriteLn(ExtractFileName(fn));
idTCPClient1.IOHandler.Write(fs, 0, True);
idUDPClient1.Send(lbLatitude.Text + ',' + lbLongitude.Text);
Finally
fs.Free;
end;
end;
end;
end;
end;
All you have to do (without completely re-writing your code, like DavidH suggested) is simply fill your ListBox with paths from all of the different directories that you want, eg:
procedure TForm1.Timer1Timer(Sender: TObject);
var
fs: TFileStream;
fn: string;
sr: TSearchRec;
I : integer;
begin
I := 0;
if FindFirst('C:/*.jpg', faAnyFile, sr) = 0 then
begin
repeat
ListBox1.Items.Add('C:/' + sr.Name);
Inc(I);
if I = 7 then Break;
until FindNext(sr) <> 0;
FindClose(sr);
end;
if I < 7 then
begin
if FindFirst('C:/Some Other Folder/*.jpg', faAnyFile, sr) = 0 then
begin
repeat
ListBox1.Items.Add('C:/Some Other Folder/' + sr.Name);
Inc(I);
if I = 7 then Break;
until FindNext(sr) <> 0;
FindClose(sr);
end;
end;
idTCPClient1.Connect;
for fn in ListBox1.Items do
begin
fs := TFileStream.Create(fn, fmOpenRead or fmShareDenyWrite);
try
IdTCPClient1.IOHandler.WriteLn(ExtractFileName(fn));
IdTCPClient1.IOHandler.Write(fs, 0, True);
...
finally
fs.Free;
end;
end;
end;
I am trying to initialize or create an array of a soap call:
Array_Of_ProductIdentifierClinicalType = array of ProductIdentifierClinicalType;
This is the way that I am trying to initialize it:
Product[0].IdentifierType := Array_Of_ProductIdentifierClinicalType.Create();
When I run the application I get this error: Access Violation at address...
The question would be: How to initialize this soap call??
Thank you for your time!!!!
You can do a WSDL import on: http://axelcarreras.dyndns.biz:3434/WSAlchemy.wsdl
procedure TFrmMain.Button16Click(Sender: TObject);
Var
ExcludeExpiradas: String;
Serv: AlchemyServiceSoap;
req: AlchemyClinical;
element: AlchemyClinicalRequest;
Prescribed: PrescribedType;
//Prescribing: Prescribing
Prescribing: PrescribedType;
alc: AlchemyIdentifierType;
D: TXSDate;
Counter: Integer;
ProductStr: AlchemyIdentifierClinicalType;
begin
With DM do
begin
ExcludeExpiradas := ' and (' + chr(39) + DateToStr(Date) + chr(39) + ' < (FECHARECETA + 180)) ';
CDSRx_Procesadas.Close;
CDSRx_Procesadas.CommandText := 'SELECT * ' +
' FROM RX_PROCESADAS WHERE ' +
' (NUMERORECETA IS NOT NULL AND CANTIDAD_DISPONIBLE > 0)' +
ExcludeExpiradas +
' and NumeroCliente = ' + CDSPacientesNumeroCliente.asString +
' Order by NumeroReceta';
//ShowMessage(CDSRx_Procesadas.CommandText);
CDSRx_Procesadas.Open;
ProductStr := AlchemyIdentifierClinicalType.Create;
With ProductStr do
begin
Identifier := 1;
end;
element := AlchemyClinicalRequest.Create;
//Prescribed := PrescribedType.Create;
With element do
begin
With Prescribed do
begin
Counter := 0;
while not CDSRx_Procesadas.eof do
begin
Product := Array_Of_ProductIdentifierClinicalType.Create();
With Product[0] do
begin
IdentifierType := ProductIdentifierTypeEnum.NDC9;
Identifier := Copy(DM.CDSInventarioNDC.Value, 1, 9);
end;
Counter := Counter + 1;
CDSRx_Procesadas.Next;
end;
end;
With Prescribing do
begin
Counter := 0;
Product[0].IdentifierType := ProductIdentifierTypeEnum.AlchemyProductID;
Product[0].Identifier := Copy(DM.CDSInventarioNDC.Value, 1, 9);
Counter := Counter + 1;
end;
With PatientDemographics do
begin
while not CDSAlergies.Eof do
begin
Allergy.AllergySubstanceClass[0].Identifier := CDSAlergiesNOALERGIA.Value;
CDSAlergies.Next;
end;
if CDSPacientesSEXO.Value = 1 then
Gender := GenderTypeEnum.Male
else
Gender := GenderTypeEnum.Female;
D := TXSDate.Create;
D.AsDate := CDSPacientesFECHANACIMIENTO.AsDateTime;
DateOfBirth := D;
end;
With RequestedOperations do
begin
DrugToDrug := True;
//DuplicateTherapy
Allergy := True;
With WarningLabels do
begin
Request := True;
LanguageCode := 'en-US';
MaxLines := 5;
CharsPerLine := 24;
end;
With DoseScreening do
begin
Request := True;
end;
AdverseReactions.Request := True;
end;
IgnorePrescribed := False;
IncludeConsumerNotes := True;
IncludeProfessionalNotes := True;
end;
end;
end;*
Assuming that this line of code from the question is accurate:
Array_Of_ProductIdentifierClinicalType = array of ProductIdentifierClinicalType;
then the problem lies here:
Product := Array_Of_ProductIdentifierClinicalType.Create();
This is a dynamic array constructor. It creates a dynamic array of length equal to the number of parameters to the constructor. And then assigns each element of the array, in turn, to the parameters passed.
Consider an example using TBytes = array of Byte.
Bytes := TBytes.Create(1, 2, 3);
This initialises Bytes to be an array of length 3 and having values 1, 2 and 3.
Now, let's look at your code again. This initialises Product to be an array of length 0. So when you access Product[0] that results in a runtime error because the array index is out of bounds.
To solve the problem you will need to make sure that the array is initialised to have sufficient elements. One option is certainly to use a dynamic array constructor. Another is to use SetLength. I suspect that your understanding of Delphi's dynamic arrays is poor. I suggest that you consult the documentation.