Archive for the ‘コピー&ペースト用’ Category

Google Translate API(v1)で翻訳するマクロ

2011/03/14

参照Webページ:
http://code.google.com/intl/ja/apis/language/translate/overview.html
http://code.google.com/intl/ja/apis/language/translate/v1/getting_started.html#translatableLanguages

Option Explicit

Public Sub Sample()
  With CreateObject("WScript.Shell")
    .Popup TranslateText("This is a pen.") '結果を日本語で表示
    .Popup TranslateText("This is a pen.", "zh") '結果を中国語で表示
    .Popup TranslateText("これはペンです。", "ar") '結果をアラビア語で表示
  End With
End Sub

Public Function TranslateText(ByVal target As String, Optional ByVal destLang As String = "ja") As String
'Google Translate API(v1)で翻訳(翻訳元言語:自動認識 , 翻訳先言語:destLangで指定(標準では日本語(ja)))
  Dim url As String
  Dim js As String
  Dim ret As String
  
  destLang = StrConv(destLang, vbNarrow)
  destLang = LCase$(destLang)
  If ChkLang(destLang) = False Then
    MsgBox "翻訳先言語が対応していません。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
    Exit Function
  End If
  target = EncodeURL(target)
  
  js = "" '初期化
  url = "https://ajax.googleapis.com/ajax/services/language/translate?v=1.0&q=" & target & "&langpair=%7C" & destLang
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .Send
    js = .responseText
  End With
  On Error GoTo 0
  If Len(js) < 1 Then Exit Function
  
  ret = GetTranslatedText(js)
  If Len(ret) < 1 Then ret = "Error"
  
  TranslateText = ret
End Function

Private Function EncodeURL(ByVal sWord As String) As String
'URLエンコード
  Dim d As Object
  Dim elm As Object
  
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.body.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & sWord & "');", "JScript"
  EncodeURL = elm.innerText
End Function

Private Function GetTranslatedText(ByVal js As String) As String
'JSONデータから訳語取得
  Dim d As Object
  Dim elm As Object
    
  js = "(" & js & ")"
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.body.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText=eval(" & js & ").responseData.translatedText;"
  
  GetTranslatedText = elm.innerText
End Function

Private Function ChkLang(ByVal lng As String) As Boolean
'対応言語チェック
  Dim LngList(55) As String
  Dim ret As Boolean
  Dim i As Long
  
  LngList(0) = "af" 'AFRIKAANS
  LngList(1) = "ar" 'ARABIC
  LngList(2) = "be" 'BELARUSIAN
  LngList(3) = "bg" 'BULGARIAN
  LngList(4) = "ca" 'CATALAN
  LngList(5) = "cs" 'CZECH
  LngList(6) = "cy" 'WELSH
  LngList(7) = "da" 'DANISH
  LngList(8) = "de" 'GERMAN
  LngList(9) = "el" 'GREEK
  LngList(10) = "en" 'ENGLISH
  LngList(11) = "es" 'SPANISH
  LngList(12) = "et" 'ESTONIAN
  LngList(13) = "fa" 'PERSIAN
  LngList(14) = "fi" 'FINNISH
  LngList(15) = "fr" 'FRENCH
  LngList(16) = "ga" 'IRISH
  LngList(17) = "gl" 'GALICIAN
  LngList(18) = "hi" 'HINDI
  LngList(19) = "hr" 'CROATIAN
  LngList(20) = "ht" 'HAITIAN_CREOLE
  LngList(21) = "hu" 'HUNGARIAN
  LngList(22) = "id" 'INDONESIAN
  LngList(23) = "is" 'ICELANDIC
  LngList(24) = "it" 'ITALIAN
  LngList(25) = "iw" 'HEBREW
  LngList(26) = "ja" 'JAPANESE
  LngList(27) = "ko" 'KOREAN
  LngList(28) = "lt" 'LITHUANIAN
  LngList(29) = "lv" 'LATVIAN
  LngList(30) = "mk" 'MACEDONIAN
  LngList(31) = "ms" 'MALAY
  LngList(32) = "mt" 'MALTESE
  LngList(33) = "nl" 'DUTCH
  LngList(34) = "no" 'NORWEGIAN
  LngList(35) = "pl" 'POLISH
  LngList(36) = "pt" 'PORTUGUESE
  LngList(37) = "pt-pt" 'PORTUGUESE_PORTUGAL
  LngList(38) = "ro" 'ROMANIAN
  LngList(39) = "ru" 'RUSSIAN
  LngList(40) = "sk" 'SLOVAK
  LngList(41) = "sl" 'SLOVENIAN
  LngList(42) = "sq" 'ALBANIAN
  LngList(43) = "sr" 'SERBIAN
  LngList(44) = "sv" 'SWEDISH
  LngList(45) = "sw" 'SWAHILI
  LngList(46) = "th" 'THAI
  LngList(47) = "tl" 'TAGALOG
  LngList(48) = "tl" 'FILIPINO
  LngList(49) = "tr" 'TURKISH
  LngList(50) = "uk" 'UKRAINIAN
  LngList(51) = "vi" 'VIETNAMESE
  LngList(52) = "yi" 'YIDDISH
  LngList(53) = "zh" 'CHINESE
  LngList(54) = "zh-cn" 'CHINESE_SIMPLIFIED
  LngList(55) = "zh-tw" 'CHINESE_TRADITIONAL
  
  ret = False ' 初期化
  For i = LBound(LngList) To UBound(LngList)
    If lng = LngList(i) Then
      ret = True
      Exit For
    End If
  Next
  
  ChkLang = ret
End Function
広告

ExportAsFixedFormatでPDFを作成する

2011/03/07

2年近く前に書いたコードを掲載してみます。

Sub Sample()
  Const FilePath As String = "M:\Test.pdf"
   
  'ブックごとPDF化
  ThisWorkbook.ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
  'シートごとPDF化
  'ActiveSheet.ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
  '選択した範囲のみPDF化
  'Selection.ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
  '範囲が飛び飛びだった場合:連続したセル範囲/1ページ のPDF作成
  'ActiveSheet.Range("A1,B3,C5").ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
End Sub

「ExportAsFixedFormat Method [Excel 2007 Developer Reference]」
http://msdn.microsoft.com/en-us/library/bb238907.aspx

動的にJavaScriptを実行する

2011/03/07

JavaScriptを動的に書き出す」参照。

Public Sub Sample()
  Dim d As Object
  Dim oDiv As Object
  
  Set d = CreateObject("htmlfile")
  Set oDiv = d.createElement("div")
  oDiv.innerHTML = "&nbsp;<script defer>alert(document.parentWindow.clientInformation.userAgent);</script>"
  d.body.appendChild oDiv
End Sub

拡張子判別

2011/02/26

割とよく使うのでコピー&ペースト用にメモ。

Public Sub Sample()
  Dim f As Object
  
  With CreateObject("Scripting.FileSystemObject")
    For Each f In .GetFolder("C:\Windows").Files
      Select Case LCase$(.GetExtensionName(f))
        Case "exe", "ini"
         Debug.Print f.Name, f.Path
      End Select
    Next
  End With
End Sub