スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

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





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

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


Excelのシート内の全図形・画像・イメージをファイルに保存する VBA マクロを修正しました。

マクロの使用方法については過去記事を参照してください。

■マクロの変更箇所
主な変更箇所です。
  1. ReSizeのリスト入力を通常の入力に変更
    設定する際まれにエラー「アプリケーション定義またはオブジェクト定義のエラーです」になるので通常の入力に戻した。
    リスト入力を有効にするには
    'Const LIST_INPUT = True
    Const LIST_INPUT = False

    Const LIST_INPUT = True
    'Const LIST_INPUT = False
    にします。
  2. Subの名称を変更
    環境変数付き文字列の変換Sub
    strEnvConvをstrEnvConvに変更しました。
  3. 図形をセルの位置にあわせる
    図形をセルの角に合わせることができます。
    'Const POS_ADJUST = True
    Const POS_ADJUST = False

    Const POS_ADJUST = True
    'Const POS_ADJUST = False
    に変更すると有効になります。

■マクロの内容
Option Explicit

'http://takiza.blog39.fc2.com/
'Excelのシート内の全図形をファイルに保存する(その4)
'imageSave V1.2
'Sub名称変更 strEnvConv -> strEnvConv

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

Const OUT_PATH = "%USERPROFILE%\Pictures\"

'V1.2 ReSizeをリスト入力するか否か
'Const LIST_INPUT = True
Const LIST_INPUT = False

'V1.2 図形のセル位置あわせ
'Const POS_ADJUST = True
Const POS_ADJUST = False

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



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

'項目追加 「No.,Column,Row,ReSize,IMG Path,OUT_PATH」 v1.1
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 = "%"

'IMG TAG v1.1
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

'V1.2
Dim cellTop As Double
Dim cellLeft As Double

'キャプション設定
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

'フローチャートの図形名称の半角「:」を削除 v1.2
sName = Replace(sName, ":", "")

If control.Type = msoAutoShape Or control.Type = msoPicture Or control.Type = msoGroup Or _
control.Type = msoOLEControlObject Or control.Type = msoChart Then
If 1 = 1 Then
'項目見直し v1.1
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 = sName
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

'V1.2 まれにv1.1で追加した「選択入力リセット」でエラーになるの対処 v1.2
If LIST_INPUT Then
'選択入力リセット v1.1
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

'サイズ変更選択 v1.1
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
End If

Cells(rowCnt, LIST_IMG_PATH).NumberFormatLocal = FORMAT_STANDARD

Cells(rowCnt, LIST_IMG_TAG).NumberFormatLocal = FORMAT_STANDARD

'IMG TAG 生成処理 v1.1
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) & "<>""" & "" & """," & _
Cells(rowCnt, LIST_HTML).Address(False, False) & ",""""))"
Cells(rowCnt, LIST_IMG_TAG).Formula = wk

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

'V1.2 図形をセルの位置にあわせる
If POS_ADJUST Then
cellTop = Cells(control.TopLeftCell.Row, control.TopLeftCell.Column).Top
cellLeft = Cells(control.TopLeftCell.Row, control.TopLeftCell.Column).Left
control.Top = cellTop
control.Left = cellLeft
End If


End If

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

'画像を保存
pt = strEnvConv(OUT_PATH & sName & IMG_EXT)
SaveCB (pt)

rowCnt = rowCnt + 1
End If
Next

End Sub

'環境変数付き文字列の変換
Function strEnvConv(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
strEnvConv = allWord
Else
strEnvConv = 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

'追加 V1.1
Sub sortList()
'リストを Row(行)でソート
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()
'HTML TAG セット
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

'追加 V1.2
Sub figClear()
'図の中を透明に
Selection.ShapeRange.Fill.Visible = msoFalse
End Sub

Sub figWhite()
'図を白の塗りつぶしに
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
End Sub

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


スポンサーサイト

コメントの投稿

非公開コメント

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

たっきー

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

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

この人とブロともになる

QRコード
QR
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。