DELPHI盒子技术论坛 https://bbs.2ccc.com/ zh-cn Copyright 2004, bbs.2ccc.com root@2ccc.com https://bbs.2ccc.com/rss.asp Rss Generator By bbs.2ccc.com https://bbs.2ccc.com/topic.asp?topicid=768481 tms2021 回复:7 浏览:141 Tue, 15 Sep 2026 03:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768480 tms2021 回复:0 浏览:65 Tue, 15 Sep 2026 03:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768474 hh2001howlong 回复:4 浏览:95 Mon, 14 Sep 2026 02:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768465 hnxxcxg json(binary) TRecordSerial<T> = record public // json-->record class procedure unjson(const AJson: UTF8String; var AResult: T); static; // record-->json class procedure json(const ARecord: T; var AResult: UTF8String); static; //record-->binary class procedure bytes(const ARecord: T; var AResult: TBytes); static; class procedure bytestr(const ARecord: T; var AResult: ByteStr); static; class procedure stream(const ARecord: T; var AResult: TStream); static; //binary-->record class procedure unbytes(const ABytes: TBytes; var AResult: T); static; class procedure unbytestr(const AByteStr: ByteStr; var AResult: T); static; class procedure unstream(const AStream: TStream; var AResult: T); static; end; type // Generate transaction SQL from a record TRecordCrud<T> = record TableName: string; //table name KeyFields: string; //Primary keys NonSaveFields: string; //Do not save fields function SelectSQL(const ARecord: T): string; function InsertSQL(const ARecord: T): string; function DeleteSQL(const ARecord: T): string; function UpdateSQL(const ARecord: T): string; private function ProcessValue(const ARttiField: TRttiField; const ARecord: T): string; end; implementation { TRecordSerial<T> } class procedure TRecordSerial<T>.json(const ARecord: T; var AResult: UTF8String); begin if @ARecord = nil then Exit; var LJsonSerializer: TJsonSerializer := TJsonSerializer.Create; try AResult := UTF8Encode(LJsonSerializer.Serialize<T>(ARecord)); finally LJsonSerializer.Free; end; end; class procedure TRecordSerial<T>.stream(const ARecord: T; var AResult: TStream); begin if @ARecord = nil then Exit; if AResult = nil then AResult := TMemoryStream.Create; AResult.Write(ARecord, SizeOf(ARecord)); AResult.Position := 0; end; class procedure TRecordSerial<T>.bytes(const ARecord: T; var AResult: TBytes); var len: Integer; begin if @ARecord = nil then Exit; len := SizeOf(ARecord); SetLength(AResult, len); Move(ARecord, PByte(AResult)^, len); end; class procedure TRecordSerial<T>.bytestr(const ARecord: T; var AResult: RawByteString); var len: Integer; begin if @ARecord = nil then Exit; len := SizeOf(ARecord); SetLength(AResult, len); Move(ARecord, PByteStr(AResult)^, len); end; class procedure TRecordSerial<T>.UnJson(const AJson: UTF8String; var AResult: T); begin if AJson = '' then Exit; var LJsonSerializer: TJsonSerializer := TJsonSerializer.Create; try AResult := LJsonSerializer.Deserialize<T>(string(AJson)); finally LJsonSerializer.Free; end; end; class procedure TRecordSerial<T>.unstream(const AStream: TStream; var AResult: T); begin if AStream = nil then Exit; AStream.Read(AResult, AStream.Size); end; class procedure TRecordSerial<T>.unbytes(const ABytes: TBytes; var AResult: T); var len: Integer; begin len := Length(ABytes); if len = 0 then Exit; Move(PByte(ABytes)^, AResult, len); end; class procedure TRecordSerial<T>.unbytestr(const AByteStr: RawByteString; var AResult: T); var len: Integer; begin len := Length(AByteStr); if len = 0 then Exit; Move(PByteStr(AByteStr)^, AResult, len); end; { TRecordCrud<T> } function TRecordCrud<T>.DeleteSQL(const ARecord: T): string; var LRttiContext: TRttiContext; LRttiType: TRttiType; LRttiField: TRttiField; LWhere, LValue: string; begin if (@ARecord = nil) or (TableName = '') or (KeyFields = '') then Exit; LRttiContext := TRttiContext.Create; try LRttiType := LRttiContext.GetType(TypeInfo(T)); LValue := ''; LWhere := ''; for LRttiField in LRttiType.GetFields do begin if Pos(LRttiField.Name, KeyFields) = 0 then //Only primary keys can be used as WHERE conditions Continue; LValue := ProcessValue(LRttiField, ARecord); LWhere := LWhere + ' and ' + LRttiField.Name + '=' + LValue; end; System.Delete(LWhere, 1, 5); Result := 'delete from ' + TableName + ' where ' + LWhere; finally LRttiContext.Free; end; end; function TRecordCrud<T>.InsertSQL(const ARecord: T): string; var LRttiContext: TRttiContext; LRttiType: TRttiType; LRttiField: TRttiField; LFields, LValues, LValue: string; begin if (@ARecord = nil) or (TableName = '') then Exit; LRttiContext := TRttiContext.Create; try LRttiType := LRttiContext.GetType(TypeInfo(T)); LFields := ''; LValues := ''; LValue := ''; for LRttiField in LRttiType.GetFields do begin if Pos(LRttiField.Name, NonSaveFields) <> 0 then //Do not save fields Exit; LFields := LFields + ',' + LRttiField.Name; LValue := ProcessValue(LRttiField, ARecord); LValues := LValues + ',' + LValue; end; System.Delete(LFields, 1, 1); System.Delete(LValues, 1, 1); Result := 'insert into ' + TableName + ' (' + LFields + ') values (' + LValues + ')'; finally LRttiContext.Free; end; end; function TRecordCrud<T>.ProcessValue(const ARttiField: TRttiField; const ARecord: T): string; begin if (@ARecord = nil) or (ARttiField = nil) then Exit; //TDateTime convert to string if ARttiField.FieldType.ToString = 'TDateTime' then Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', ARttiField.GetValue(@ARecord).AsType<TDateTime>) else if ARttiField.FieldType.ToString = 'TDate' then Result := FormatDateTime('yyyy-mm-dd', ARttiField.GetValue(@ARecord) .AsType<TDate>) else if ARttiField.FieldType.ToString = 'TTime' then Result := FormatDateTime('hh:nn:ss', ARttiField.GetValue(@ARecord) .AsType<TTime>) else Result := ARttiField.GetValue(@ARecord).ToString; //QuotedStr() process sql-string if (ARttiField.FieldType.ToString = 'string') or (ARttiField.FieldType.ToString = 'TDateTime') or (ARttiField.FieldType.ToString = 'TDate') or (ARttiField.FieldType.ToString = 'TTime') then Result := QuotedStr(Result); end; function TRecordCrud<T>.SelectSQL(const ARecord: T): string; var LRttiContext: TRttiContext; LRttiType: TRttiType; LRttiField: TRttiField; LFields: string; begin if (@ARecord = nil) or (TableName = '') then Exit; LRttiContext := TRttiContext.Create; try LRttiType := LRttiContext.GetType(TypeInfo(T)); LFields := ''; for LRttiField in LRttiType.GetFields do begin LFields := LFields + ',' + LRttiField.Name; end; System.Delete(LFields, 1, 1); Result := 'select ' + LFields + ' from ' + TableName; finally LRttiContext.Free; end; end; function TRecordCrud<T>.UpdateSQL(const ARecord: T): string; var LRttiContext: TRttiContext; LRttiType: TRttiType; LRttiField: TRttiField; LWhere, LValue, LSet: string; begin if (@ARecord = nil) or (TableName = '') or (KeyFields = '') then Exit; LRttiContext := TRttiContext.Create; try LRttiType := LRttiContext.GetType(TypeInfo(T)); LValue := ''; LWhere := ''; LSet := ''; for LRttiField in LRttiType.GetFields do begin if Pos(LRttiField.Name, NonSaveFields) <> 0 then //Do not save fields Exit; LValue := ProcessValue(LRttiField, ARecord); LSet := LSet + ',' + LRttiField.Name + '=' + LValue; if Pos(LRttiField.Name, KeyFields) = 0 then //Only primary keys can be used as WHERE conditions Continue; LWhere := LWhere + ' and ' + LRttiField.Name + '=' + LValue; end; System.Delete(LWhere, 1, 5); System.Delete(LSet, 1, 1); Result := 'update ' + TableName + ' set ' + LSet + ' where ' + LWhere; finally LRttiContext.Free; end; end; end.]]> 回复:8 浏览:316 Sun, 13 Sep 2026 07:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768446 pcplayer 回复:20 浏览:673 Thu, 10 Sep 2026 11:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768436 pcplayer 回复:5 浏览:234 Thu, 10 Sep 2026 06:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768426 pcplayer 回复:7 浏览:287 Tue, 08 Sep 2026 06:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768385 emailx45 回复:15 浏览:535 Thu, 03 Sep 2026 18:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768374 wntee 回复:3 浏览:252 Thu, 03 Sep 2026 01:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768362 wntee 回复:5 浏览:242 Wed, 02 Sep 2026 08:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768356 tms2021 回复:10 浏览:441 Wed, 02 Sep 2026 02:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768353 mp654kk 回复:4 浏览:173 Tue, 01 Sep 2026 16:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768349 pherody 回复:7 浏览:474 Tue, 01 Sep 2026 01:09:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768345 keymark 回复:2 浏览:259 Mon, 31 Aug 2026 06:08:00 GMT https://bbs.2ccc.com/topic.asp?topicid=768336 mp654kk 回复:3 浏览:138 Sun, 30 Aug 2026 07:08:00 GMT