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 段階くらいとか) を差し上げます。
テキストボックスではなくて、シェイプです。
不明点はコメント欄にお願いします。
No.2
2915
301
35pt
出遅れた感があるので回答すべきかとも思ったのですが・・・
カラーからモノクロへの変換部分が違うので、
回答投稿させていただく事にしました。
214
205
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
※ＩＦ文に関しては回答１の方法が良いでしょうけど、
あえて、そのまま直さずにおきますね。
※ほぼ、専用関数的に作ってますので、
ＲＧＢプロパティが存在しないオブジェクトを
関数に渡すとエラーになります。
No.1
10423
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段階になるかと思います。
No.2
2915301
ここでベストアンサー
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
※ＩＦ文に関しては回答１の方法が良いでしょうけど、
あえて、そのまま直さずにおきますね。
※ほぼ、専用関数的に作ってますので、
ＲＧＢプロパティが存在しないオブジェクトを
関数に渡すとエラーになります。
1
1
1
2
1
コメント（4件)
黒かどうかの判定は 不要だけど、黒を除いた分、高速化するかどうかは疑問。
>|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
||<
Gistにはりつけました。 http://gist.github.com/254070
ただ今本業で手がふさがっていますので、
今日の夜に確認いたします。
とりあえず一時停止します。