• はてなアカウントでログイン
• 無料ユーザー登録

ベストアンサー

• oil9992012/02/18 22:07:56

  満足700pt

  コメントいただいた、thump，merelyについても発音・意味を取得できるように修正しました。
  
  以下のマクロをお試しください。
  簡単なエラー処理も加えてあります。

  Option Explicit
  
  Sub getALC()
      Dim url As String, word As String, html As String
      Dim http As Object
      Dim arr() As String, sense As String, pronun As String
      Dim i As Long
  
      word = Sheet1.Range("A2:A2").Value
      url = "http://eow.alc.co.jp/search?q=" & word
      Set http = CreateObject("MSXML2.XMLHTTP")
      http.Open "GET", url, False
      http.Send
      html = http.responseText
      arr = Split(html, vbCrLf)
      i = toSense(word, arr)
      If (i > 0) Then
          pronun = getPronun(arr(i))
          If (pronun = "") Then pronun = "★発音が見当たりません"
          sense = getSense(arr(i))
          If (sense = "") Then sense = "★意味が見当たりません"
      Else
          pronun = "★発音が見当たりません"
          sense = "★意味が見当たりません"
      End If
      Sheet1.Range("B2").Value = pronun
      Sheet1.Range("C2").Value = sense
  End Sub
  
  '意味が記述されている行番号を取り出す
  Function toSense(word As String, arr() As String) As Long
      Dim i As Integer, n As Integer
      Dim re As Object
      Dim flag As Boolean
      Set re = CreateObject("VBScript.RegExp")
     
      n = UBound(arr)
      '探索
      With re
          .Pattern = "<font class='searchwordfont' color='#BF0000'>" & word & "</font>"
          .IgnoreCase = True
          .Global = True
          flag = False
          i = 0
          While (i <= n And flag = False)
              If .test(arr(i)) Then flag = True
              i = i + 1
          Wend
      End With
      If (flag = True) Then
          toSense = i
          With re
              .Pattern = "<span class=""wordclass"">"
              .IgnoreCase = True
              .Global = True
              flag = False
              If .test(arr(toSense - 1)) Then toSense = toSense - 1
          End With
      Else
          toSense = 0
      End If
      Set re = Nothing
  
  End Function
  
  '意味のHTML文をプレーンテキストに加工
  Function getSense(sour As String) As String
      Dim re As Object
      Dim remat
      
      getSense = ""
      Set re = CreateObject("VBScript.RegExp")
      '意味部分の抽出
      With re
          .Pattern = "<span class=""wordclass"">(.+)(<span class=""label"">【レベル】).+"
          .IgnoreCase = True
          .Global = True
          Set remat = .Execute(sour)
          If remat.Count > 0 Then
              getSense = remat(0).submatches(0)
          End If
      End With
      'プレーンテキストに変換
      With re
          .Pattern = "</li></ol>|<ol>|</li>|</ol>"
          .IgnoreCase = True
          .Global = True
          getSense = .Replace(getSense, vbCrLf)
      End With
      With re
          .Pattern = "<[0-9a-z/\=""' #]+>"
          .IgnoreCase = True
          .Global = True
          getSense = .Replace(getSense, "")
      End With
      Set re = Nothing
  End Function
  
  '発音のHTML文をプレーンテキストに加工
  Function getPronun(sour As String) As String
      Dim re As Object
      Dim remat
     
      getPronun = ""
      Set re = CreateObject("VBScript.RegExp")
      '発音部分の抽出
      With re
          .Pattern = "<span class=""pron"">([^、]+)、</span>"
          .IgnoreCase = True
          .Global = True
          Set remat = .Execute(sour)
          If remat.Count > 0 Then
              getPronun = remat(0).submatches(0)
          End If
      End With
      'プレーンテキストに変換
      With re
          .Pattern = "<[0-9a-z/\=""' #]+>"
          .IgnoreCase = True
          .Global = True
          getPronun = .Replace(getPronun, "")
      End With
      
      Set re = Nothing
  End Function
  

  スター

  • 

    3件のコメントを見る

  • tetlis 2012/02/19 12:46:38

    素敵な回答ありがとうございます。
    ところで、
    
    「thump」だと、発音が「★発音が見当たりません」で意味が空欄。
    
    「merely」を入れると意味は正しいのですが、発音が「mi'ərli」
    
    となってしまうのですが、どうしたら解決できますでしょうか？

    スター

  • oil999 2012/02/19 14:34:14

    コメントいただいた、thump，merelyについても発音・意味を取得できるように修正しました。
    お試しください。

    スター

  • tetlis 2012/02/19 15:24:31

    出来ました！
    他にも応用がききそうです。ありがとうございました。

    スター

その他の回答

