Código
'------------------------------------------------------- ' *Module : mTranslator ' *Author : *PsYkE1* ' *Mail : vbpsyke1@mixmail.com ' *Date : 27/7/10 ' *Purpose : Translate any text using Google Translator ' *Web : http://foro.rthacker.net '------------------------------------------------------- Option Explicit Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer Public Const IF_NO_CACHE_WRITE = &H4000000 Public Function Get_Html_Code(sURL As String) As String Dim sBuffer As String * 1000 Dim lInternet As Long Dim lFile As Long Dim lRead As Long lInternet = InternetOpen(0, 1, vbNullString, vbNullString, 0) If lInternet <> 0 Then lFile = InternetOpenUrl(lInternet, sURL, vbNullString, 0, IF_NO_CACHE_WRITE, 0) If lFile <> 0 Then Do Call InternetReadFile(lFile, sBuffer, 1000, lRead): DoEvents Get_Html_Code = Get_Html_Code & Left$(sBuffer, lRead) Loop While lRead <> 0 End If Call InternetCloseHandle(lInternet) End If End Function Public Function Simplified_Language(ByVal sLenguage As String) As String sLenguage = LCase$(sLenguage) Select Case sLenguage Case "albanian": Simplified_Language = "sq" Case "german": Simplified_Language = "de" Case "armenian": Simplified_Language = "hy" Case "bulgarsk": Simplified_Language = "bg" Case "greek": Simplified_Language = "el" Case "dutch": Simplified_Language = "nl" Case "polish": Simplified_Language = "pl" Case "portuguese": Simplified_Language = "pt" Case "spanish": Simplified_Language = "es" Case "swedish": Simplified_Language = "sv" Case "czech": Simplified_Language = "cs" Case "german": Simplified_Language = "de" Case Else Simplified_Language = Left$(sLenguage, 2) End Select End Function Public Function Text_Between_Words(ByVal sTextToAnalyze As String, ByVal sStartWord As String, ByVal sEndWord As String) As String Dim lPosition1 As Double Dim lPosition2 As Double Dim lStart As Double lPosition1 = InStr(sTextToAnalyze, sStartWord) If lPosition1 <> 0 Then lStart = lPosition1 + Len(sStartWord) lPosition2 = InStr(lStart, sTextToAnalyze, sEndWord) Else Exit Function End If If lPosition2 <> 0 Then Text_Between_Words = Mid$(sTextToAnalyze, lStart, lPosition2 - lStart) End Function Public Function Translate_Text(ByVal sTextToTranslate As String, ByVal sActualLenguage As String, ByVal sFutureLenguage As String) As String Const sGoogleTransUrl As String = "http://translate.google.com/?js=y&prev=_t&hl=es&ie=UTF-8&layout=1&eotf=1&text=" '# Delimiters Const START_TRANSLATED_TEXT As String = "onmouseout=""this.style.backgroundColor='#fff'"">" Const END_TRANSLATED_TEXT As String = "<br>" Dim sGoogleHtml As String If sActualLenguage <> sFutureLenguage Then sTextToTranslate = Replace$(sTextToTranslate, Chr$(32), "%20") sActualLenguage = Simplified_Language(sActualLenguage) sFutureLenguage = Simplified_Language(sFutureLenguage) sGoogleHtml = Get_Html_Code(sGoogleTransUrl & sTextToTranslate & "%0D%0A%0D%0A&file=&sl=" & sActualLenguage & "&tl=" & sFutureLenguage & "#submit") Translate_Text = RTrim$(Text_Between_Words(sGoogleHtml, START_TRANSLATED_TEXT, END_TRANSLATED_TEXT)) Else Translate_Text = sTextToTranslate End If End Function
An example:
Código
Debug.Print Translate_Text("Hoy estoy un poco cansado, pero creo que este proyecto sera grande.", "spanish", "english")
It returns:
Citar
Today I am a little tired, but I think this project will be great.
DoEvents¡!