【★完全回答で 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 段階くらいとか) を差し上げます。

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

回答の条件
  • 1人1回まで
  • 登録:2009/12/11 15:58:03
  • 終了:2009/12/18 16:00:03

ベストアンサー

id:kn1967 No.2

kn1967回答回数2915ベストアンサー獲得回数3012009/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

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

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

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

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

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

その他の回答(1件)

id:mattn No.1

mattn回答回数104ベストアンサー獲得回数232009/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段階になるかと思います。

id:kn1967 No.2

kn1967回答回数2915ベストアンサー獲得回数3012009/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

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

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

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

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

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

  • id:taknt
    透明以外は 黒にするってことですね。

    黒かどうかの判定は 不要だけど、黒を除いた分、高速化するかどうかは疑問。
  • id:mattn
    失礼しました。関数が抜けてました。
    >|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
    ||<
  • id:mattn
    あらら...
    Gistにはりつけました。 http://gist.github.com/254070
  • id:Nigitama
    ありがとうございます。
    ただ今本業で手がふさがっていますので、
    今日の夜に確認いたします。

    とりあえず一時停止します。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません