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





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

ブログの記事を書く際、Excelを使うことが多々あります。
Excelのシートに画像を貼り付け、記事を完成させます。

以前、Excelのシート上の画像をファイルに保存する VBA マクロを紹介しました。
関連記事
Excelのシート内の全図形・画像・イメージをファイルに保存する
Excelのシート内の全図形・画像・イメージをファイルに保存する(その3)
Excelのシート内の全図形・画像・イメージをファイルに保存する(その4)

私自身、結構、便利に使っています。

ただ、使っていると更に便利に使いたくなります。

そこで、少し改造し、機能アップしてみました。

使用方法は過去記事を参照してください。

変更点は以下の通りです。
この変更により、ブログの記事作成が容易になると思います。

■リストの項目追加
No.通番
Columnイメージが存在するセルの列アドレスを表示
Rowイメージが存在するセルの行アドレスを表示
ReSizeHTMLのIMG TAG生成時、幅と高さを変更するか否かを選択して指定します
IMG PathHTMLのIMG TAG生成時、ファイルが存在するURLを指定します
(例:http://blog-imgs-59.fc2.com/t/a/k/takiza/)
IMG TAGHTMLのIMG TAG生成します

また、項目名の右にファイル保存先の表示を追加しました。

■マクロの処理追加
sortListリストをRow(行)アドレスの昇順にソートします
実行することにより、シートの行順に一覧をソートできます。
tagSetイメージが存在するセルにIMG TAGをコピーします
シート上にブログの記事を記述している場合に容易にIMG TAGを追加できます


■マクロの内容
Option Explicit

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

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_No = SET_COL + 0
Const LIST_NAME = SET_COL + 1
Const LIST_WIDTH = SET_COL + 2
Const LIST_HEIGT = SET_COL + 3
Const LIST_RATE = SET_COL + 4
Const LIST_CVT_WIDTH = SET_COL + 5
Const LIST_CVT_HEIGT = SET_COL + 6
Const LIST_HTML = SET_COL + 7
Const LIST_NEW_NAME = SET_COL + 8
Const LIST_RENAME_CMD = SET_COL + 9
Const LIST_TOP_COL = SET_COL + 10
Const LIST_TOP_ROW = SET_COL + 11

Const LIST_SIZE = SET_COL + 12

Const LIST_IMG_PATH = SET_COL + 13

Const LIST_IMG_TAG = SET_COL + 14

Const LIST_SORT_END = LIST_IMG_TAG

Const IMG_TAG_W = " width="
Const IMG_TAG_H = " height="
Const DELIMITER = ","
Const PATHNAME_KEY = "%IMG_PATH%"

Const RESIZE_SPEC = "resize"

Const SIZE_SELECTION = "," & RESIZE_SPEC

Const CAPTION_LIST = "No.,Name,Width,Heigt,Rate,cWidth,cHeigt,HTML,New Name,ReName CMD,Column,Row,ReSize,IMG Path,IMG TAG" & DELIMITER & OUT_PATH

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

Const ENV_KEY = "%"

Const IMG_TAG = """<img src=""""" & PATHNAME_KEY & """"">"""

'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 keyLen 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 Or control.Type = msoOLEControlObject Then
If 1 = 1 Then
Cells(rowCnt, LIST_No).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_No).Value = rowCnt - ROW_TOP + 1
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

Cells(rowCnt, LIST_TOP_COL).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_TOP_COL).Value = control.TopLeftCell.Column
Cells(rowCnt, LIST_TOP_ROW).NumberFormatLocal = FORMAT_STANDARD
Cells(rowCnt, LIST_TOP_ROW).Value = control.TopLeftCell.Row

'選択入力リセット
Range(Cells(rowCnt, LIST_No), Cells(rowCnt, LIST_IMG_TAG)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With

'サイズ変更選択
Range(Cells(rowCnt, LIST_SIZE), Cells(rowCnt, LIST_SIZE)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=SIZE_SELECTION
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With

Cells(rowCnt, LIST_IMG_PATH).NumberFormatLocal = FORMAT_STANDARD

Cells(rowCnt, LIST_IMG_TAG).NumberFormatLocal = FORMAT_STANDARD

keyLen = Len(PATHNAME_KEY) + 1
wk = "=REPLACE(" & IMG_TAG & ", FIND(""" & PATHNAME_KEY & """," & IMG_TAG & ")," & _
keyLen & ", " & Cells(rowCnt, LIST_IMG_PATH).Address(False, False) & "&" & _
Cells(rowCnt, LIST_NEW_NAME).Address(False, False) & "&""" & IMG_EXT & """""""" & _
"&IF(" & Cells(rowCnt, LIST_SIZE).Address(False, False) & "=""" & RESIZE_SPEC & """," & _
Cells(rowCnt, LIST_HTML).Address(False, False) & ",""""))"
Cells(rowCnt, LIST_IMG_TAG).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

Sub sortList()
Dim maxRow As Long

maxRow = Cells(Rows.Count, SET_COL).End(xlUp).Row

If maxRow >= ROW_TOP Then
Range(Cells(ROW_TOP, SET_COL), Cells(maxRow, SET_COL + LIST_SORT_END)).Sort , _
Key1:=Columns(LIST_TOP_ROW), _
Order1:=xlAscending
End If

End Sub

Sub tagSet()
Dim maxRow As Long
Dim rowCnt As Long

maxRow = Cells(Rows.Count, SET_COL).End(xlUp).Row

If maxRow >= ROW_TOP Then
For rowCnt = ROW_TOP To maxRow
Cells(Cells(rowCnt, LIST_TOP_ROW).Value, Cells(rowCnt, LIST_TOP_COL).Value).Value = Cells(rowCnt, LIST_IMG_TAG).Value
Next rowCnt
End If

End Sub

imageSave_v1_1.txtこのリンクを「名前を付けてリンク先を保存」や「対象をファイルに保存」等で保存します。
スポンサーサイト

コメントの投稿

非公開コメント

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

たっきー

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

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

この人とブロともになる

QRコード
QR