Funkcja Tłumacz   strona główna:
A po co ten Excel ;-)
 
To już druga wersja tej funkcji. Google zmieniło nieco swoje narzędzia językowe więc i funkcję opierającą się o to narzedzie trzeba  
było odrobinę zmienić. :-)   
 
Function Tłumacz(strTekst As String, _  
                 zJęzyka As String, _  
                 Optional naJęzyk As String = "pl") As String  
    On Error GoTo Tłumacz_Error  
 
    Dim strURL As String, strText As String  
    Dim objIEBrowser As Object 'SHDocVw.InternetExplorer  
    Dim objHTMLDoc As Object 'MSHTML.HTMLDocument  
 
    Const READYSTATE_COMPLETE = 4  
     
    strText = VBA.Replace(strTekst, " ", "+")  
    strURL = "http://translate.google.pl/translate_t?hl=&ie=UTF-8&" & _  
             "text=" & strText & "&" & _  
             "sl=" & zJęzyka & "&" & _  
             "tl=" & naJęzyk & "#"  
     
    Set objIEBrowser = CreateObject("InternetExplorer.Application")  
    With objIEBrowser  
        .navigate strURL  
        '.Visible = True  
        Do  
            DoEvents  
        Loop Until .readyState = READYSTATE_COMPLETE  
        Set objHTMLDoc = .Document  
         
        'wersja 2.0 2011-08-01  
        Dim colTags As Object  
        Set colTags = objHTMLDoc.getElementsByTagName("span")  
        Tłumacz = colTags("result_box").outerText  
         
        ' pierwotna wersja  
        'Dim colForms As Object  
        'Set colForms = objHTMLDoc.forms(1)  
        'Tłumacz = colForms("gtrans").Value  
 
    End With  
     
Tłumacz_Exit:  
    On Error Resume Next  
     
    If Not objIEBrowser Is Nothing Then  
        objIEBrowser.Quit  
        Set objIEBrowser = Nothing  
    End If  
     
    'Set colForms = Nothing  
    Set objHTMLDoc = Nothing  
    Set colTags = Nothing  
 
Exit Function  
 
Tłumacz_Error:  
    MsgBox "Byk nr - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - Tłu"  
Resume Tłumacz_Exit  
 
End Function  
 
Sub test()  
    'en angielski   ar arabski      be białoruski   bg bułgarski  
    'zh-CN chiński  hr chorwacki    cs czeski       da duński  
    'et estoński    fi fiński       fr francuski    el grecki  
    'iw hebrajski   es hiszpański   nl holenderski  ja japoński  
    'ko koreański   lt litewski     lv łotewski     de niemiecki  
    'no norweski    pl polski       pt portugalski  ru rosyjski  
    'sk słowacki    ( inne )  
     
    Debug.Print Tłumacz("create new workbook", "en", "fr")  
    Debug.Print Tłumacz("create new workbook", "en")  
End Sub  
 
 
     Procedura test zwraca wynik do okna Immediate (VBE/Ctrl+G) jednak funkcję można śmiało używać jako funkcję arkuszową.  
Składnia:  
=Tłumacz("text in English";"en";"de")  
 
Przydałaby się też pełna lista języków jakie można wykorzystać… zamiast wypisywać jakie to …  
 
Function JezykiGoogleLanguages() As VBA.Collection  
    On Error GoTo JezykiGoogleLanguages_Error  
 
    Dim strURL As String, strText As String  
    Dim objIEBrowser As Object 'SHDocVw.InternetExplorer  
    Dim objHTMLDoc As Object 'MSHTML.HTMLDocument  
    Dim colJęzyki As New VBA.Collection  
      
    Const READYSTATE_COMPLETE = 4  
      
    Set objIEBrowser = CreateObject("InternetExplorer.Application")  
    With objIEBrowser  
        .navigate "http://www.google.pl/language_tools"  
        '.Visible = True  
        Do  
            DoEvents  
        Loop Until .readyState = READYSTATE_COMPLETE  
        Set objHTMLDoc = .Document  
          
        Dim colTags As Object, objTag As Object  
        Set colTags = objHTMLDoc.getElementsByTagName("option")  
          
        On Error Resume Next  
        For Each objTag In colTags  
            With objTag  
                colJęzyki.Add .outerText & " (" & .Value & ")", .Value  
            End With  
        Next  
        On Error GoTo 0  
          
    End With  
    Set JezykiGoogleLanguages = colJęzyki  
      
JezykiGoogleLanguages_Exit:  
    On Error Resume Next  
      
    If Not objIEBrowser Is Nothing Then  
        objIEBrowser.Quit  
        Set objIEBrowser = Nothing  
    End If  
      
    'Set colForms = Nothing  
    Set objHTMLDoc = Nothing  
    Set colTags = Nothing  
 
Exit Function  
 
JezykiGoogleLanguages_Error:  
    MsgBox "Byk nr - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - JezykiGoogleLanguages"  
Resume JezykiGoogleLanguages_Exit  
 
End Function  
 
 
Sub Start()  
    Dim colJezyki As New VBA.Collection  
    Dim iCol As Integer  
      
    Set colJezyki = JezykiGoogleLanguages()  
    For iCol = 1 To colJezyki.Count  
        Debug.Print colJezyki.Item(iCol)  
    Next  
    Set colJezyki = Nothing  
End Sub  
 
i jest lista :-D