DELPHI 微信公众平台 订阅号（二）

一、采用IdHTTPServer

unit fun_send; interface uses Winapi.Windows, System.Classes, IPPeerClient, REST.Client, REST.Types, System.JSON; function rest_get(server_url: string; send_name_strlist: TStringList; send_info_strlist: TStringList): string; function rest_post(server_url: string; send_json: TJSONObject;json_name:string): string; implementation function rest_get(server_url: string; send_name_strlist: TStringList; send_info_strlist: TStringList): string; var i: integer; // 发送用 temp_RESTClient1: TRESTClient; temp_RESTResponse1: TRESTResponse; temp_RESTRequest1: TRESTRequest; //接收用 recv_str: string; begin // 发送 temp_RESTClient1 := TRESTClient.Create(nil); temp_RESTClient1.HandleRedirects := true; temp_RESTResponse1 := TRESTResponse.Create(nil); temp_RESTRequest1 := TRESTRequest.Create(nil); temp_RESTRequest1.Client := temp_RESTClient1; temp_RESTRequest1.Method := rmGET; temp_RESTRequest1.Response := temp_RESTResponse1; temp_RESTRequest1.SynchronizedEvents := false; temp_RESTClient1.BaseURL := server_url; temp_RESTRequest1.Params.Clear; for i := 0 to send_name_strlist.Count - 1 do begin temp_RESTRequest1.AddParameter(send_name_strlist[i], send_info_strlist[i]); end; try temp_RESTRequest1.Execute; recv_str := temp_RESTResponse1.Content; except recv_str := '提交失败'; end; temp_RESTClient1.Free; temp_RESTRequest1.Free; temp_RESTResponse1.Free; result := recv_str; end; function rest_post(server_url: string; send_json: TJSONObject;json_name:string): string; var i: integer; // 发送用 temp_RESTClient1: TRESTClient; temp_RESTResponse1: TRESTResponse; temp_RESTRequest1: TRESTRequest; //接收用 recv_str: string; begin // 发送 temp_RESTClient1 := TRESTClient.Create(nil); temp_RESTClient1.HandleRedirects := true; temp_RESTResponse1 := TRESTResponse.Create(nil); temp_RESTRequest1 := TRESTRequest.Create(nil); temp_RESTRequest1.Client := temp_RESTClient1; temp_RESTRequest1.Method := rmPOST; temp_RESTRequest1.Response := temp_RESTResponse1; temp_RESTRequest1.SynchronizedEvents := false; temp_RESTClient1.BaseURL := server_url; temp_RESTRequest1.Params.Clear; temp_RESTRequest1.AddParameter(json_name, send_json); try temp_RESTRequest1.Execute; recv_str := temp_RESTResponse1.Content; except recv_str := '提交失败'; end; temp_RESTClient1.Free; temp_RESTRequest1.Free; temp_RESTResponse1.Free; result := recv_str; end; end.

二、主窗体代码

