Option Explicit

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