jvqmemorydataset.pas

East make Tray Icon in delphi

procedure TJvMemoryData.Sort;
var
  Pos: TBookmarkStr;
begin
  if Active and (FRecords <> nil) and (FRecords.Count > 0) then
  begin
    Pos := Bookmark;
    try
      QuickSort(0, FRecords.Count - 1, CompareRecords);
      SetBufListSize(0);
      InitBufferPointers(False);
      try
        SetBufListSize(BufferCount + 1);
      except
        SetState(dsInactive);
        CloseCursor;
        raise;
      end;
    finally
      Bookmark := Pos;
    end;
    Resync([]);
  end;
end;

procedure TJvMemoryData.QuickSort(L, R: Integer; Compare: TCompareRecords);
var
  I, J: Integer;
  P: TJvMemoryRecord;
begin
  repeat
    I := L;
    J := R;
    P := Records[(L + R) shr 1];
    repeat
      while Compare(Records[I], P) < 0 do
        Inc(I);
      while Compare(Records[J], P) > 0 do
        Dec(J);
      if I <= J then
      begin
        FRecords.Exchange(I, J);
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      QuickSort(L, J, Compare);
    L := I;
  until I >= R;
end;

function TJvMemoryData.CompareRecords(Item1, Item2: TJvMemoryRecord): Integer;
var
  Data1, Data2: PChar;
  F: TField;
  I: Integer;
