第74回目 図をもとに説明するためのツール

○第74回目　図を加えて説明するためのツール


　これまでの説明はほとんど文章だけで、イメージがつきづらいという問題がありました。
　少しでも図式を取り入れて説明するということも必要ですので、いろいろと探していたところ、便利なツールが見つかりました。
　これを使って、図を登場させたいと思います(投稿時期のずれのため、これまでの投稿にはすでに一部対応しています)。

【図形作成システムで作成した例】










　ホームページからの転載です。
　　http://www2s.biglobe.ne.jp/~iryo/2vba/vba29b.htmlより転載。
---------------------------------------------------------------------------
２９－３６．シ－ト上の指定したセルをgif(jpg)で保存
○●● ホ－ムペ－ジを出していると説明用に、シ－トの特定セルを切り取り図形(gif) で保存したいケ－スがよくあります。簡単に変換する方法がないか色々考えようやく出来たのが下記マクロです。（本人評価→スゴク便利）

マクロの説明：
[1]開いているブックと同じフォルダ－へ保存します。(新規作成のブックは一度保存すること）
[2]変換したいセルの場所はマウスで範囲を指定（InputBoxメソッドのType:=8使用）
[3]指定した範囲を図でコピ－（Format:=xlBitmapがピクチャ－より綺麗だった）
[4]図の大きさを取得し、それより少し大きいChart枠を作成[3]を貼り付け
[5]Exportメソッドでgifファイルとして保存（ファイル名は"Mygif.gif"としてある）
[6]上記で仮作成した、図とチャ－トを削除


Sub 例2936()
Dim grf As Chart
Dim scel As Range

'保存先パス
phn = ActiveWorkbook.Path
If phn = "" Then
MsgBox "このブックと同じフォルダ－へGIFを保存します" & Chr(10) _
& "パス未定の為ブックを1度保存してから実行して下さい"
Exit Sub
End If

'コピ－個所指定
msg = "GIFで保存するセル範囲を指定して下さい。" & Chr(10) _
& "(セル範囲をシ－トから指定して下さい)"
On Error Resume Next
Application.DisplayAlerts = False
Set scel = Application.InputBox(msg, "セル指定", Type:=8)
Application.DisplayAlerts = True
If TypeName(scel) = "Nothing" Then
MsgBox "セル範囲をシ－トから指定して下さい"
Exit Sub
End If
On Error GoTo 0
scel.Select
'画像コピ－
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ActiveSheet.Paste
ActiveSheet.Pictures.Select
pnam2 = Selection.Name

ActiveSheet.Shapes(pnam2).Select
hei = Selection.ShapeRange.Height
wid = Selection.ShapeRange.Width
'チャ－ト枠作成
Set grf = ActiveSheet.ChartObjects.Add(0, 0, wid + 8, hei + 8).Chart
grf.Paste

'gif保存
grf.Export phn & "\" & "Mygif.gif"
'仮作成の図形削除
grf.Parent.Delete
ActiveSheet.Shapes(pnam2).Select
Selection.Delete

Range("A1").Select
End Sub

jpg保存の場合は、grf.Export phn & "\" & "Mygif.gif"を"Mygif.jpg"にして下さい

--以上、http://www2s.biglobe.ne.jp/~iryo/2vba/vba29b.htmlより転載。---------