• うぃんど2012/02/18 21:12:12

  満足200pt

  XMLに展開しようかとも思いましたが、
  必要なのは極一部分なのでTEXTのままで処理させてみました

  text1 = http1.responseText
  
  ' 大雑把な抜き出し
  ps = InStr(text1, "<span class=""wordclass"">")
  pe = InStr(ps, text1, "</div>")
  text2 = Mid(text1, ps, pe - ps)
  
  ' タグ削除と整形
  text2 = Replace(text2, "<span class=""wordclass"">", "")
  text2 = Replace(text2, "</span>", "")
  text2 = Replace(text2, "</li></ol>", vbLf)
  text2 = Replace(text2, "<ol>", "")
  text2 = Replace(text2, "</ol>", vbLf)
  text2 = Replace(text2, "<li>", "")
  text2 = Replace(text2, "</li>", vbLf)
  text2 = Replace(text2, "<span class=""label"">", vbLf)
  text2 = Replace(text2, "<span class=""pron"">", "")
  text2 = Replace(text2, "◆" & vbLf, "◆")
  
  ' text2の確認用
  ' Debug.Print text2
  
  ' セルへの代入
  Sheet1.Range("B2").Value = Split((Split(text2, "【発音】")(1)), "、")(0)
  Sheet1.Range("C2").Value = Split(text2, vbLf & vbLf)(0)
  

  以下の変数宣言も追加

  Dim ps, pe As Long, text2 As String
  

  スター

  • 

    1件のコメントを見る

  • tetlis 2012/02/19 15:25:25

    すぐにお返事いただきありがとうございました。

    スター

きゃづみぃ2012/02/18 21:28:46

満足400pt

最初のG2の値を取得するのが 何なのかは よくわからないのですが
ある程度の単語に応対するように作ってみました。

単語によって使われてるタグが違うことがありますので
そのタグを取り除くために

    d = Replace(d, "<ol>", "")

というようなことを やっています。

残る場合は、これがある箇所に それを追加してください。



Sub getALC()
'Dim your variables
Dim url1 As String
Dim date1 As String
Dim http1 As Object
Dim start1 As Long
Dim length1 As Long

'Store the value in cell G2 earlier as length1
length1 = Sheet1.Range("G2").Value

For Each rcell In Sheet1.Range("A2:A5")
    url1 = "http://eow.alc.co.jp/search?q=" & rcell.Value
    Set http1 = CreateObject("MSXML2.XMLHTTP")
    http1.Open "GET", url1, False
    http1.Send
    text1 = http1.responseText
    
    Sheet1.Cells(rcell.Row, "B").Value = ""
    Sheet1.Cells(rcell.Row, "C").Value = ""
    
    c = "<span class=""wordclass"">"
    a = InStr(text1, c)
    If a = 0 Then Exit Sub
    
    text1 = Right(text1, Len(text1) - a - Len(c) + 1)
    
    b = InStr(text1, "【発音】")
    If b = 0 Then Exit Sub
    
    d = Left(text1, b - 1)
    
    d = Replace(d, "</span><ol><li>", vbCrLf)
    d = Replace(d, "<br />", vbCrLf)
    d = Replace(d, "</li><li>", vbCrLf)
    d = Replace(d, "</li>", "")
    d = Replace(d, "<ol>", "")
    d = Replace(d, "</ol>", "")
    d = Replace(d, "</span>", "")
    d = Replace(d, "<span class=""refvocab"">", "")
    d = Replace(d, "<span class=""label"">", "")
    d = Replace(d, "<span class=""kana"">", "")
    d = Replace(d, c, vbCrLf)
    
    c = "【発音】</span><span class=""pron"">"
    a = InStr(text1, c)
    
    If a = 0 Then Exit Sub
    text1 = Right(text1, Len(text1) - a - Len(c) + 1)
    
    a = InStr(text1, "<span class=""label"">")
    e = Left(text1, a - 1)
    e = Replace(e, "</span>", "")
    e = Replace(e, "<span class=""proni"">", "")
    Sheet1.Cells(rcell.Row, "B").Value = e
    Sheet1.Cells(rcell.Row, "C").Value = d

Next rcell

End Sub

スター

• 

  1件のコメントを見る

• tetlis 2012/02/19 15:25:08

  ありがとうございます。
  他の人と違うアプローチの部分とループを参考にさせていただきます。

  スター
• その他の回答を読む

この質問へのコメント

質問の情報

登録日時

2012-02-18 19:45:11

終了日時

2012-02-19 15:25:55

回答条件

1人5回まで

この質問のカテゴリ

• インターネット
• ウェブ制作

この質問に含まれるキーワード

人気の質問

• オリックスバファローズ　中川圭太　2025年から背番号変更するのは、どれですか？…ren9908271日前
• オリックスバファローズ　安達了一は現役引退後、どうしますか？ren9908271日前
• 音楽のドレミですが、ドイツでは、ABCです（アーベーツェー）。英米でも、ABC（エービーシー）です。イタリ…匿名質問者1123日前
• 第二次大戦中のドイツ陸軍、ドイツ武装親衛隊、ドイツ親衛隊の写真を偶然みたのですけど、帽子を傾けて被っ…匿名質問者2日前
• 陰陽師 0についての質問です。 序盤で安倍晴明がカエルを殺すシーンがありますが、なんといって詠唱したの…匿名質問者2日前

メニュー

• 質問一覧
• カテゴリ一覧
• 無料ユーザー登録
• 人力検索はてなトップ

PC版

• お問い合わせ
• ヘルプ
• お知らせ
• はてなトップ