[分享]一种将 Delphi 组件属性信息保存到JSON的方法

此代码支持 Delphi 2007+，使用 QJSON 做为序列化的支持库。你可以自己改为使用其它的 JSON库（注：此文写法未完善，仅为示意）。

uses typinfo, qjson, qstring;

type
  TComponentJsonHelper = class helper for TComponent
  protected
    procedure DoSaveToJson(AStream: TStream; AJson: TQJson);
    procedure DoLoadFromJson(AParent: TComponent; AJson: TQJson;
      ALoaded: TList);
  public
    procedure SaveToJson(AJson: TQJson);
    procedure LoadFromJson(AJson: TQJson);
  end;
{ TComponentJsonHelper }

procedure TComponentJsonHelper.LoadFromJson(AJson: TQJson);
var
  ALoaded: TList;
  I: Integer;
begin
  ALoaded := TList.Create;
  GlobalNameSpace.BeginWrite;
  try
    DoLoadFromJson(nil, AJson, ALoaded);
    for I := 0 to ALoaded.Count - 1 do
      TComponent(ALoaded&#91;I]).Loaded;
    Loaded;
  finally
    GlobalNameSpace.EndWrite;
  end;
end;

procedure TComponentJsonHelper.DoLoadFromJson(AParent: TComponent;
  AJson: TQJson; ALoaded: TList);
type
  PComponentState = ^TComponentState;
var
  AChildPos: Integer;
  AList: TQJson;
  ACompState: PComponentState;
  function JsonToSet(AValues: TQJson): String;
  var
    I: Integer;
  begin
    Result := '&#91;';
    for I := 0 to AValues.Count - 1 do
    begin
      if I = 0 then
        Result := AValues&#91;I].AsString
      else
        Result := Result + ',' + AValues&#91;I].AsString;
    end;
    Result := Result + ']';
  end;
  function PropByPath(var Instance: TObject; APath: String): PPropInfo;
  var
    AName: String;
    APos: Integer;
  begin
    AName := DecodeTokenW(APath, '.', #0, true, true);
    Result := GetPropInfo(Instance, AName);
    if (Length(APath) > 0) then
    begin
      if (Result.PropType^.Kind = tkClass) then
      begin
        Instance := TObject(GetOrdProp(Instance, Result));
        if Assigned(Instance) then
          Result := PropByPath(Instance, APath)
        else
          Result := nil;
      end
      else
        Result := nil;
    end;
  end;
  procedure LoadProps(ARootInstance: TObject; AProps: TQJson);
  var
    I: Integer;
    AProp: PPropInfo;
    APropJson: TQJson;
    AInstance: TObject;
  begin
    if not Assigned(ARootInstance) then
      Exit;
    for I := 0 to AProps.Count - 1 do
    begin
      APropJson := AProps&#91;I];
      AInstance := ARootInstance;
      AProp := PropByPath(AInstance, APropJson.Name);
      if Assigned(AProp) then
      begin
        case AProp.PropType^.Kind of
          tkInteger:
            SetOrdProp(AInstance, AProp, APropJson.AsInteger);
          tkChar, tkWChar:
            begin
              if APropJson.IsString then
                SetOrdProp(AInstance, AProp, Ord(PChar(APropJson.AsString)^))
              else
                SetOrdProp(AInstance, AProp, APropJson.AsInteger);
            end;
          tkEnumeration:
            SetEnumProp(AInstance, AProp, APropJson.AsString);
          tkFloat:
            SetFloatProp(AInstance, AProp, APropJson.AsFloat);
          tkString, tkLString, tkWString, tkUString:
            SetStrProp(AInstance, AProp, APropJson.AsString);
          tkSet:
            SetSetProp(AInstance, AProp, JsonToSet(APropJson));
          tkClass:
            LoadProps(Pointer(GetOrdProp(AInstance, AProp)), APropJson);
          tkVariant:
            SetVariantProp(AInstance, AProp, APropJson.AsVariant);
          // tkArray,tkDynArray,tkRecord, tkInterface,tkClassRef,tkPointer, tkProcedure
          tkInt64:
            SetInt64Prop(AInstance, AProp, APropJson.AsInt64);
        end;
      end;
    end;
  end;

  procedure LoadChildren(AObjects: TQJson);
  var
    I: Integer;
    AChildComp: TComponent;
    AClass: TClass;
    AClassName: String;
  begin
    for I := 0 to AObjects.Count - 1 do
    begin
      AClassName := AObjects&#91;I].ValueByName('ClassName', '');
      AClass := FindClass(AClassName);
      if AClass = TComponent then
      begin
        if Assigned(Owner) then
          AChildComp := TComponentClass(AClass).Create(Owner)
        else
          AChildComp := TComponentClass(AClass).Create(Self);
        AChildComp.DoLoadFromJson(Self, AObjects&#91;I], ALoaded);
      end
      else
        raise EClassNotFound.CreateFmt('Class %s not found', &#91;AClassName]);
    end;
  end;

begin
  ACompState := @ComponentState;
  ACompState^ := ACompState^ + &#91;csLoading, csReading];
  try
    Name := AJson.ValueByName('Name', '');
    if AJson.HasChild('Props', AList) then
      LoadProps(Self, AList);
    if AJson.HasChild('Children', AList) then
      LoadChildren(AList);
  finally
    ACompState^ := ACompState^ - &#91;csLoading, csReading];
    if Assigned(ALoaded) then
      ALoaded.Add(Self);
  end;
  if Assigned(AParent) then
  begin
    AChildPos := AJson.IntByName('ChildPos', -1);
    if AChildPos > 0 then
      AParent.SetChildOrder(Self, AChildPos);
  end;
end;

procedure TComponentJsonHelper.DoSaveToJson(AStream: TStream; AJson: TQJson);
var
  Reader: TReader;
  ObjectName, PropName: string;

procedure ConvertValue(AItem: TQJson); forward;

  procedure ConvertHeader(AItem: TQJson);
  var
    ClassName: string;
    Flags: TFilerFlags;
    Position: Integer;
  begin
    Reader.ReadPrefix(Flags, Position);
    ClassName := Reader.ReadStr;
    ObjectName := Reader.ReadStr;
    AItem.Add('Name').AsString := Name;
    AItem.Add('ClassName').AsString := ClassName;
    if ffInherited in Flags then
      AItem.Add('InstanceType').AsString := 'inherited'
    else if ffInline in Flags then
      AItem.Add('InstanceType').AsString := 'inline'
    else
      AItem.Add('InstanceType').AsString := 'object';
    if ffChildPos in Flags then
      AItem.Add('ChildPos').AsInteger := Position;
  end;

  procedure ConvertBinary(AItem: TQJson);
  var
    Count: Integer;
    Buffer: TBytes;
  begin
    Reader.ReadValue;
    Reader.Read(Count, SizeOf(Count));
    SetLength(Buffer, Count);
    Reader.Read(Buffer, Count);
    AItem.AsBytes := Buffer;
  end;

procedure ConvertProperty(AItem: TQJson); forward;

  procedure ConvertValue(AItem: TQJson);
  const
    LineLength = 64;
  var
    S: String;
  begin
    case Reader.NextValue of
      vaList:
        begin
          Reader.ReadValue;
          AItem.DataType := jdtArray;
          while not Reader.EndOfList do
            ConvertValue(AItem.Add);
        end;
      vaInt8, vaInt16, vaInt32:
        AItem.AsInteger := Reader.ReadInteger;
      vaExtended, vaDouble:
        AItem.AsFloat := Reader.ReadFloat;
      vaSingle:
        AItem.AsFloat := Reader.ReadSingle;
      vaCurrency:
        AItem.AsFloat := Reader.ReadCurrency;
      vaDate:
        AItem.AsDateTime := Reader.ReadDate;
      vaWString, vaUTF8String, vaString, vaLString:
        AItem.AsString := Reader.ReadString;
      vaIdent:
        AItem.AsString := Reader.ReadIdent;
      vaFalse:
        AItem.AsBoolean := False;
      vaTrue:
        AItem.AsBoolean := true;
      vaNil, vaNull:
        AItem.ResetNull;
      vaBinary:
        ConvertBinary(AItem);
      vaSet:
        begin
          Reader.ReadValue;
          AItem.DataType := jdtArray;
          while true do
          begin
            S := Reader.ReadStr;
            if S = '' then
              Break;
            AItem.Add.AsString := S;
          end;
        end;
      vaCollection:
        begin
          Reader.ReadValue;
          AItem.DataType := jdtObject;
          while not Reader.EndOfList do
          begin
            with AItem.AddArray('items') do
            begin
              if Reader.NextValue in &#91;vaInt8, vaInt16, vaInt32] then
                ConvertValue(Add);
            end;
            Reader.CheckValue(vaList);
            while not Reader.EndOfList do
              ConvertProperty(AItem);
          end;
          Reader.ReadListEnd;
        end;
      vaInt64:
        AItem.AsInt64 := Reader.ReadInt64;
    else
      raise EReadError.CreateFmt('Can not read %s property %s',
        &#91;ObjectName, PropName]);
    end;
  end;

  procedure ConvertProperty(AItem: TQJson);
  begin
    ConvertValue(AItem.Add(Reader.ReadStr));
  end;

  procedure ConvertObject(AItem: TQJson);
  var
    AObject, AList: TQJson;
  begin
    ConvertHeader(AItem);
    AList := AItem.Add('Props');
    while not Reader.EndOfList do
      ConvertProperty(AList);
    Reader.ReadListEnd;
    AList := AItem.Add('Children');
    AList.DataType := jdtObject;
    while not Reader.EndOfList do
      ConvertObject(AList);
    Reader.ReadListEnd;
  end;

begin
  Reader := TReader.Create(AStream, 4096);
  try
    Reader.ReadSignature;
    ConvertObject(AJson);
  finally
    Reader.Free;
  end;
end;

procedure TComponentJsonHelper.SaveToJson(AJson: TQJson);
var
  AStream: TMemoryStream;
begin
  AStream := TMemoryStream.Create;
  try
    AStream.WriteComponent(Self);
    AStream.Position := 0;
    DoSaveToJson(AStream, AJson);
  finally
    FreeAndNil(AStream);
  end;
end;

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

uses typinfo, qjson, qstring;

type

TComponentJsonHelper = class helper for TComponent

protected

procedure DoSaveToJson(AStream: TStream; AJson: TQJson);

procedure DoLoadFromJson(AParent: TComponent; AJson: TQJson;

ALoaded: TList);

public

procedure SaveToJson(AJson: TQJson);

procedure LoadFromJson(AJson: TQJson);

end;

{ TComponentJsonHelper }

procedure TComponentJsonHelper.LoadFromJson(AJson: TQJson);

var

ALoaded: TList;

I: Integer;

begin

ALoaded := TList.Create;

GlobalNameSpace.BeginWrite;

try

DoLoadFromJson(nil, AJson, ALoaded);

for I := 0 to ALoaded.Count - 1 do

TComponent(ALoaded[I]).Loaded;

Loaded;

finally

GlobalNameSpace.EndWrite;

end;

procedure TComponentJsonHelper.DoLoadFromJson(AParent: TComponent;

AJson: TQJson; ALoaded: TList);

type

PComponentState = ^TComponentState;

var

AChildPos: Integer;

AList: TQJson;

ACompState: PComponentState;

function JsonToSet(AValues: TQJson): String;

var

I: Integer;

begin

Result := '[';

for I := 0 to AValues.Count - 1 do

begin

if I = 0 then

Result := AValues[I].AsString

else

Result := Result + ',' + AValues[I].AsString;

end;

Result := Result + ']';

end;

function PropByPath(var Instance: TObject; APath: String): PPropInfo;

var

AName: String;

APos: Integer;

begin

AName := DecodeTokenW(APath, '.', #0, true, true);

Result := GetPropInfo(Instance, AName);

if (Length(APath) > 0) then

begin

if (Result.PropType^.Kind = tkClass) then

begin

Instance := TObject(GetOrdProp(Instance, Result));

if Assigned(Instance) then

Result := PropByPath(Instance, APath)

else

Result := nil;

end

else

Result := nil;

end;

procedure LoadProps(ARootInstance: TObject; AProps: TQJson);

var

I: Integer;

AProp: PPropInfo;

APropJson: TQJson;

AInstance: TObject;

begin

if not Assigned(ARootInstance) then

Exit;

for I := 0 to AProps.Count - 1 do

begin

APropJson := AProps[I];

AInstance := ARootInstance;

AProp := PropByPath(AInstance, APropJson.Name);

if Assigned(AProp) then

begin

case AProp.PropType^.Kind of

tkInteger:

SetOrdProp(AInstance, AProp, APropJson.AsInteger);

tkChar, tkWChar:

begin

if APropJson.IsString then

SetOrdProp(AInstance, AProp, Ord(PChar(APropJson.AsString)^))

else

SetOrdProp(AInstance, AProp, APropJson.AsInteger);

end;

tkEnumeration:

SetEnumProp(AInstance, AProp, APropJson.AsString);

tkFloat:

SetFloatProp(AInstance, AProp, APropJson.AsFloat);

tkString, tkLString, tkWString, tkUString:

SetStrProp(AInstance, AProp, APropJson.AsString);

tkSet:

SetSetProp(AInstance, AProp, JsonToSet(APropJson));

tkClass:

LoadProps(Pointer(GetOrdProp(AInstance, AProp)), APropJson);

tkVariant:

SetVariantProp(AInstance, AProp, APropJson.AsVariant);

// tkArray,tkDynArray,tkRecord, tkInterface,tkClassRef,tkPointer, tkProcedure

tkInt64:

SetInt64Prop(AInstance, AProp, APropJson.AsInt64);

end;

procedure LoadChildren(AObjects: TQJson);

var

I: Integer;

AChildComp: TComponent;

AClass: TClass;

AClassName: String;

begin

for I := 0 to AObjects.Count - 1 do

begin

AClassName := AObjects[I].ValueByName('ClassName', '');

AClass := FindClass(AClassName);

if AClass = TComponent then

begin

if Assigned(Owner) then

AChildComp := TComponentClass(AClass).Create(Owner)

else

AChildComp := TComponentClass(AClass).Create(Self);

AChildComp.DoLoadFromJson(Self, AObjects[I], ALoaded);

end

else

raise EClassNotFound.CreateFmt('Class %s not found', [AClassName]);

end;

begin

ACompState := @ComponentState;

ACompState^ := ACompState^ + [csLoading, csReading];

try

Name := AJson.ValueByName('Name', '');

if AJson.HasChild('Props', AList) then

LoadProps(Self, AList);

if AJson.HasChild('Children', AList) then

LoadChildren(AList);

finally

ACompState^ := ACompState^ - [csLoading, csReading];

if Assigned(ALoaded) then

ALoaded.Add(Self);

end;

if Assigned(AParent) then

begin

AChildPos := AJson.IntByName('ChildPos', -1);

if AChildPos > 0 then

AParent.SetChildOrder(Self, AChildPos);

end;

procedure TComponentJsonHelper.DoSaveToJson(AStream: TStream; AJson: TQJson);

var

Reader: TReader;

ObjectName, PropName: string;

procedure ConvertValue(AItem: TQJson); forward;

procedure ConvertHeader(AItem: TQJson);

var

ClassName: string;

Flags: TFilerFlags;

Position: Integer;

begin

Reader.ReadPrefix(Flags, Position);

ClassName := Reader.ReadStr;

ObjectName := Reader.ReadStr;

AItem.Add('Name').AsString := Name;

AItem.Add('ClassName').AsString := ClassName;

if ffInherited in Flags then

AItem.Add('InstanceType').AsString := 'inherited'

else if ffInline in Flags then

AItem.Add('InstanceType').AsString := 'inline'

else

AItem.Add('InstanceType').AsString := 'object';

if ffChildPos in Flags then

AItem.Add('ChildPos').AsInteger := Position;

end;

procedure ConvertBinary(AItem: TQJson);

var

Count: Integer;

Buffer: TBytes;

begin

Reader.ReadValue;

Reader.Read(Count, SizeOf(Count));

SetLength(Buffer, Count);

Reader.Read(Buffer, Count);

AItem.AsBytes := Buffer;

end;

procedure ConvertProperty(AItem: TQJson); forward;

procedure ConvertValue(AItem: TQJson);

const

LineLength = 64;

var

S: String;

begin

case Reader.NextValue of

vaList:

begin

Reader.ReadValue;

AItem.DataType := jdtArray;

while not Reader.EndOfList do

ConvertValue(AItem.Add);

end;

vaInt8, vaInt16, vaInt32:

AItem.AsInteger := Reader.ReadInteger;

vaExtended, vaDouble:

AItem.AsFloat := Reader.ReadFloat;

vaSingle:

AItem.AsFloat := Reader.ReadSingle;

vaCurrency:

AItem.AsFloat := Reader.ReadCurrency;

vaDate:

AItem.AsDateTime := Reader.ReadDate;

vaWString, vaUTF8String, vaString, vaLString:

AItem.AsString := Reader.ReadString;

vaIdent:

AItem.AsString := Reader.ReadIdent;

vaFalse:

AItem.AsBoolean := False;

vaTrue:

AItem.AsBoolean := true;

vaNil, vaNull:

AItem.ResetNull;

vaBinary:

ConvertBinary(AItem);

vaSet:

begin

Reader.ReadValue;

AItem.DataType := jdtArray;

while true do

begin

S := Reader.ReadStr;

if S = '' then

Break;

AItem.Add.AsString := S;

end;

vaCollection:

begin

Reader.ReadValue;

AItem.DataType := jdtObject;

while not Reader.EndOfList do

begin

with AItem.AddArray('items') do

begin

if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then

ConvertValue(Add);

end;

Reader.CheckValue(vaList);

while not Reader.EndOfList do

ConvertProperty(AItem);

end;

Reader.ReadListEnd;

end;

vaInt64:

AItem.AsInt64 := Reader.ReadInt64;

else

raise EReadError.CreateFmt('Can not read %s property %s',

[ObjectName, PropName]);

end;

procedure ConvertProperty(AItem: TQJson);

begin

ConvertValue(AItem.Add(Reader.ReadStr));

end;

procedure ConvertObject(AItem: TQJson);

var

AObject, AList: TQJson;

begin

ConvertHeader(AItem);

AList := AItem.Add('Props');

while not Reader.EndOfList do

ConvertProperty(AList);

Reader.ReadListEnd;

AList := AItem.Add('Children');

AList.DataType := jdtObject;

while not Reader.EndOfList do

ConvertObject(AList);

Reader.ReadListEnd;

end;

begin

Reader := TReader.Create(AStream, 4096);

try

Reader.ReadSignature;

ConvertObject(AJson);

finally

Reader.Free;

end;

procedure TComponentJsonHelper.SaveToJson(AJson: TQJson);

var

AStream: TMemoryStream;

begin

AStream := TMemoryStream.Create;

try

AStream.WriteComponent(Self);

AStream.Position := 0;

DoSaveToJson(AStream, AJson);

finally

FreeAndNil(AStream);

end;

使用示例：

procedure TForm1.Button1Click(Sender: TObject);
var
  AJson: TQJson;
begin
  AJson := AcquireJson;
  try
    LabeledEdit1.SaveToJson(AJson);
    ShowMessage(AJson.AsJson);
    LabeledEdit1.EditLabel.Caption := 'Hello';
    LabeledEdit1.Text := '';
    Button2.Caption:='Json Converted';
    ShowMessage('from json');
    LabeledEdit1.LoadFromJson(AJson);
  finally
    ReleaseJson(AJson);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);

var

AJson: TQJson;

begin

AJson := AcquireJson;

try

LabeledEdit1.SaveToJson(AJson);

ShowMessage(AJson.AsJson);

LabeledEdit1.EditLabel.Caption := 'Hello';

LabeledEdit1.Text := '';

Button2.Caption:='Json Converted';

ShowMessage('from json');

LabeledEdit1.LoadFromJson(AJson);

finally

ReleaseJson(AJson);

end;

如上面的示例，由于写成了 class helper，所以保存到 Json 里，直接调用组件实例的 SaveToJson 就可以了，而从 Json 中恢复则直接调用组件实例的 LoadFromJson 就可以了。

上面的代码加入 C++Builder，然后可以直接引用。

登录