unit Unit1; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.JSON, Vcl.ExtCtrls, Vcl.StdCtrls, fun_send, IdContext, Web.HTTPApp, IdCustomHTTPServer, IdBaseComponent, IdComponent, IdCustomTCPServer, IdHTTPServer, DCPcrypt2, DCPblockciphers, DCPdes, DCPsha256,IdHashSHA; type Pwx_info_in = ^Twx_info_in; Twx_info_in = record url: string; AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo end; type TForm1 = class(TForm) GroupBox1: TGroupBox; GroupBox2: TGroupBox; Label3: TLabel; Label4: TLabel; Edit4: TEdit; Edit5: TEdit; Button3: TButton; Button2: TButton; Label1: TLabel; Edit2: TEdit; Label2: TLabel; Edit3: TEdit; Timer1: TTimer; GroupBox3: TGroupBox; Button1: TButton; Edit1: TEdit; CheckBox1: TCheckBox; IdHTTPServer1: TIdHTTPServer; Memo1: TMemo; DCP_sha2561: TDCP_sha256; DCP_des1: TDCP_des; DCP_des2: TDCP_des; procedure Button2Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure IdHTTPServer1CommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.Button1Click(Sender: TObject); begin // 设置绑定参数 IdHTTPServer1.Bindings.Clear; IdHTTPServer1.DefaultPort := StrToInt(edit1.Text); IdHTTPServer1.Bindings.Add.IP := '0.0.0.0'; // 启动服务器 IdHTTPServer1.Active := True; end; procedure TForm1.Button2Click(Sender: TObject); var send_name_strlist: TStringList; send_info_strlist: TStringList; i: integer; recv_str: string; //接收用 recv_json: tjsonobject; //临时生成的 recv_jv: tjsonvalue; recv_jv_num: TJSONNumber; access_token: string; expires_in: integer; begin //关闭有效期定时器 Timer1.Enabled := false; send_name_strlist := TStringList.Create; send_info_strlist := TStringList.Create; send_name_strlist.Add('grant_type'); send_info_strlist.Add('client_credential'); send_name_strlist.Add('appid'); send_info_strlist.Add(Edit4.Text); send_name_strlist.Add('secret'); send_info_strlist.Add(Edit5.Text); recv_str := rest_get('https://api.weixin.qq.com/cgi-bin/token', send_name_strlist, send_info_strlist); // recv_str := AnsiToUtf8(recv_str); //接收 recv_json := tjsonobject.Create; recv_json := TJSONObject.parsejsonvalue(tencoding.utf8.getbytes(recv_str), 0) as TJSONObject; recv_jv := recv_json.get('access_token').jsonvalue; access_token := recv_jv.Value; recv_jv_num := recv_json.get('expires_in').JsonValue as TJSONNumber; expires_in := recv_jv_num.AsInt; //接收完成 Edit2.Text := access_token; Edit3.Text := IntToStr(expires_in); send_name_strlist.Free; send_info_strlist.Free; //打开有效期定时器 Edit4.Text := ''; Edit5.Text := ''; Timer1.Enabled := True; end; procedure TForm1.Button3Click(Sender: TObject); begin Edit4.Text := ''; Edit5.Text := ''; end; procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); procedure wx_fun(var wx_info_in: Twx_info_in); function wx_access(var wx_info_in: Twx_info_in): string; function sha1(input: string): string; begin with tidhashsha1.create do try result := HashStringAsHex(input); finally free; end; end; function checktoken(token, signature, timestamp, nonce, echostr: string): string; var s, s1: string; tmp: TStringList; begin tmp := TStringList.Create; try tmp.Delimiter := ','; s := token + ',' + timestamp + ',' + nonce; tmp.DelimitedText := s; tmp.Sorted := true; s := tmp.Strings[0] + tmp.Strings[1] + tmp.Strings[2]; s1 := sha1(s); if s1.ToUpper = signature.ToUpper then Result := echostr else Result := 'error'; finally tmp.Free; end; end; var url: string; AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo; //提取参数 recv_signature: string; recv_timestamp: string; recv_nonce: string; recv_echostr: string; temp_str: string; RespStr: string; begin url := wx_info_in.url; AContext := wx_info_in.AContext; ARequestInfo := wx_info_in.ARequestInfo; AResponseInfo := wx_info_in.AResponseInfo; //微信认证 recv_signature := ARequestInfo.Params.Values['signature']; recv_timestamp := ARequestInfo.Params.Values['timestamp']; recv_nonce := ARequestInfo.Params.Values['nonce']; recv_echostr := ARequestInfo.Params.Values['echostr']; temp_str := checktoken('微信网站上设置的 token', recv_signature, recv_timestamp, recv_nonce, recv_echostr); //生成返回 AResponseInfo.ContentType := 'text/HTML;charset=utf-8'; RespStr := temp_str; AResponseInfo.ContentText := AnsiToUtf8(RespStr); end; var url: string; AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo; begin Form1.Memo1.Lines.Add('处理微信函数'); url := wx_info_in.url; AContext := wx_info_in.AContext; ARequestInfo := wx_info_in.ARequestInfo; AResponseInfo := wx_info_in.AResponseInfo; if Form1.CheckBox1.Checked = true then begin Form1.Memo1.Lines.Add('接收到微信消息类型为:' + ARequestInfo.Command); Form1.Memo1.Lines.Add('访问模块为:' + url); end; if (url = '/Twx/Rwx') or (url = '/Twx/Rwx/') then begin //微信认证 if ARequestInfo.Command = 'GET' then begin wx_access(wx_info_in) end; //微信POST消息 if ARequestInfo.Command = 'POST' then // post begin if Form1.CheckBox1.Checked = true then begin Form1.Memo1.Lines.Add('接收到微信POST消息'); end; //wx_recv_post(wx_info_in); //返回微信消息 end; end; end; var RespStr, recvText: string; msgText: string; recv_url: string; //访问模块 wx_info_in: Twx_info_in; Buf: TBytes; temp_str: string; Stream: TStream; begin try try //获取在访问的模块 recv_url := ARequestInfo.Document; //调试模式下显示收到内容 if CheckBox1.Checked = true then begin if ARequestInfo.Command = 'POST' then // post begin if (ARequestInfo.PostStream <> nil) and (ARequestInfo.PostStream.Size > 0) then begin end; end; if ARequestInfo.Command = 'GET' then begin // Memo1.Lines.Add(Httpdecode(ARequestInfo.QueryParams)); // 引用 Httpapp end; end; if Form1.CheckBox1.Checked = true then begin Form1.Memo1.Lines.Add('接收到访问类型为:' + ARequestInfo.Command + ' 访问模块为:' + recv_url + ' 访问时间为：' + DateTimeToStr(Now())); Form1.Memo1.Lines.Add('访问者IP：' + AContext.Connection.Socket.Binding.PeerIP); if ARequestInfo.Command = 'GET' then begin Memo1.Lines.Add('地址栏参数：' + Httpdecode(ARequestInfo.QueryParams)); end; end; //如果是微信模块 if (recv_url = '/Twx/Rwx') or (recv_url = '/Twx/Rwx/') then begin wx_info_in.url := recv_url; wx_info_in.AContext := AContext; wx_info_in.ARequestInfo := ARequestInfo; wx_info_in.AResponseInfo := AResponseInfo; wx_fun(wx_info_in); end else begin AResponseInfo.ContentType := 'text/HTML;charset=utf-8'; RespStr := '<html><body>只是一个练习界面，什么功能都没有。</body></html>'; AResponseInfo.ContentText := AnsiToUtf8(RespStr); end; except end; finally end; end; procedure TForm1.Timer1Timer(Sender: TObject); begin Edit3.Text := IntToStr(StrToInt(Edit3.Text) - 60); end; end.

