にぎたま回答ポイント 70ptウォッチ 2

【★完全回答で 500pt ～★】

Word VBA で色付きのシェイプをモノクロにする方法

Win XP Home, Word 2003/2007 を使っています。

doc 文書内にいろいろな図 (シェイプを使用したもの) があります。これらの図は赤や青や緑など、さまざまな色の線や塗りつぶしがされています。

これを Word VBA を使って、黒と透明以外の色が設定されている線または面をモノクロに置き換える方法はありますか？

イメージとしてはこんな感じです。
for i = 0 to シェイプの数
if シェイプ(i).線 <> 黒 or 透明
シェイプ(i).線 = 黒
end if
if シェイプ(i).面 <> 黒 or 透明
シェイプ(i).面 = 黒
end if
next

最初に白黒化ができる回答をしてくれた人に 100pt、
使われている色の明度に合わせてグレースケールで濃淡が出せた場合は +500 ポイント (濃淡の精度はほどほど、例 10 or 16 段階くらいとか) を差し上げます。

テキストボックスではなくて、シェイプです。
不明点はコメント欄にお願いします。

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

ベストアンサー

• kn19672009/12/11 17:33:35

  満足35pt

  出遅れた感があるので回答すべきかとも思ったのですが・・・

  カラーからモノクロへの変換部分が違うので、

  回答投稿させていただく事にしました。

  Function Color2Mono(s As Object)
      Dim r As Integer, g As Integer, b As Integer, mono As Integer
      r = s.rgb Mod 256
      g = Int(s.rgb / 256) Mod 256
      b = Int(s.rgb / 256 / 256)
      mono = r * 0.3 + g * 0.59 + b * 0.11
      s.rgb = rgb(mono, mono, mono)
  End Function
  
  Sub Macro1()
    Dim s As Object
    With ActiveDocument
      For Each s In .Shapes
        With s
          If .Fill.Visible = msoTrue Then '塗りつぶしありの場合はモノクロ化
            Call Color2Mono(.Fill.ForeColor)
          End If
          If .Line.Visible = msoTrue Then '線ありの場合はモノクロ化
            Call Color2Mono(.Line.ForeColor)
          End If
        End With
      Next
    End With
  End Sub
  

  ※ＩＦ文に関しては回答１の方法が良いでしょうけど、

  　あえて、そのまま直さずにおきますね。

  ※ほぼ、専用関数的に作ってますので、

  　ＲＧＢプロパティが存在しないオブジェクトを

  　関数に渡すとエラーになります。

  スター

その他の回答

• mattn2009/12/11 17:15:41

  満足35pt

  こんな感じでどうでしょうか？

  Sub foo()
      Dim i, j, rgbl, r, g, b As Integer
      Dim m As Long
      For i = 1 To Me.Shapes.Count
          For j = 1 To Me.Shapes(i).CanvasItems.Count
              With Me.Shapes(i).CanvasItems(j)
                  If .Line.ForeColor <> vbBlack Or .Line.Transparency = 0 Then
                      rgbl = .Line.ForeColor
                      r = SHR(rgbl, 16) Mod 256
                      g = SHR(rgbl, 8) Mod 256
                      b = rgbl Mod 256
                      m = max(max(r, g), b)
                      .Line.ForeColor.rgb = rgb(m, m, m)
                  End If
                  If .Fill.ForeColor <> vbBlack Or .Fill.Transparency = 0 Then
                      rgbl = .Fill.ForeColor.rgb
                      r = SHR(rgbl, 16) Mod 256
                      g = SHR(rgbl, 8) Mod 256
                      b = rgbl Mod 256
                      m = (r + g + b) / 3
                      .Fill.ForeColor.rgb = rgb(m, m, m)
                  End If
              End With
          Next
      Next
  End Sub
  

  明度はRGB平均で出してますので確かなHSBじゃないですが、やってみた結果、それっぽく出なかったので平均にしてます。

  明度の刻みは

  m = CInt((CDbl(m) / 25.6) * 25.6)
  

  とかすれば10段階になるかと思います。

  スター

この質問へのコメント

• きゃづみぃ2009/12/11 16:44:09
  透明以外は 黒にするってことですね。
  
  黒かどうかの判定は 不要だけど、黒を除いた分、高速化するかどうかは疑問。
  
• mattn2009/12/11 17:31:31
  失礼しました。関数が抜けてました。
  >|vb|
  Option Explicit
  
  Private Function SHR(ByVal x As Long, ByVal c As Byte) As Long
  Dim msb As Long
  msb = x And &H80000000
  x = (x And &H7FFFFFFF) \ 2 ^ c
  If msb Then x = x Or 2 ^ (31 - c)
  SHR = x
  End Function
  
  
  Private Function SHL(ByVal x As Long, ByVal c As Byte) As Long
  Dim mask As Long
  Dim msb As Long
  mask = &H2& ^ (31 - c)
  msb = x And mask
  x = (x And (mask - 1)) * 2 ^ c
  If msb Then x = x Or &H80000000
  SHL = x
  End Function
  
  Function MAX(ByVal lhs As Long, ByVal rhs As Long)
  If lhs < rhs Then
  MAX = rhs
  Else
  MAX = lhs
  End If
  End Function
  
  Sub foo()
  Dim i, j, rgbl, r, g, b As Integer
  Dim m As Long
  For i = 1 To Me.Shapes.Count
  For j = 1 To Me.Shapes(i).CanvasItems.Count
  With Me.Shapes(i).CanvasItems(j)
  If .Line.ForeColor <> vbBlack Or .Line.Transparency = 0 Then
  rgbl = .Line.ForeColor
  r = SHR(rgbl, 16) Mod 256
  g = SHR(rgbl, 8) Mod 256
  b = rgbl Mod 256
  m = MAX(MAX(r, g), b)
  .Line.ForeColor.rgb = rgb(m, m, m)
  End If
  If .Fill.ForeColor <> vbBlack Or .Fill.Transparency = 0 Then
  rgbl = .Fill.ForeColor.rgb
  r = SHR(rgbl, 16) Mod 256
  g = SHR(rgbl, 8) Mod 256
  b = rgbl Mod 256
  m = (r + g + b) / 3
  .Fill.ForeColor.rgb = rgb(m, m, m)
  End If
  End With
  Next
  Next
  End Sub
  ||<
  
• mattn2009/12/11 17:37:03
  あらら...
  Gistにはりつけました。 http://gist.github.com/254070
  
• にぎたま2009/12/11 17:41:25
  ありがとうございます。
  ただ今本業で手がふさがっていますので、
  今日の夜に確認いたします。
  
  とりあえず一時停止します。

質問の情報

登録日時

2009-12-11 15:58:03

終了日時

2009-12-18 16:00:03

回答条件

1人1回まで

この質問のカテゴリ

• コンピュータ

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

人気の質問

• 親族（実家）の犬が無駄吠えをしています。朝方に一時間くらい吠えているらしい。昼にも一時間くらい吠え続…匿名質問者1120時間前
• 東京都は山に四方を囲まれています。風水的にはどうですか？。匿名質問者11日前
• 誰か読んでくれませんか？ ゲームの話です アンダーテールっていうんですけど 話し相手が全然いないんです…yun_10241日前
• スマホ（アンドロイド）に、TypeAppを入れております。登録になっているメアドのいくつかを削除したいので…匿名質問者120時間前
• アスペルガー精神3級会社員男性(34歳独身)です。 元々眠りが浅いのに最近尚更深刻な夢や深く考え過ぎる夢を…hayakushinene16時間前

メニュー

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

PC版

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