Classe para encurtar URL

[hargon 64]

O código foi encontrado na Web e possui as devidas referências.

 

'************************************************************************
'* @TITLE: 					Shorten URL Class
'* @PACKAGE:				Simple Classic ASP Twitter API
'* @AUTHOR:					Ariel G. Saputra <webmaster@asp.web.id>
'* @DESCRIPTION:			Class to create short redirection url
'* @SCOPE:					TinyURL,is.gd,bit.ly
'* @DATE:					May 15 2009
'* @TODO:					Adding more free url redirection providers
'************************************************************************
class UrlBawak

	private m_StrProvider,m_StrApiUrl,m_StrUserName,m_StrApiKey

	public property let aspSetProvider(strProvider)
		m_StrProvider = Lcase(strProvider)
		select case m_StrProvider
			case "bitly"
				m_StrApiUrl = "http://api.bit.ly/shorten?version=2.0.1&format=xml&longUrl=[:URL:]&login=[:LOGIN:]&apiKey=[:API:]"
			case "isgd"
				m_StrApiUrl = "http://is.gd/api.php?longurl=[:URL:]"
			case else
				m_StrApiUrl = "http://tinyurl.com/api-create.php?url=[:URL:]"
		end select
	end property

	public property let aspSetUser(strUser)
		m_StrUserName = strUser
	end property

	public property let aspSetApi(strApi)
		m_StrApiKey = strApi
	end property

	sub class_initialize()
		me.aspSetProvider = "tinyurl"
		m_StrUserName = m_StrApiKey = ""
	end sub

	sub class_terminate()
	end sub

	private function aspGrabUrl(strUrl)
		select case m_StrProvider
			case "bitly"
				Dim oXmlDom,strGrabUrl
				set oXmlDom = Server.CreateObject("Microsoft.XMLDOM")
				oXmlDom.async = false
				oXmlDom.setProperty "SelectionLanguage", "XPath"
				oXmlDom.loadxml(strUrl)
				strGrabUrl = oXmlDom.selectSingleNode("/bitly/results/nodeKeyVal/shortUrl").Text
				Set oXmlDom = Nothing
				aspGrabUrl = strGrabUrl
			case else
				aspGrabUrl = strUrl
		end select
	end function

	public function aspShortUrlExec(strUrl)
		if Len(m_StrApiUrl) > 0 then
			Dim oXml,strRealUrl,strShortUrl
			strRealUrl = Replace(m_StrApiUrl, "[:URL:]", strUrl, 1, -1, 1)
			strRealUrl = Replace(strRealUrl, "[:LOGIN:]", m_StrUserName, 1, -1, 1)
			strRealUrl = Replace(strRealUrl, "[:API:]", m_StrApiKey, 1, -1, 1)
			set oXml = Server.CreateObject("Msxml2.ServerXMLHTTP.3.0")
			oXml.Open "GET", strRealUrl, false
			oXml.Send null
			strShortUrl = oXml.responseText
			Set oXml = nothing
			aspShortUrlExec = aspGrabUrl(strShortUrl)
		else
			aspShortUrlExec = false
		end if
	end function

end class

Exemplo de uso:

Dim obj,tinyUrl,isGdUrl,bitlyUrl
Set obj = new UrlBawak

	' utilizando tinyUrl
	tinyUrl = obj.aspShortUrlExec("http://asp.web.id/update-twitter-status-with-classic-asp-vbscript.html")

	' utilizando is.gd
	obj.aspSetProvider = "isgd"
	isGdUrl = obj.aspShortUrlExec("http://asp.web.id/update-twitter-status-with-classic-asp-vbscript.html")

	' utilizando bit.ly
	obj.aspSetProvider = "bitly"
	obj.aspSetUser = "username"
	obj.aspSetApi = "API_KEY"
	bitlyUrl = obj.aspShortUrlExec("http://asp.web.id/create-tinyurl-with-classic-asp-vbscript.html")

	Response.Write(tinyUrl&"<hr />"&isGdUrl&"<hr />"&bitlyUrl)
Set obj = nothing

 

Fonte

[brcontainer 16]

Nossa muito bom =)

ainda não testei mas vou testar hoje em casa

 

Obrigado por compartilhar aqui no forum