Excelのシート内の全図形・画像・イメージをファイルに保存する







Excelのシート内の全図形・画像・イメージをファイルに保存する

関連記事
もし、リボンに「開発」が表示されない場合はこちら
リボンに「開発」が無い場合、リボンに「開発」を追加する

Excelのシート内の全図形・画像・イメージをファイルに保存する(その2)
Excelのシート内の全図形・画像・イメージをファイルに保存する(その3)
Excelのシート内の全図形・画像・イメージをファイルに保存する(その4)



ブログの記事を書く際、Excelを使うことが多々あります。

Excelのシートに画像を貼り付け、記事を完成させます。
画像が多いと、1つ1つの画像について

  1. Excelの画像をコピー
  2. ペイントに貼り付け
  3. jpg や png 形式のファイルに保存

これを繰り返しやっています。
探したらマイクロソフトのサイトにも手順が載っていました。
Excel シートに貼り付けた画像をファイルとして保存するには

ファイルに保存する際、ペイントでファイル名を毎回指定するのも面倒です。

画像が少ない場合は、そんなに手間ではないのですが
多いと結構大変です。

それと、実際に画像を表示するとブラウザ上では大きすぎて
IMG TAGで画像を指定する際、幅、高さを 「width=600 height=611」 のように指定します。
この時、元の画像の幅と高さが分からないといくつを指定したら良いか分かりません。

Excelのマクロを使って、何とか自動で画像をファイルに保存できないか試行錯誤していました。
で、見つけたのがこちら
とある管理人さんの
◆VBAでクリップボードの画像保存(jpgとpng)

こちらに記述されているソースを利用すればできそうということで作ってみました。

■組み込み方法

下図を参考にマクロを登録します。


ソースはここから
Option Explicit

'http://takiza.blog39.fc2.com/
'Excelのシート内の全図形をファイルに保存する
'imageSave V1.0