begin
  Result := 0;
  if FIndexList <> nil then
  begin
    for I := 0 to FIndexList.Count - 1 do
    begin
      F := TField(FIndexList[I]);
      Data1 := FindFieldData(Item1.Data, F);
      if Data1 <> nil then
      begin
        Data2 := FindFieldData(Item2.Data, F);
        if Data2 <> nil then
        begin
          if (Data1[0] <> #0) and (Data2[0] <> #0) then
          begin
            Inc(Data1);
            Inc(Data2);
            Result := CompareFields(Data1, Data2, F.DataType,
              FCaseInsensitiveSort);
          end
          else
          if Data1[0] <> #0 then
            Result := 1
          else
          if Data2[0] <> #0 then
            Result := -1;
          if FDescendingSort then
            Result := -Result;
        end;
      end;
      if Result <> 0 then
        Exit;
    end;
  end;
  if Result = 0 then
  begin
    if Item1.ID > Item2.ID then
      Result := 1
    else
    if Item1.ID < Item2.ID then
      Result := -1;
    if FDescendingSort then
      Result := -Result;
  end;
end;

function TJvMemoryData.GetIsIndexField(Field: TField): Boolean;
begin
  if FIndexList <> nil then
    Result := FIndexList.IndexOf(Field) >= 0
  else
    Result := False;
end;

procedure TJvMemoryData.CreateIndexList(const FieldNames: string);
var
  Pos: Integer;
  F: TField;
begin
  if FIndexList = nil then
    FIndexList := TList.Create
  else
    FIndexList.Clear;
  Pos := 1;
  while Pos <= Length(FieldNames) do
  begin
    F := FieldByName(ExtractFieldName(FieldNames, Pos));
    if (F.FieldKind = fkData) and
      (F.DataType in ftSupported - ftBlobTypes) then
      FIndexList.Add(F)
    else
      ErrorFmt(SFieldTypeMismatch, [F.DisplayName]);
  end;
end;

procedure TJvMemoryData.FreeIndexList;
begin
  FIndexList.Free;
  FIndexList := nil;
end;

//------------------------ Added by CFZ -------------------------------------
                // changed 2004/10/19 (CFZ)

function TJvMemoryData.GetValues(FldNames: string = ''): Variant;
var
  I: Integer;
  List: TStrings;

  function FldNamesToStrList(Flds: string): TStrings;
  var
    InStr, SubStr: string;
    I, Len: Integer;
  begin
    Result := TStringList.Create;
    Len := Length(Flds);
    InStr := Flds;
    SubStr := '';
    I := 1;
    while (I <= Len) do
    begin
      if (InStr[I] = ';') or (I = Len) then
      begin
        if (I = Len) and not (InStr[I] = ';') then
          SubStr := SubStr + InStr[I];
        Result.Add(SubStr);
        SubStr := '';
      end
      else
        SubStr := SubStr + InStr[I];
      Inc(I);
    end;
  end;

begin
  Result := Null;
  if FldNames = '' then // Changed 2004/10/19 (CFZ)
    List := FldNamesToStrList(FKeyFieldNames)
  else
    List := FldNamesToStrList(FldNames);
  try
    I := List.Count;
    Result := VarArrayCreate([0, I], varVariant);
    for I := 0 to List.Count - 1 do
      Result[I] := FieldValues[List[I]];
  finally
    FreeAndNil(List);
  end;
end;

function TJvMemoryData.CopyFromDataSet: Integer;
var
  bOpen: Boolean;
  I, Len: Integer;
  FOriginal, FClient: TField;
begin
  Result := 0;
  if FDataSet = nil then
    Exit;
  if FApplyMode <> amNone then
    Len := FieldDefs.Count - 2
  else
    Len := FieldDefs.Count - 1;
  if Len < 1 then
    Exit;
  bOpen := FDataSet.Active;
  try
    if not bOpen then
      FDataSet.Open;
  except
    Exit;
  end;
  if FDataSet.IsEmpty then
  begin
    if not bOpen And FDataSetClosed then
      FDataSet.Close;
    Exit;
  end;

  FDataSet.DisableControls;
  DisableControls;
  FSaveLoadState := slsLoading;
  try
    FDataSet.First;
    while not FDataSet.Eof do
    begin
      Append;
      for I := 0 to Len do
      begin
        FClient := Fields[I];
        FOriginal := FDataSet.FindField(FClient.FieldName);
        if (FClient <> nil) and (FOriginal <> nil) then
        begin
          if FOriginal.IsNull then
            Fields[I].Clear
          else
            Fields[I].Value := FOriginal.Value;
        end;
      end;
      if FApplyMode <> amNone then // Added 2004/10/25 (CFZ)
        FieldByName(FStatusName).AsInteger := Integer(rsOriginal);
      Post;
      Inc(Result);
      FDataSet.Next;
    end;
  finally
    FSaveLoadState := slsNone;
    EnableControls;
    FDataSet.EnableControls;
    if not bOpen And FDataSetClosed then
      FDataSet.Close;
  end;
end;

procedure TJvMemoryData.DoBeforeApply;
begin
  if Assigned(FBeforeApply) then
    FBeforeApply(Self);
end;

procedure TJvMemoryData.DoAfterApply;
begin
  if Assigned(FAfterApply) then
    FAfterApply(Self);
end;

procedure TJvMemoryData.DoBeforeApplyRecord(ADataSet: TDataSet; RS: TRecordStatus; Found: Boolean);
begin
  if Assigned(FBeforeApplyRecord) then
    FBeforeApplyRecord(ADataSet, RS, Found);
end;

procedure TJvMemoryData.DoAfterApplyRecord(ADataSet: TDataSet; RS: TRecordStatus; Apply: Boolean);
begin
  if Assigned(FAfterApplyRecord) then
    FAfterApplyRecord(ADataSet, RS, Apply);
end;

procedure TJvMemoryData.ClearChanges;
var
  I: Integer;
  PFValues: TPVariant;
begin
  if FDeletedValues.Count > 0 then
  begin
    for I := 0 to (FDeletedValues.Count - 1) do
    begin
      PFValues := FDeletedValues[I];
      Dispose(PFValues);
    end;
    FDeletedValues.Clear;
  end;

  EmptyTable;

  if FLoadRecords then
  begin
    FRowsOriginal := CopyFromDataSet;
    if FRowsOriginal > 0 then
    begin
      if FKeyFieldNames <> '' then
        SortOnFields(KeyFieldNames);
      if FApplyMode = amAppend then
        Last
      else
        First;
    end;
  end;
end;

procedure TJvMemoryData.CancelChanges;
begin
  CheckBrowseMode;
  if (FDataSet = nil) or (FApplyMode = amNone) then
    Exit;
  if (FApplyMode <> amNone) and (FKeyFieldNames = '') then
    Exit;
  ClearChanges;
  FRowsChanged := 0;
  FRowsAffected := 0;
end;

function TJvMemoryData.ApplyChanges: Boolean;
var
  xKey: Variant;
  PxKey: TPVariant;
  Len, Row: Integer;
  Status: TRecordStatus;
  bFound, bApply: Boolean;
  FOriginal, FClient: TField;

  function WriteFields: Boolean;
  var
    J: Integer;
  begin
    try
      for J := 0 to Len do
      begin
        if (Fields[J].FieldKind = fkData) then
        begin
          FClient := Fields[J];
          FOriginal := FDataSet.FindField(FClient.FieldName);
          if (FOriginal <> nil) and (FClient <> nil) then
          begin
            if FClient.IsNull then
              FOriginal.Clear
            else
              FDataSet.FieldByName(FOriginal.FieldName).Value := FClient.Value;
          end;
        end;
      end;
      Result := True;
    except
      Result := False;
    end;
  end;

  function InsertRec: Boolean;
  begin
    try
      FDataSet.Append;
      WriteFields;
      FDataSet.Post;
      Result := True;
    except
      Result := False;
    end;
  end;

  function UpdateRec: Boolean;
  begin
    try
      FDataSet.Edit;
      WriteFields;
      FDataSet.Post;
      Result := True;
    except
      Result := False;
    end;
  end;

  function DeleteRec: Boolean;
  begin
    try
      FDataSet.Delete;
      Result := True;
    except
      Result := False;
    end;
  end;

  function SaveChanges: Integer;
  var
    I: Integer;
  begin
    Result := 0;
    FDataSet.DisableControls;
    DisableControls;
    Row := RecNo;
    FSaveLoadState := slsSaving;
    try
      if not IsEmpty Then
        First;
      while not Eof do
      begin
        Status := TRecordStatus(FieldByName(FStatusName).AsInteger);
        if (Status <> rsOriginal) then
        begin
          xKey := GetValues;
          bFound := FDataSet.Locate(FKeyFieldNames, xKey, []);
          DoBeforeApplyRecord(FDataSet, Status, bFound);
          bApply := False;
          (********************* New Record ***********************)
          if IsInserted then
          begin
            if not bFound then // Not Exists in Original
            begin
              if InsertRec then
              begin
                Inc(Result);
                bApply := True;
              end
              else
              if FExactApply then
              begin
                Error(RsEInsertError);
                Break;
              end
              else
              begin
                if (FDataSet.State in dsEditModes) then
                  FDataSet.Cancel;
                SysUtils.Abort;
              end;
            end
            else
            if FExactApply then // Exists in Original
            begin
              Error(RsERecordDuplicate);
              Break;
            end
            else
            if FApplyMode = amMerge then
            begin
              if UpdateRec then
              begin
                Inc(Result);
                bApply := True;
              end
              else
              begin
                if FDataSet.State in dsEditModes then
                  FDataSet.Cancel;
                SysUtils.Abort;
              end;
            end
          end;
          (*********************** Modified Record ************************)
          if IsUpdated then
          begin
            if bFound then // Exists in Original
            begin