晚上闲着没事，一个朋友联系，让帮忙写一个微信公众号利用asp生成带参数的二维码，别人扫了后如果已经关注过该公众号的，则直接进入公众号里，如果没关注则提示关注，关注后自动把该微信用户资料获取到并且保存入库，然后回复他的上级是谁，我觉得有可能对别人有用，就发到这了，闲话不说，上代码，对了，生成的二维码可以是临时二维也可以是永久的二维码：
<% ‘********************************************** ‘注意事项 ‘ASP文件需要以UTF-8的格式保存,否则乱码. ‘作者wx :18611436777 ‘********************************************** dim Signature ‘微信加密签名 dim Timestamp ‘时间戳 dim Nonce ‘随机数 dim Echostr ‘随机字符串 dim Token ‘与微信后台设置的token一致 dim encrypt_type ‘加密类型 dim msg_signature ‘签名 Token="7Gk0Ry2Wn"‘ Signature = request.QueryString("signature") Nonce = request.QueryString("nonce") Timestamp = request.QueryString("timestamp") Echostr = request.QueryString("echostr") encrypt_type = request.QueryString("encrypt_type") msg_signature = request.QueryString("msg_signature") ‘验证微信接口 If EchoStr<>"" then ‘下面进行Token,TimesTamp,Nonce三个参数的字典排序 dim str,i dim Myarray:Myarray=Sort(Array(Token,TimesTamp,Nonce)) For i=0 To Ubound(Myarray) str=str&Myarray(i) Next if Lcase(SignaTure)=Lcase(SHA1(str,"Hex")) then Response.Write EchoStr ‘验证成功，返回正确EchoStr给微信，接通接口API Response.End() end if End if ‘获取微信主动发送过来的内容 Set xmldom = Server.CreateObject("MSXML2.DOMDocument") xmldom.load request xml = xmldom.documentElement.xml ‘call CreateTextFile(request.QueryString&xml,"a.txt") If encrypt_type = "aes" Then res = ToAes(xml,0) xmldom.loadxml res End If ToUserName=xmldom.getelementsbytagname("ToUserName").item(0).text ‘接收者微信账号。即我们的公众平台账号。 FromUserName=xmldom.getelementsbytagname("FromUserName").item(0).text ‘发送者微信账号Openid CreateTime=xmldom.getelementsbytagname("CreateTime").item(0).text MsgType=xmldom.getelementsbytagname("MsgType").item(0).text if (MsgType="event") then strEventType=xmldom.getelementsbytagname("Event").item(0).text ‘微信事件 if strEventType="subscribe" then ‘表示订阅微信公众平台 EventKey=xmldom.getelementsbytagname("EventKey").item(0).text Content="感谢关注" if EventKey<>"" then EventKey=replace(EventKey,"qrscene_","") Content = "你的上线ID:"&EventKey Else EventKey= 0 Content = "感谢关注" end if Call Login(EventKey,FromUserName) Call Return_Text(Content) ElseIf strEventType="unsubscribe" Then‘取消关注 Content="取消关注" Call Return_Text(Content) ElseIf strEventType="CLICK" Then‘点击菜单获取关键字，获取 EventKey=xmldom.getelementsbytagname("EventKey").item(0).text Content=EventKey Call Return_Text(Content) ElseIf strEventType="VIEW" Then‘点击菜单获取关键字，跳转到链接 EventKey=xmldom.getelementsbytagname("EventKey").item(0).text Content=EventKey Call Return_Text(Content) ElseIf strEventType="SCAN" Then ‘扫描二维码 EventKey=xmldom.getelementsbytagname("EventKey").item(0).text Content= "欢迎再次光临" Call Return_Text(Content) ElseIf strEventType="scancode_push" or strEventType="scancode_waitmsg" Then ‘点击菜单，调用扫码推事件的事件推送 EventKey=xmldom.getelementsbytagname("EventKey").item(0).text ScanResult=xmldom.getelementsbytagname("ScanResult").item(0).text Content=ScanResult Call Return_Text(Content) ElseIf strEventType="pic_sysphoto" or strEventType="pic_photo_or_album" or strEventType="pic_weixin" Then ‘点击菜单，调用系统拍照发图 EventKey=xmldom.getelementsbytagname("EventKey").item(0).text Counts=xmldom.getelementsbytagname("Count").item(0).text Content="拍照发图，接收【"&Counts&"】张图片" Call Return_Text(Content) ElseIf strEventType="location_select" Then ‘点击菜单，调用位置发送 EventKey=xmldom.getelementsbytagname("EventKey").item(0).text Location_X=xmldom.getelementsbytagname("Location_X").item(0).text Location_Y=xmldom.getelementsbytagname("Location_Y").item(0).text Scale=xmldom.getelementsbytagname("Scale").item(0).text Label=xmldom.getelementsbytagname("Label").item(0).text Content="发送位置"&EventKey Call Return_Text(Content) ElseIf strEventType="LOCATION" Then‘获取用户地理位置，当用户打开对话框时，自动获取微信用户的实时地址。本功能需要配合服务号的LEB接口。 Latitude=xmldom.getelementsbytagname("Latitude").item(0).text Longitude=xmldom.getelementsbytagname("Longitude").item(0).text Precision=xmldom.getelementsbytagname("Precision").item(0).text ‘记录用户LEB信息 end if else MsgId=xmldom.getelementsbytagname("MsgId").item(0).text End If If MsgType="text" then‘接收文本信息 Content=xmldom.getelementsbytagname("Content").item(0).text Call Return_Text(Content) elseif MsgType="image" then‘接收图片信息 MediaId=xmldom.getelementsbytagname("MediaId").item(0).text PicUrl=xmldom.getelementsbytagname("PicUrl").item(0).text Content=PicUrl Call Return_Text(Content) elseif MsgType="voice" then‘"接收语音信息 MediaId=xmldom.getelementsbytagname("MediaId").item(0).text Format=xmldom.getelementsbytagname("Format").item(0).text Content=MediaId Call Return_Text(Content) elseif MsgType="video" then‘接收视频信息 MediaId=xmldom.getelementsbytagname("MediaId").item(0).text ThumbMediaId=xmldom.getelementsbytagname("ThumbMediaId").item(0).text Content=MediaId Call Return_Text(Content) elseif MsgType="location" then‘接收位置信息 Location_X=xmldom.getelementsbytagname("Location_X").item(0).text Location_Y=xmldom.getelementsbytagname("Location_Y").item(0).text Scale=xmldom.getelementsbytagname("Scale").item(0).text Label=xmldom.getelementsbytagname("Label").item(0).text Content="地理位置"&Location_X&","&Location_Y&"你发的是地址信息:"&Label Call Return_Text(Content) elseif MsgType="link" then‘接收链接信息 Title=xmldom.getelementsbytagname("Title").item(0).text Descriptions=xmldom.getelementsbytagname("Description").item(0).text Url=xmldom.getelementsbytagname("Url").item(0).text Content=Url Call Return_Text(Content) end if set xmldom=Nothing ‘多图文消息 Function Return_News(Articles) ArticleCount = Ubound(Articles)+1 str = "<xml>"&_ "<ToUserName><![CDATA["&FromUserName&"]]></ToUserName>"&_ "<FromUserName><![CDATA["&ToUserName&"]]></FromUserName>"&_ "<CreateTime>"&DateDiff("s","1970-01-01 08:00:00",Now())&"</CreateTime>"&_ "<MsgType><![CDATA[news]]></MsgType>"&_ "<ArticleCount>"&ArticleCount&"</ArticleCount>"&_ "<Articles>" For i = 0 To ArticleCount-1 str = str & "<item>"&_ "<Title><![CDATA["&Articles(i)(0)&"]]></Title>"&_ "<Description><![CDATA["&Articles(i)(1)&"]]></Description>"&_ "<PicUrl><![CDATA["&Articles(i)(2)&"]]></PicUrl>"&_ "<Url><![CDATA["&Articles(i)(3)&"]]></Url>"&_ "</item>" Next str = str & "</Articles>"&_ "</xml>" Response.Write str End Function ‘文本消息 Function Return_Text(Content) str = "<xml>"&_ "<ToUserName><![CDATA["&FromUserName&"]]></ToUserName>"&_ "<FromUserName><![CDATA["&ToUserName&"]]></FromUserName>"&_ "<CreateTime>"&DateDiff("s","1970-01-01 08:00:00",Now())&"</CreateTime>"&_ "<MsgType><![CDATA[text]]></MsgType>"&_ "<Content><![CDATA["&Content&"]]></Content>"&_ "</xml>" Response.Write str End Function ‘字典排序 Function Sort(ary) Dim KeepChecking,I,FirstValue,SecondValue KeepChecking = TRUE Do Until KeepChecking = FALSE KeepChecking = FALSE For I = 0 to UBound(ary) If I = UBound(ary) Then Exit For If ary(I) > ary(I+1) Then FirstValue = ary(I) SecondValue = ary(I+1) ary(I) = SecondValue ary(I+1) = FirstValue KeepChecking = TRUE End If Next Loop Sort = ary End Function Function PostHTTPPage(url,data) dim Http set Http=server.createobject("MSXML2.SERVERXMLHTTP.3.0") Http.open "POST",url,false Http.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded" Http.send(data) if Http.readystate<>4 then exit function End if PostHTTPPage=Http.responseText set http=nothing if err.number<>0 then err.Clear End Function Function SHA1(ByVal Str,ByVal Types) Dim TAsc,Enc,Bytes,objXML,objXMLNode,Outstr ‘Borrow some objects from .NET (supported from 1.1 onwards) Set TAsc = Server.CreateObject("System.Text.UTF8Encoding") Set Enc = Server.CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider") ‘Convert the string to a byte array and hash it Bytes = TAsc.GetBytes_4(Str) Bytes = Enc.ComputeHash_2((Bytes)) ‘Convert the byte array to a hex or bsae64 string Outstr = "" If Types = "Base64" Then Set objXML = Server.CreateObject("Msxml2.DOMDocument") Set objXMLNode = objXML.createElement("a") objXMLNode.DataType = "bin.base64" objXMLNode.NodeTypedValue = Bytes Outstr = Replace(objXMLNode.Text,Chr(10),"") Set objXML = Nothing Set objXMLNode = Nothing ElseIf Types = "Hex" Then Set objXML = Server.CreateObject("Msxml2.DOMDocument") Set objXMLNode = objXML.createElement("a") objXMLNode.DataType = "bin.hex" objXMLNode.NodeTypedValue = Bytes Outstr = Replace(objXMLNode.Text,Chr(10),"") Set objXML = Nothing Set objXMLNode = Nothing End If SHA1 = Outstr Set Enc = Nothing Set TAsc = Nothing End Function Sub Login(genKey,openid) Set Rs = Conn.ExeCute("Select * From [Wx_user] Where openid=‘"&openid&"‘") If Rs.Eof Then UserInfo = Wx.Get_UserInfo(openid) nickname = UserInfo(0) sex = UserInfo(1) icon = UserInfo(2) province = UserInfo(4) city = UserInfo(5) Conn.ExeCute("Insert Into [Wx_user]([username],[password],headurl,sex,province,city,openid,genkey,pid) values(‘"&nickname&"‘,‘"&openid&"‘,‘"&icon&"‘,"&sex&",‘"&province&"‘,‘"&city&"‘,‘"&openid&"‘,‘"&genkey&"‘,"&genkey&")") End If End Sub %>