Option Explicit

'http://takiza.blog39.fc2.com/
'Excelのシート内の全図形をファイルに保存する（その２）
'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