人気ブログランキング | 話題のタグを見る

興味のある物色々。賞味期限切れで廃棄されないよう気をつけます。


by Lautan

口なしドラえもん

某ブログ(この書き出しマンネリ?)で、ドラえもんの絵を描くマクロがExcel2007で動かない(というより動くんだけどちゃんとしたドラえもんにならない)と書いてありました。
試してみたらやはり変!

原因はVBAでのオートシェイプの描画内容が変わったことに有るようです。

今回ドラえもんを描画するVBAプログラムを見ていくと、Excel2003のVBAの機能から以下の変更がありました。
(1)カラーインデックスのデフォルトカラーが変わった
(2)オートシェイプの規定値が塗りつぶしになった
(3)自由線を引く構文が変わった
(4)吹き出しを修正する構文が変わった

このうち(1)(2)はプログラムを修正することで対応可能ですが、(3)(4)の対応方法が分かりません。
そもそもExcelにはマクロの自動記録機能があって、オートシェイプの作成もマクロ記録出来たのですが、Excel2007β2ではオートシェイプの描画がマクロ記録出来ません。
どうも、まだオートシェイプ関連のVBAは作り込み不足のようです。
(3)(4)が変わるのはあんまりなので、これは正規版では過去との互換性を維持する方向になるような気がします。
つまりこれは仕様変更ではなく単なる(あわわ)では無いかと。
また(1)(2)についても、互換性を維持してくれないと困ります。

さて、Excel2003でも2007β2でもちゃんと動くようにドラえもん描画プログラムを変えてみましたが、2007β2では口をかくところがうまく動かないので、ここはコメントアウトしました。
おかげで口のないドラえもんになってしまいました。安倍晴明の時代だったら、口なしドラえもんが枕元に化けて出てくるかもしれません(笑)
---------------------------------------------------------------------------------------
Option Explicit

Sub DORA()
Dim L As Long, T As Long
Range("a1").Select
L = ActiveCell.Left - 160
T = ActiveCell.Top - 50

ActiveSheet.Shapes.AddShape _
(msoShapeOval, 283.5 + L, 128.25 + T, 51#, 72.75).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.Copy
ActiveSheet.Paste
Selection.ShapeRange.Top = 128.25 + T
Selection.ShapeRange.Left = 283.5 + 51 + L

ActiveSheet.Shapes.AddShape _
(msoShapeOval, 310 + L, 160 + T, 11.25, 21#).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0) '//黒
ActiveSheet.Shapes.AddShape _
(msoShapeArc, 352 + L, 165 + T, 7.5, 8.25).Select
Selection.ShapeRange.Adjustments.Item(1) = 180
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) '//白

ActiveSheet.Shapes.AddShape _
(msoShapeOval, 319.5 + L, 191.25 + T, 27.75, 28.5).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) '//赤
ActiveSheet.Shapes.AddShape _
(msoShapeOval, 336.75 + L, 197.25 + T, 8.25, 8.25).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255) '//白

ActiveSheet.Shapes.AddShape _
(msoShapeOval, 229.5 + L, 155.25 + T, 212.25, 173.43).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255) '//白
Selection.ShapeRange.ZOrder msoSendToBack
Selection.ShapeRange.ScaleHeight 0.97, _
msoFalse, msoScaleFromBottomRight

ActiveSheet.Shapes.AddShape _
(msoShapeOval, 204.75 + L, 91.5 + T, 263.25, 237.75).Select
With Selection.ShapeRange
.Fill.ForeColor.RGB = RGB(100, 100, 255) '//スカイブルー
.ZOrder msoSendToBack
.ScaleHeight 0.9579, msoFalse, msoScaleFromBottomRight
.ScaleWidth 0.97, msoFalse, msoScaleFromBottomRight
.IncrementTop -0.75
End With

ActiveSheet.Shapes.AddLine _
(333.75 + L, 221.25 + T, 333.75 + L, 266.25 + T).Select '//ひげ
ActiveSheet.Shapes.AddLine _
(375.75 + L, 215.25 + T, 423.75 + L, 226.5 + T).Select
Selection.ShapeRange.Flip msoFlipVertical
ActiveSheet.Shapes.AddLine _
(375.75 + L, 235.5 + T, 426 + L, 239.25 + T).Select
Selection.ShapeRange.Flip msoFlipVertical
ActiveSheet.Shapes.AddLine _
(375.75 + L, 252 + T, 423.75 + L, 255.75 + T).Select
ActiveSheet.Shapes.AddLine _
(247.5 + L, 219.75 + T, 288.75 + L, 225.75 + T).Select
Selection.ShapeRange.Flip msoFlipHorizontal
Selection.ShapeRange.Flip msoFlipVertical
ActiveSheet.Shapes.AddLine _
(243.75 + L, 239.25 + T, 288.75 + L, 239.25 + T).Select
Selection.ShapeRange.Flip msoFlipHorizontal
ActiveSheet.Shapes.AddLine _
(251.25 + L, 252 + T, 291 + L, 257.25 + T).Select
Selection.ShapeRange.Flip msoFlipHorizontal

'With ActiveSheet.Shapes.BuildFreeform _
'(msoEditingAuto, 246 + L, 240 + T)
'.AddNodes msoSegmentCurve, msoEditingAuto, 241.5 + L, 250.5 + T '//口
'.AddNodes msoSegmentCurve, msoEditingAuto, 261.75 + L, 261.75 + T
'.AddNodes msoSegmentCurve, msoEditingAuto, 334.5 + L, 268.5 + T
'.AddNodes msoSegmentCurve, msoEditingAuto, 395.25 + L, 263.25 + T
'.AddNodes msoSegmentCurve, msoEditingAuto, 428.25 + L, 252 + T
'.AddNodes msoSegmentCurve, msoEditingAuto, 420.75 + L, 241.5 + T
'.ConvertToShape.Select
'End With
ActiveSheet.Shapes.AddShape _
(msoShapeOval, 321.25 + L, 330 + T, 33#, 31.5).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0) '//黄色
ActiveSheet.Shapes.AddShape _
(msoShapeRoundedRectangle, 317.5 + L, 342.75 + T, 40.5, 6#).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0) '//黄色

ActiveSheet.Shapes.AddShape _
(msoShapeRoundedRectangle, 334.75 + L, 351 + T, 6#, 8.25).Select
Selection.ShapeRange.ScaleHeight 1.27, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0) '//黒

ActiveSheet.Shapes.AddShape _
(msoShapeOval, 240.75 + L, 261 + T, 192#, 75.75).Select
With Selection.ShapeRange
.ScaleHeight 1.63, msoFalse, msoScaleFromBottomRight
.IncrementLeft -1.5
.ScaleWidth 1.06, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft
.Fill.ForeColor.RGB = RGB(255, 0, 0) '//赤
.ZOrder msoSendToBack
End With

ActiveSheet.Shapes.AddShape _
(msoShapeOvalCallout, 493.5 + L, 73.5 + T, 324#, 144.75).Select '//吹き出し

With Selection
.Characters.Text = "ぼく、ドラえもん です。"
.Font.Size = 20
.Font.Color = RGB(0, 0, 0) '//黒

'.ShapeRange.Adjustments.Item(1) = -0.0139
'.ShapeRange.Adjustments.Item(2) = 0.9586

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ShapeRange.Fill.ForeColor.RGB = RGB(100, 255, 100) '//ライトグリーン
End With

ActiveCell.Activate
End Sub
by Lautan | 2006-06-21 22:44 | Excel