Delphi 處理Json字串－抓狂小白的程式筆記

Delphi XE10 已經有內建的Json處理Unit 請見 http://kamilia1470.pixnet.net/blog/post/217835349###

Delphi 7 網路上也有別人用好的Json Unit 感覺跟XE差不多

但是我覺得很難用要搞很久才懂他的意思而且不能直接知道有多少物件

要是Range下錯就直接跳錯

於是自己弄了一個Unit來處理Json

Json 格式我就簡單介紹一下詳細的還是得自己Google

總而言之

最基本的就是 Key:Value

我稱之為 BaseJson

{ } 包起來的就是物件裡面可以有很多BaseItem 也可以有很多 "Value 為陣列的Item"

[ ] 包起來的就是陣列裡面可以有很多物件

總而言之就是物件裡面可以有陣列裡面又有物件或是陣列裡面有物件又有陣列又有物件......

最外層可以是物件也可以是陣列麻煩就在這

以下是我自己寫的Json Unit

(*
(* TBaseJson使用
var bj:TBaseJson;
begin
{
with bj do
begin
Key:='123';
Value:='abc';
ShowMessage(Source);
end
}
{
with bj do
begin
Source:='"123":"abc"';
ShowMessage(Key+#13+Value);
end
}

(* TOneJsonObject 使用
var
jo:TOneJsonObject;
i:integer;
begin
//BaseJsonItem
jo.Source:='{"abc":"123","cde":"456","ttt":[{"ace":"789"}],"ijk":"567"}';
for I := 0 to length(jo.JsonItems)-1 do
begin
if jo.JsonItems[i].IsBaseJson then
ShowMessage('T')
else
ShowMessage('F');

ShowMessage(jo.JsonItems[i].Source);
end;

(* TjsonArray 範例

var
jo:TOneJsonObject;
i:integer;
begin
//BaseJsonItem
jo.Source:='{"abc":"123","cde":"456","ttt":[{"ace":"789"},{"ppp":"555","kkk":"666"}],"ijk":"567"}';
// ↑↑↑
ShowMessage(jo.JsonItems[2].ValueAsArray.JsonObjects[1].JsonItems[1].Value);

(* *)
unit XBJsonUnit;

interface

uses System.Classes,System.SysUtils,SysConst;

Type
TBaseJson = class //JSon最底層沒有陣列單一個key = Value型態
private
FKey:String;
FValue:string;
Function GetSource:String;
procedure SetSource(Value: String);
procedure SetKey(Value: String);
procedure SetValue(Value: String);
published
property Source: String read GetSource write SetSource;
property Key: String read FKey write SetKey;
property Value: String read FValue write SetValue;
end;

TJsonItem = class;

TJsonObject = record //用 { } 包起來的為 TOneJsonObject 裡面可以有很多 TJsonItem
JsonItems:array of TJsonItem;
private
FSource:string;
procedure SetSource(Value: String);
public
property Source: String read FSource write SetSource;
end;

TJsonArray = record //用 [ ] 包起來的為 TJsonArray 裡面可以有很多 TOneJsonObject
JsonObjects:array of TJsonObject;
private
FSource:string;
procedure SetSource(Value: String);
public
property Source: String read FSource write SetSource;
end;

TJsonItem = class(TBaseJson) //指單一個item (與下一個item 用,分隔的) 只會有兩種型態 1=BaseJson (key = Value) 2=含有陣列的Json (key = TJsonArray)
public
function IsBaseJson:Boolean;
private
Function GetValueAsArray:TJsonArray;
Procedure SetValueAsArray(Value: TJsonArray);
published
property ValueAsArray: TJsonArray read GetValueAsArray write SetValueAsArray;
end;

implementation

{ TBaseJson }

procedure TBaseJson.SetSource(Value: String);
begin
while Pos('"',Value)>0 do
Delete(Value,Pos('"',Value),1);
while Pos(' ',Value)>0 do
Delete(Value,Pos(' ',Value),1);
FKey:=Copy(Value,1,Pos(':',Value)-1);
FValue:=Copy(Value,Pos(':',Value)+1,Length(Value)-Pos(':',Value));
end;

function TBaseJson.GetSource: String;
begin
Result:='"'+FKey+'":"'+FValue+'"';
end;

procedure TBaseJson.SetKey(Value: String);
begin
if FKey<>Value then
FKey:=Value;
end;

procedure TBaseJson.SetValue(Value: String);
begin
if FValue<>Value then
FValue:=Value;
end;

{ TJsonArray }

procedure TJsonArray.SetSource(Value: String);
var
JSonArrayStr:String; //拿來分解的字串
i,OCount,PosD:integer;
JsonObjectData:TStrings; //拿來裝所有JsonObject資料
begin
if FSource=Value then
Exit;
FSource:=Value;

//預防空直
if Source='' then
begin
raise EConvertError.CreateFmt(System.SysConst.SInvalidSourceArray, ['Empty']);
Exit;
end;

//一定要是 [開頭 ]結尾
if (Source[1] <> '[') or (Source[Length(Source)] <> ']') then
begin
raise EConvertError.CreateFmt(System.SysConst.SInvalidSourceArray, ['"[" and "]"']);
Exit;
end;

JSonArrayStr:=Source;
//先去掉頭尾 { }
Delete(JSonArrayStr,1,1);
Delete(JSonArrayStr,Length(JSonArrayStr),1);

JsonObjectData:=TStringlist.Create;

repeat
PosD:=Pos('},{',JSonArrayStr);
if PosD=0 then //找不到逗號等於結束
begin
JsonObjectData.Append(JSonArrayStr);
end
else
begin
//陣列裡面一定是 {object1},{object2],...,{objectlast} 所以一定要是 {開頭 {結尾
if (JSonArrayStr[1] <> '{') or (JSonArrayStr[Length(JSonArrayStr)] <> '}') then
begin
raise EConvertError.CreateFmt(System.SysConst.SInvalidSourceArray,
['Array inside must be begin "{" end "}"']);
Exit;
end;

OCount:=0;
for I := 1 to Length(JSonArrayStr) do //從 [ 後面的字元開始數遇到 [ + 1 遇到 ] -1 直到 ACount 等於0
begin
case JSonArrayStr[i] of
'{':Inc(OCount);
'}':Dec(OCount);
end;
if OCount=0 then
Break;
end;
// } 後面一定是逗號 (最後一個的話不會進到這裡)
JsonObjectData.Append(Copy(JSonArrayStr,1,i));
Delete(JSonArrayStr,1,i+1);
end;
until PosD=0;

SetLength(JsonObjects,JsonObjectData.Count);

for I := 0 to JsonObjectData.Count-1 do
JsonObjects[i].Source:=JsonObjectData[i];

JsonObjectData.free;
end;

{ TOneJsonObject }

procedure TJsonObject.SetSource(Value: String);
var
JsonObjectStr:string; //拿來分解的字串
bufArrayStr:string; //若遇到陣列要佔存字串
i,PosD,PosA,ACount:Integer; //下一個位置 PosD = , PosA = [ ACount 用來數陣列的結束位置
JsonItemData:TStrings; //拿來裝所有Item資料
procedure GetNextItem;
begin
JsonItemData.Append(Copy(JsonObjectStr,1,PosD-1));
Delete(JsonObjectStr,1,PosD);
end;
begin
if FSource=Value then
Exit;
FSource:=Value;
//用 { } 包起來的為 TOneJsonObject 裡面可以有很多 TJsonItem

//預防空直
if Source='' then
begin
raise EConvertError.CreateFmt(System.SysConst.SInvalidSourceArray, ['Empty']);
Exit;
end;

//一定要是 {開頭 {結尾
if (Source[1] <> '{') or (Source[Length(Source)] <> '}') then
begin
raise EConvertError.CreateFmt(System.SysConst.SInvalidSourceArray, ['"{" and "}"']);
Exit;
end;

JsonObjectStr:=Source;
//先去掉頭尾 { }
Delete(JsonObjectStr,1,1);
Delete(JsonObjectStr,Length(JsonObjectStr),1);

JsonItemData:=TStringList.Create;
repeat
PosD:=Pos(',',JsonObjectStr);
if PosD=0 then //找不到逗號等於結束
begin
JsonItemData.Append(JsonObjectStr);
end
else
begin
PosA:= Pos('[',JsonObjectStr); //下一個陣列位置
if PosA=0 then //若沒有陣列也就是最原始的物件只有{item,item} 這樣
begin
GetNextItem;
end
else //若有陣列就會像這樣 {itme,item,key:[...],item}
begin
if PosA>PosD then //若 [ 比 , 遠代表下一個item 還是最基本的item
begin
GetNextItem;
end
else //若 [ 比 , 近代表下一個item 就是包含array的item
begin
ACount:=1;
for I := PosA+1 to Length(JsonObjectStr) do //從 [ 後面的字元開始數遇到 [ + 1 遇到 ] -1 直到 ACount 等於0
begin
case JsonObjectStr[i] of
'[':Inc(ACount);
']':Dec(ACount);
end;
if ACount=0 then
Break;
end;
// ] 後面一定是逗號 (最後一個的話不會進到這裡)
JsonItemData.Append(Copy(JsonObjectStr,1,i));
Delete(JsonObjectStr,1,i+1);
end;
end;
end;
until PosD=0;

SetLength(JsonItems,JsonItemData.Count);

for I := 0 to JsonItemData.Count-1 do
begin
JsonItems[i]:=TJsonItem.Create;
JsonItems[i].Source:=JsonItemData[i];
end;

JsonItemData.Free;
end;

{ TJsonItem }

function TJsonItem.IsBaseJson: Boolean;
begin
Result:= Pos('[',FValue)=0; //沒有陣列就是最底層
end;

function TJsonItem.GetValueAsArray: TJsonArray;
begin
if IsBaseJson then
begin
raise EConvertError.CreateFmt(System.SysConst.SInvalidSourceArray, [Source]);
Exit;
end;
Result.Source:=FValue;
end;

procedure TJsonItem.SetValueAsArray(Value: TJsonArray);
begin
FValue:=Value.Source;
end;

end.

範例 >> 使用樹狀圖呈現資料

procedure TForm1.Button1Click(Sender: TObject);
Procedure BuildTree(JsonStr:string;PNode:TTreeNode);
var
jo:TJsonObject;
ja:TJsonArray;
i:Integer;
NNode:TTreeNode;
begin
if JsonStr='' then
Exit;
case JsonStr[1] of
'{': //物件
begin
jo.Source:=JsonStr;
for I := 0 to length(jo.JsonItems)-1 do
with jo.JsonItems[i] do
if IsBaseJson then
TreeView1.Items.AddChild(PNode,'Item '+ IntToStr(i) + ' ' + Source)
else
begin
NNode:=TreeView1.Items.AddChild(PNode,'Item '+ IntToStr(i) + ' Key = ' + Key);
BuildTree(ValueAsArray.Source,NNode); //遇到陣列就往下一階開始建立
end;
end;
'[': //陣列
begin
ja.Source:=JsonStr;
for I := 0 to Length(ja.JsonObjects)-1 do
with ja.JsonObjects[i] do
begin
NNode:=TreeView1.Items.AddChild(PNode,'object '+ IntToStr(i));
BuildTree(Source,NNode); //每一個物件都要往下一階建立
end;
end;
else
begin
ShowMessage('錯誤參數');
Exit;
end;
end;
end;
begin
BuildTree(Edit1.Text,nil);
end;

附上檔案

https://drive.google.com/open?id=0B_Boa0V6iHIuWGdtOXczQ0ZSdmM

以下代碼為XE版本可以直接使用Json "陣列" 直接轉為TClientDataSet (與上面無關)

是我自己在用的Json處理的Unit

unit XBJsonUnit;

interface

uses System.Classes,IdHTTP,JSon,FMX.Dialogs,
REST.Response.Adapter, REST.Client,
Data.Bind.Components, Data.Bind.ObjectScope,
Datasnap.DBClient
,IPPeerClient //不USE 可以過但會跳一個很奇怪的錯誤 (要拉REST元件才會自動USE這個)
;

type
TRestJsonCDS=class(TClientDataSet)
RESTClient: TRESTClient;
RESTRequest: TRESTRequest;
RESTResponse: TRESTResponse;
RESTResponseDataSetAdapter: TRESTResponseDataSetAdapter;
public
constructor Create(AOwner: TComponent;BaseURL:String;ParaTs:TStrings=nil); overload;
constructor Create(AOwner: TComponent;BaseURL:String;ParaStr:array of String); overload;
destructor destroy; override;
end;

function GetPostReturn(URL:string;ParaTs:TStrings;var ReturnStr:String):Boolean; overload;
function GetPostReturn(URL:string;ParaTs:TStrings):string; overload;

function GetXBJson(BaseUrl,MainFunctionName,SubFunctionName:string;ParaTs:TStrings):string; overload;
function GetXBJson(BaseUrl,MainFunctionName,SubFunctionName:string;ParaStr:array of String):string; overload;

function GetXBJSonCDS(BaseURL,MainFunctionName,SubFunctionName:string;ParaTs:TStrings=nil):TRestJsonCDS; overload; //此函數將自動產生一個CDS 需自行釋放
function GetXBJSonCDS(BaseURL,MainFunctionName,SubFunctionName:string;ParaStr:array of String):TRestJsonCDS; overload; //此函數將自動產生一個CDS 需自行釋放

function GetXBJsonOneField(BaseURL,MainFunctionName,SubFunctionName:string;ParaStr:array of String;FieldName:String):string;

Const EmptyRecord=''; //當CDS為完全空值時回傳此字串未來有可能會回傳空字串時可以修改這裡以區分空值跟空DB

implementation

uses REST.Types;

function GetFullURL(BaseUrl,MainFunctionName,SubFunctionName:string):String;
begin
result:= BaseUrl+'/'+MainFunctionName+'/'+SubFunctionName;
end;

function GetPostReturn(URL:string;ParaTs:TStrings;var ReturnStr:String):Boolean;
var idhttp:TIdHttp;
begin
Result:=True;
ReturnStr:='';
idhttp:=TIdHttp.Create(nil);
try
try
showmessage('URL>>'+URL+#13+ParaTs.Text);
ReturnStr:=IdHTTP.Post(URL,ParaTs);
except
Result:=False;
end;
finally
idhttp.Free;
end;
end;

function GetPostReturn(URL:string;ParaTs:TStrings):string; overload;
begin
//ShowMessage('GetPostReturn URL >> '+URL);
GetPostReturn(URL,ParaTs,Result);
end;

function GetXBJson(BaseUrl,MainFunctionName,SubFunctionName:string;ParaTs:TStrings):string;
begin
Result:=GetPostReturn(GetFullURL(BaseUrl,MainFunctionName,SubFunctionName),ParaTs);
end;

//ParaStr 省去TStrings的麻煩但一定要 Name Value Name Value 若Length為奇數則取消返回
function GetXBJson(BaseUrl,MainFunctionName,SubFunctionName:string;ParaStr:array of String):string;
var ts:TStrings;
I: Integer;
begin
if Length(ParaStr) mod 2 = 1 then
begin
Showmessage('ParaStr Error');
Exit;
end;
ts:=TStringList.Create;
try
for I := 0 to (Length(ParaStr) div 2)-1 do
ts.Values[ParaStr[i*2]]:=ParaStr[i*2+1];
//ShowMessage(ts.Text);
Result:=GetXBJson(BaseUrl,MainFunctionName,SubFunctionName,ts);
finally
ts.Free;
end;
end;

function GetXBJSonCDS(BaseURL,MainFunctionName,SubFunctionName:string;ParaTs:TStrings):TRestJsonCDS; //此函數將自動產生一個CDS 需自行釋放
begin
Result:=TRestJsonCDS.Create(nil,GetFullURL(BaseURL,MainFunctionName,SubFunctionName),ParaTS);
end;

function GetXBJSonCDS(BaseURL,MainFunctionName,SubFunctionName:string;ParaStr:array of String):TRestJsonCDS; overload; //此函數將自動產生一個CDS 需自行釋放
var ts:TStrings;
I: Integer;
begin
if Length(ParaStr) mod 2 = 1 then
begin
Showmessage('ParaStr Error');
Exit;
end;
ts:=TStringList.Create;
try
for I := 0 to (Length(ParaStr) div 2)-1 do
ts.Values[ParaStr[i*2]]:=ParaStr[i*2+1];
//ShowMessage(ts.Text);
Result:=GetXBJSonCDS(BaseUrl,MainFunctionName,SubFunctionName,ts);
finally
ts.Free;
end;
end;

function GetXBJsonOneField(BaseURL,MainFunctionName,SubFunctionName:string;ParaStr:array of String;FieldName:String):string;
begin
with GetXBJSonCDS(BaseURL,MainFunctionName,SubFunctionName,ParaStr) do
begin
if FindField(FieldName)<>nil then
Result:=FieldByName(FieldName).AsString
else
begin
//ShowMessage('Field Not Found!');
Result:=EmptyRecord;
end;
Free;
end;
end;

{ TRestJsonCDS }

constructor TRestJsonCDS.Create(AOwner: TComponent;BaseURL:String;ParaTs:TStrings=nil);
var i:integer;
begin
inherited Create(AOwner);
RESTClient:=TRESTClient.Create(Self);
RESTRequest:=TRESTRequest.Create(Self);
RESTResponse:=TRESTResponse.Create(Self);
RESTResponseDataSetAdapter:=TRESTResponseDataSetAdapter.Create(Self);

RESTRequest.Client:=RESTClient;
RESTRequest.Response:=RESTResponse;

RESTResponseDataSetAdapter.Response:=RESTResponse;
RESTResponseDataSetAdapter.Dataset:=Self;

RESTClient.BaseURL:=BaseURL;

if ParaTs<>nil then
begin
RESTRequest.Method := rmPOST;
for I := 0 to ParaTs.Count-1 do
RESTRequest.Params.AddItem(ParaTs.Names[i],ParaTs.ValueFromIndex[i]);
end;

RESTRequest.Execute;
end;

constructor TRestJsonCDS.Create(AOwner: TComponent; BaseURL: String;
ParaStr: array of String);
var ts:TStrings;
I: Integer;
begin
if Length(ParaStr) mod 2 = 1 then
begin
Showmessage('ParaStr Error');
Exit;
end;
ts:=TStringList.Create;
try
for I := 0 to (Length(ParaStr) div 2)-1 do
ts.Values[ParaStr[i*2]]:=ParaStr[i*2+1];
//ShowMessage(ts.Text);
inherited Create(AOwner);
RESTClient:=TRESTClient.Create(Self);
RESTRequest:=TRESTRequest.Create(Self);
RESTResponse:=TRESTResponse.Create(Self);
RESTResponseDataSetAdapter:=TRESTResponseDataSetAdapter.Create(Self);

RESTRequest.Client:=RESTClient;
RESTRequest.Response:=RESTResponse;

RESTResponseDataSetAdapter.Response:=RESTResponse;
RESTResponseDataSetAdapter.Dataset:=Self;

RESTClient.BaseURL:=BaseURL;

RESTRequest.Method := rmPOST;
for I := 0 to ts.Count-1 do
RESTRequest.Params.AddItem(ts.Names[i],ts.ValueFromIndex[i]);

RESTRequest.Execute;
finally
ts.Free;
end;
end;

destructor TRestJsonCDS.destroy;
begin
RESTResponseDataSetAdapter.Free;
RESTResponse.Free;
RESTRequest.Free;
RESTClient.Free;
inherited destroy;
end;

end.

附上檔案

https://github.com/Kamilia1470/XBJsonUnit.git

抓狂小白

抓狂小白的程式筆記

抓狂小白發表在痞客邦留言(0) 人氣()

E-mail轉寄

抓狂小白的程式筆記

之前無聊到跑去知識加回答一些程式問題然後驚覺之前學得很多種程式語言都退化了所以開了這個部落格做筆記主要精通Delphi 其他程式語言還在新手階段由於想試試自己的身手及能耐若有甚麼小程式需要幫忙的歡迎留言

Delphi 處理Json字串

留言列表

我的連結

熱門文章

文章分類

JSP (2)

Delphi (19)

JAVA (2)

Windows API (2)

VB (1)

PHP (3)

C (2)

DataBase (2)

Python (2)

最新文章

最新留言

文章搜尋

參觀人氣

QR Code

抓狂小白的程式筆記

之前無聊到跑去知識加回答一些程式問題 然後驚覺之前學得很多種程式語言都退化了 所以開了這個部落格做筆記 主要精通Delphi 其他程式語言還在新手階段 由於想試試自己的身手及能耐 若有甚麼小程式需要幫忙的歡迎留言

Delphi 處理Json字串

留言列表

我的連結

熱門文章

文章分類

JSP (2)

Delphi (19)

JAVA (2)

Windows API (2)

VB (1)

PHP (3)

C (2)

DataBase (2)

Python (2)

最新文章

最新留言

文章搜尋

參觀人氣

QR Code

之前無聊到跑去知識加回答一些程式問題然後驚覺之前學得很多種程式語言都退化了所以開了這個部落格做筆記主要精通Delphi 其他程式語言還在新手階段由於想試試自己的身手及能耐若有甚麼小程式需要幫忙的歡迎留言