Const W_DEFAULT = 600
'''Const IMG_EXT = ".png"
Const IMG_EXT = ".jpg"

Const SET_COL = 8 '開始列 H列
Const ROW_TOP = 3 '開始行
Const ROW_CAPTION = ROW_TOP - 1 'キャプション行

Const OUT_PATH = "%USERPROFILE%\Pictures\"

Const PNG_EXT = ".png"

Const LIST_NAME = SET_COL + 0
Const LIST_WIDTH = SET_COL + 1
Const LIST_HEIGT = SET_COL + 2
Const LIST_RATE = SET_COL + 3
Const LIST_CVT_WIDTH = SET_COL + 4
Const LIST_CVT_HEIGT = SET_COL + 5
Const LIST_HTML = SET_COL + 6
Const LIST_NEW_NAME = SET_COL + 7
Const LIST_RENAME_CMD = SET_COL + 8

Const IMG_TAG_W = " width="
Const IMG_TAG_H = " height="

Const CAPTION_LIST = "Name,Width,Heigt,Rate,cWidth,cHeigt,HTML,New Name,ReName CMD"

Const FORMAT_STANDARD = "G/標準"
Const FORMAT_STRING = "@"

Const ENV_KEY = "%"

Const DELIMITER = ","

'Module2 に
'http://i-break.net/article/68901897.html
'のソースを貼り付けます

'コンボボックスのプロパティを出力(配置位置が正しいかチェック用)
'Type
'msoAutoShape 1 オートシェイプ
'msoCallout 2 吹き出し 引き出し線
'msoChart 3 グラフ
'msoComment 4 コメント
'msoFreeform 5 フリーフォーム
'msoGroup 6 グループ化された図形
'msoEmbeddedOLEObject 7 埋め込みOLEオブジェクト
'msoFormControl 8 フォームコントロール
'msoLine 9 線
'msoLinkedOLEObject 10 リンクOLEオブジェクト
'msoLinkedPicture 11 リンクしている画像
'msoOLEControlObject 12 ActiveXコントロール
'msoPicture 13 画像
'msoPlaceholder 14 プレースホルダー
'msoTextEffect 15 テキスト効果
'msoMedia 16 メディア
'msoTextBox 17 テキストボックス
'msoScriptAnchor 18 スクリプトアンカー
'msoTable 19 表
'msoShapeTypeMixed -2 値の取得のみ可能です。
'他の状態の組み合わせを示します。
'msoDiagram 21 図表
'msoCanvas 20 キャンバス
'msoInk 22 インク
'msoInkComment 23 インクコメント
'msoSmartArt 24 スマートアート
'msoSlicer 25 スライサー

Sub imageSave()

Dim wk As String
Dim pt As String

Dim sName As String
Dim rowCnt As Long
Dim sType As Long

Dim control As Shape

Dim calWk As Variant

'キャプション設定
calWk = Split(CAPTION_LIST, DELIMITER)
Range(Cells(ROW_CAPTION, SET_COL), Cells(ROW_CAPTION, SET_COL + UBound(calWk))).Value = calWk
Range(Cells(ROW_CAPTION, SET_COL), Cells(ROW_CAPTION, SET_COL + UBound(calWk))).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Font.Bold = True

rowCnt = ROW_TOP
For Each control In ActiveSheet.Shapes
sType = control.Type
sName = control.Name
If control.Type = msoAutoShape Or control.Type = msoPicture Or control.Type = msoGroup Then
If 1 = 1 Then
Cells(rowCnt, LIST_NAME).NumberFormatLocal = FORMAT_STRING
Cells(rowCnt, LIST_NAME).Value = control.Name
Cells(rowCnt, LIST_WIDTH).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_WIDTH).Value = Int(control.Width / Application.CentimetersToPoints(1) * 100 + 0.5) / 100
Cells(rowCnt, LIST_HEIGT).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_HEIGT).Value = Int(control.Height / Application.CentimetersToPoints(1) * 100 + 0.5) / 100
Cells(rowCnt, LIST_RATE).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_RATE).Formula = "=" & Cells(rowCnt, LIST_WIDTH).Address(False, False) & "/" & Cells(rowCnt, LIST_CVT_WIDTH).Address(False, False)
Cells(rowCnt, LIST_CVT_WIDTH).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_CVT_WIDTH).Value = W_DEFAULT
Cells(rowCnt, LIST_CVT_HEIGT).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_CVT_HEIGT).Formula = "=INT(" & Cells(rowCnt, LIST_HEIGT).Address(False, False) & "/" & Cells(rowCnt, LIST_RATE).Address(False, False) & ")"

Cells(rowCnt, LIST_HTML).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_HTML).Formula = "=""" & IMG_TAG_W & """&" & Cells(rowCnt, LIST_CVT_WIDTH).Address(False, False) & "&""" & IMG_TAG_H & """&" & _
Cells(rowCnt, LIST_CVT_HEIGT).Address(False, False)

Cells(rowCnt, LIST_NEW_NAME).NumberFormatLocal = FORMAT_STRING

wk = "=IF(" & Cells(rowCnt, LIST_NEW_NAME).Address(False, False) & "="""","""",""rename """"""&" & _
Cells(rowCnt, LIST_NAME).Address(False, False) & "&""" & IMG_EXT & """"" """"""&" & _
Cells(rowCnt, LIST_NEW_NAME).Address(False, False) & "&""" & IMG_EXT & """"""")"
Cells(rowCnt, LIST_RENAME_CMD).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_RENAME_CMD).Formula = wk

' xlMoveAndSize セルに合わせて移動やサイズ変更をする
' xlMove セルに合わせて移動するがサイズ変更はしない
' xlFreeFloating セルに合わせて移動やサイズ変更をしない
control.Placement = xlMove
End If

'画像をクリップボードにコピー
control.Copy

'画像を保存
pt = strConv(OUT_PATH & control.Name & IMG_EXT)
SaveCB (pt)

rowCnt = rowCnt + 1
End If
Next

End Sub

'環境変数付き文字列の変換
Function strConv(pt As String) As String
Dim stLen As Long
Dim cnt As Long
Dim kCnt As Long
Dim n As Long

Dim envWord As String
Dim allWord As String

stLen = Len(pt)

cnt = 0
For n = 1 To stLen
If Mid(pt, n, 1) = ENV_KEY Then
cnt = cnt + 1
End If
Next n

'偶数か?
If (cnt Mod 2) = 0 And cnt > 0 Then
kCnt = 0
For n = 1 To stLen
If Mid(pt, n, 1) = ENV_KEY And kCnt = 0 Then
'envWord開始
envWord = ""
kCnt = 1
ElseIf Mid(pt, n, 1) = ENV_KEY And kCnt = 1 Then
'Environ(envWord)をallWordに追加
allWord = allWord & Environ(envWord)
kCnt = 0
ElseIf kCnt = 0 Then
'allWordに追加
allWord = allWord & Mid(pt, n, 1)
ElseIf kCnt = 1 Then
'envWordに追加
envWord = envWord & Mid(pt, n, 1)
End If
Next n
strConv = allWord
Else
strConv = pt
End If

End Function


Sub SaveCB(pt As String)
Dim myStdPicture As StdPicture
Dim gdipRet As GDIPlusStatusConstants

Set myStdPicture = CreatePictureFromClipboard
'jpg保存したいときはこの下の行を有効に(100ところを0~100に変更でクオリティ設定できる)
' gdipRet = SavePictureJpg(myStdPicture, "c:\ABC\001.jpg", 100)
'jpg保存するときはこの下の行をコメントアウト

If Right(pt, 4) = PNG_EXT Then
gdipRet = SavePicturePng(myStdPicture, pt)
Else
gdipRet = SavePictureJpg(myStdPicture, pt, 100)
End If

End Sub

<注意>ソースは転載禁止です。自己責任で利用してください。


■実行方法

「開発」-「マクロ」で「imageSave」を選択し、[実行]します。



■リストの説明
保存した画像の情報を出力します。

表示する位置はソースの
Const SET_COL = 8 '開始列 H列
Const ROW_TOP = 3 '開始行
で指定しています。変更したい場合はソースを変更します。

リスト表示が不要でしたら
If 1 = 1 Then
の行を
If 1 = 2 Then
のように修正してください。

以下は各項目の説明です。
項目名
表示
入力
内容
備考
Name
表示
図形の名前
「オブジェクトの選択と表示」の日本語名と異なります。
ただし、1度「オブジェクトの選択と表示」で名前を変更後は同じになります
Width
表示
図形の幅

Heigt
表示
図形の高さ

Rate
表示
「Width」を「cWidth」に変換するための倍率
「Width」と「cWidth」の値から計算しています
cWidth
入力
図形をHTMLのIMG TAGで表示する際の幅を指定
初期値600はConst W_DEFAULT = 600で指定
値を変更することで「cHeigt」「HTML」を再計算します
cHeigt
表示
図形の縦横比を変えない条件で指定した幅「cWidth」に対する高さを表示します。

HTML
表示
HTMLのIMG TAGの幅と高さの指定部分を表示します

New Name
入力
図形の名前変更したい場合に新しい名前を指定します

ReName CMD
表示
「New Name」が指定された場合、図形の名前を変更するrenameコマンドを表示します
「New Name」が指定された場合表示します


■その他
画像ファイルは標準では「ライブラリ\ピクチャ」に保存されます。

変更したい場合は、ソースの
Const OUT_PATH = "%USERPROFILE%\Pictures\"
を変更します。
環境変数を指定する場合は環境変数を半角「%」でくくって指定してください。
指定例)
Const OUT_PATH = "%USERPROFILE%\Desktop\"
Const OUT_PATH = "%USERPROFILE%\Documents\"
フォルダ指定のヒント
Windows 7のフォルダ一覧


また、jpg形式でファイルを保存しています。
'''Const IMG_EXT = ".png"
Const IMG_EXT = ".jpg"

Const IMG_EXT = ".png"
'''Const IMG_EXT = ".jpg"
の様に編集するとpng形式でファイルを保存します。

図のプロパティを「セルに合わせて移動するがサイズ変更はしない」に設定しています。
control.Placement = xlMove
変更したくない場合は以下のようにコメントにしてください。
'''control.Placement = xlMove

■謝辞
とある管理人さん ソースを利用させていただきました。
ありがとうございました。


スポンサーサイト

コメントの投稿

非公開コメント

アクセスカウンタ
オンラインカウンター
現在の閲覧者数:
プロフィール

たっきー

Author:たっきー
たっきーのブログへようこそ!
パソコン・スマホを
より使いやすくするため奮闘中!
改造したり、root取ったり
色々やってます。

カテゴリ
最新記事
最新コメント
月別アーカイブ
最新トラックバック
検索フォーム
RSSリンクの表示
リンク
ブロとも申請フォーム

この人とブロともになる

QRコード
QR