三、编辑界面

四、说明

1、DCP是一套控件，与微信服务器验证的时候用的。

2、附赠一个单元

unit fun_change; interface uses Winapi.Windows, System.SysUtils, System.Classes, fun_wx_recv, Xml.xmldom, Xml.XMLIntf, Xml.XMLDoc, Xml.omnixmldom, System.DateUtils; function format_Json_show(indent: string; inputStr: string): string; function StreamToString(mStream: TStream): string; //拆分微信POST消息 function split_wx_mess(xml: string; var wx_mess_Recv: Twx_mess_Recv): Boolean; //初始化被动回复消息 function reset_wx_mess_send(wx_mess_Recv: Twx_mess_Recv; var wx_mess_send: Twx_mess_send): boolean; //获得时间戳 function Get_Stamp_Time(d: TDateTime): Int64; //生成返回的XML function get_wx_mess_xml(wx_mess_send: Twx_mess_send): string; implementation function Get_Stamp_Time(d: TDateTime): Int64; var dJavaStart: TDateTime; begin //java里的时间是从1970年1月1日0点到当前的间隔 dJavaStart := EncodeDateTime(1970, 1, 1, 0, 0, 0, 0); Result := MilliSecondsBetween(d, dJavaStart); end; function format_Json_show(indent: string; inputStr: string): string; var outStr, s: string; p, i: integer; c: char; level: integer; //缩进级别 quot: integer; //双引号标记 slant: integer; //反斜杠标记 colon: integer; //冒号 function getTab(level: integer): string; var tab: string; j: integer; begin getTab := ''; if level > 0 then begin for j := 1 to level do begin tab := tab + indent; end; end; result := tab; end; begin //去掉换行回车符 inputStr := stringReplace(inputStr, #13#10, '', [rfReplaceAll, rfIgnoreCase]); //去掉tab符 inputStr := stringReplace(inputStr, #9, '', [rfReplaceAll, rfIgnoreCase]); //支持 xxx={...} 格式的数据，保留 xxx= 内容。 p := pos('{', inputStr); if p > 0 then begin outStr := copy(inputStr, 1, p - 1); inputStr := copy(inputStr, p, length(inputStr)); end else begin result := inputStr; exit; end; //json格式化处理 //简易处理规则： //遇到反斜杠 "\"，输出，后面紧跟的字符直接输出，不做特殊处理 //遇到双引号 """，输出，等待匹配下一个双引号（除了反斜杠"\"后的双引号外),其间的字符直接输出 //遇到左花括号 "{" 缩进不变输出，回车，后续缩进等级+1 //遇到右花括号 "}" 回车，缩进-1, 输出，后续缩进等级-1 //遇到左方括号 "[" 缩进不变输出，回车，后续缩进等级+1 //遇到右方括号 "]" 回车，缩进-1, 输出，后续缩进等级-1 //遇到双引号外的逗号 "," 输出后回车 //遇到冒号 ":", 输出，加一个空格 //不符合以上规则的字符，除空格外，直接 输出 level := 0; quot := 0; //是否等待匹配双引号 colon := 0; for i := 1 to length(inputStr) do begin c := inputStr[i]; if c <> ' ' then s := c else s := ''; //过滤一般性空格 if (slant = 1) then begin //反斜杠之后的字符直接输出 slant := 0; end else if (quot = 1) and (c <> '"') and (c <> '\') then begin //双引号之后的字符直接输出 s := c; //双引号之间的空格也保留输出 end else begin case c of '\': begin slant := 1; end; '{': begin if colon <> 1 then s := getTab(level) + s; s := s + #13#10; level := level + 1; colon := 0; end; '}': begin s := #13#10 + getTab(level - 1) + s; level := level - 1; end; '[': begin if colon <> 1 then s := getTab(level) + s; s := s + #13#10; level := level + 1; colon := 0; end; ']': begin s := #13#10 + getTab(level - 1) + s; level := level - 1; end; '"': begin quot := 1 - quot; if (quot = 1) and (colon = 0) then s := getTab(level) + s; colon := 0; end; ',': begin s := s + #13#10; colon := 0; end; ':': begin s := s + ' '; colon := 1; end; else // end; end; outStr := outStr + s; end; result := outStr; end; function StreamToString(mStream: TStream): string; { 将内存流转换成字符串 } var I: Integer; begin Result := ''; if not Assigned(mStream) then Exit; SetLength(Result, mStream.Size); for I := 0 to Pred(mStream.Size) do try mStream.Position := I; mStream.Read(Result[Succ(I)], 1); except Result := ''; end; end; { StreamToString } function reset_wx_mess_send(wx_mess_Recv: Twx_mess_Recv; var wx_mess_send: Twx_mess_send): boolean; begin wx_mess_send.ToUserName := wx_mess_Recv.FromUserName; wx_mess_send.FromUserName := wx_mess_Recv.ToUserName; wx_mess_send.CreateTime := IntToStr(Get_Stamp_Time(now)); wx_mess_send.MsgType := 'text'; wx_mess_send.Content := '测试一下。' + chr(13) + chr(10) + '看看能不能收到'; end; function split_wx_mess(xml: string; var wx_mess_Recv: Twx_mess_Recv): Boolean; var Rootnode, node: IXmlNode; xml1: TXMLDocument; doc: IXMLDocument; begin xml1 := TXMLDocument.Create(nil); try xml1.DOMVendor := GetDOMVendor('Omni XML'); doc := xml1; doc.XML.Text := xml; doc.Active := true; Rootnode := doc.DocumentElement; node := Rootnode.ChildNodes.FindNode('ToUserName'); if node <> nil then wx_mess_Recv.ToUserName := node.Text; node := Rootnode.ChildNodes.FindNode('FromUserName'); if node <> nil then wx_mess_Recv.FromUserName := node.Text; node := Rootnode.ChildNodes.FindNode('CreateTime'); if node <> nil then wx_mess_Recv.CreateTime := node.Text; node := Rootnode.ChildNodes.FindNode('MsgType'); if node <> nil then wx_mess_Recv.MsgType := node.Text; node := Rootnode.ChildNodes.FindNode('Content'); if node <> nil then wx_mess_Recv.Content := node.Text; node := Rootnode.ChildNodes.FindNode('MediaId'); if node <> nil then wx_mess_Recv.MediaId := node.Text; node := Rootnode.ChildNodes.FindNode('PicUrl'); if node <> nil then wx_mess_Recv.PicUrl := node.Text; node := Rootnode.ChildNodes.FindNode('Format'); if node <> nil then wx_mess_Recv.Format := node.Text; node := Rootnode.ChildNodes.FindNode('ThumbMediaId'); if node <> nil then wx_mess_Recv.ThumbMediaId := node.Text; node := Rootnode.ChildNodes.FindNode('MsgId'); if node <> nil then wx_mess_Recv.MsgId := node.Text; node := Rootnode.ChildNodes.FindNode('Event'); if node <> nil then wx_mess_Recv.Event := node.Text; node := Rootnode.ChildNodes.FindNode('EventKey'); if node <> nil then wx_mess_Recv.EventKey := node.Text; node := Rootnode.ChildNodes.FindNode('Ticket'); if node <> nil then wx_mess_Recv.Ticket := node.Text; node := Rootnode.ChildNodes.FindNode('Latitude'); if node <> nil then wx_mess_Recv.Latitude := node.Text; node := Rootnode.ChildNodes.FindNode('Longitude'); if node <> nil then wx_mess_Recv.Longitude := node.Text; node := Rootnode.ChildNodes.FindNode('Precision'); if node <> nil then wx_mess_Recv.Precision := node.Text; node := Rootnode.ChildNodes.FindNode('Location_X'); if node <> nil then wx_mess_Recv.Location_X := node.Text; node := Rootnode.ChildNodes.FindNode('Location_Y'); if node <> nil then wx_mess_Recv.Location_Y := node.Text; node := Rootnode.ChildNodes.FindNode('Scale'); if node <> nil then wx_mess_Recv.Scale := node.Text; node := Rootnode.ChildNodes.FindNode('Label'); if node <> nil then wx_mess_Recv.Label_ := node.Text; finally // xml1.Active := false; //xml1.Free; end; Result := true; end; function CDATA(value: string): string; begin Result := '<![CDATA[' + value + ']]>'; end; function get_wx_mess_xml(wx_mess_send: Twx_mess_send): string; var xml1: TXmlDocument; doc: IXMLDocument; Rootnode, node, node1, node2: IXmlNode; xml: string; begin try try xml1 := TXMLDocument.Create(nil); xml1.DOMVendor := GetDOMVendor('Omni XML'); doc := xml1; doc.Active := true; doc.AddChild('xml'); Rootnode := doc.DocumentElement; node := Rootnode.AddChild('ToUserName'); node.Text := CDATA(wx_mess_send.ToUserName); node := Rootnode.AddChild('FromUserName'); node.Text := CDATA(wx_mess_send.FromUserName); node := Rootnode.AddChild('CreateTime'); node.Text := CDATA(wx_mess_send.CreateTime); node := Rootnode.AddChild('MsgType'); node.Text := CDATA(wx_mess_send.MsgType); if wx_mess_send.MsgType = 'text' then begin node := Rootnode.AddChild('Content'); node.Text := CDATA(wx_mess_send.Content); end; if wx_mess_send.MsgType = 'Image' then begin node := Rootnode.AddChild('Image'); node1 := node.AddChild('MediaId'); node1.Text := CDATA(wx_mess_send.Image_MediaId) end; xml := doc.XML.Text; xml := xml.Replace('&lt;', '<').Replace('&gt;', '>'); Result := xml; except Result := ''; end; finally // doc.Free; end; end; end.