April 12, 2014

Excelで画像ファイルを切り抜き、並べるマクロ

Excelのセルを表のセルとして利用し、そこに適当なマージンを設定した大きさになるように画像をトリミングするツールを作成しました。

使用方法

  1. 切り抜きたい画像を選びます。
  2. setCropBoxWithMarginで切り抜き範囲を指定する枠を生成します。
  3. 画像の上で切り抜き範囲を動かして切り抜きたい範囲を指定します。
  4. cropPictureToBoxでで図形を切り抜きます。
  5. 前項で画像を自動配置しなかった場合は、画像をおおよそセルの中央に移動させた後、以下のマクロを使って場所を調整します。
found, known and done.: Excelの図の位置をセルの中心に
http://foundknownanddone.blogspot.jp/2014/04/excel-centering-object-to-cell.html#more



 コード

Sub setCropBoxWithMargin()
    Dim margin(0 To 3) As Double
    Dim marginResponse As String, marginResponseArray() As String
    Dim cropBoxCellRange As Range, cropBoxCell As Range
    Dim targetShape As Shape
    Dim boxTop As Double, boxLeft As Double, boxHeight As Double, boxWidth As Double
    Dim i As Long, j As Long
        
    Set cropBoxCellRange = Application.InputBox("Select cells you want to fit pictures.", "setCropBox", , , , , , 8)
    If cropBoxCellRange Is Nothing Then Exit Sub
    
    marginResponse = Application.InputBox("Set margin for pictures.(format: margin / margin-topbottom, margin-leftright / margin-top, margin-bottom, margin-left, margin-right", "setCropBox", , , , , , 2)
    If marginResponse = "" Then marginResponse = "0"
    
    marginResponseArray = Split(marginResponse, ",")
    Select Case UBound(marginResponseArray)
    Case 0
        For i = 0 To 3
            margin(i) = CInt(marginResponseArray(0))
        Next
    Case 1
        margin(0) = CInt(marginResponseArray(0))
        margin(1) = CInt(marginResponseArray(0))
        margin(2) = CInt(marginResponseArray(1))
        margin(3) = CInt(marginResponseArray(1))
    Case 3
        For i = 0 To 3
            margin(i) = CInt(marginResponseArray(i))
        Next
    Case Else
     Exit Sub
    End Select
    
    
    j = 1
    For i = 1 To Selection.ShapeRange.Count
        Set targetShape = Selection.ShapeRange(i)
        Set cropBoxCell = cropBoxCellRange(j)
        
        If targetShape.Type <> msoPicture Then GoTo Continue
        
        boxTop = targetShape.Top + targetShape.Height / 2 - cropBoxCell.Height / 2 + margin(0)
        boxLeft = targetShape.Left + targetShape.Width / 2 - cropBoxCell.Width / 2 + margin(2)
        boxHeight = cropBoxCell.Height - (margin(0) + margin(1))
        boxWidth = cropBoxCell.Width - (margin(2) + margin(3))
        
        With ActiveSheet.Shapes.AddShape(msoShapeRectangle, boxLeft, boxTop, boxWidth, boxHeight)
            .Fill.Visible = msoFalse
            .Line.ForeColor.RGB = RGB(0, 0, 0)
            .Line.Style = msoLineSingle
            .Line.Weight = 2
            .Name = "cropbox_" & cropBoxCell.Address
        End With
        
        j = j + 1
Continue:
    Next
End Sub

Sub cropPictureToBox()
    Dim targetObject As Variant
    Dim targetCenterCell As Range
    Dim zoomX As Double, zoomY As Double
    Dim cropBox As Shape
    Dim flagDeleteAfterCropping As Integer, flagMoveAfterCropping As Integer
    
    flagDeleteAfterCropping = MsgBox("Delete cropping boxes after cropping?", vbYesNo, "cropPictureToBox")
    flagMoveAfterCropping = MsgBox("Move pictures to cell after cropping?", vbYesNo, "cropPictureToBox")
    
    For Each targetObject In Selection.ShapeRange
        With targetObject
            If .Type <> msoPicture Then GoTo Continue1
            With .Duplicate
                .ScaleWidth 1, True
                .ScaleHeight 1, True
                
                zoomX = .Width / targetObject.Width
                zoomY = .Height / targetObject.Height
                .Delete
            End With
            
            For Each cropBox In ActiveSheet.Shapes
                If cropBox.Type <> msoAutoShape Or cropBox.AutoShapeType <> msoShapeRectangle Then GoTo Continue2
                If .Top < cropBox.Top And .Left < cropBox.Left _
                    And .Top + .Height > cropBox.Top + cropBox.Height _
                    And .Left + .Width > cropBox.Left + cropBox.Width Then
                    
                    .PictureFormat.CropRight = .PictureFormat.CropRight + _
                        zoomX * (.Left + .Width - (cropBox.Left + cropBox.Width))
                    .PictureFormat.CropLeft = .PictureFormat.CropLeft + _
                        zoomX * (-.Left + cropBox.Left)
                    .PictureFormat.CropTop = .PictureFormat.CropTop + _
                        zoomY * (-.Top + cropBox.Top)
                    .PictureFormat.CropBottom = .PictureFormat.CropBottom + _
                        zoomY * (.Top + .Height - (cropBox.Top + cropBox.Height))
                    
                    If flagMoveAfterCropping = vbYes Then
                        If Split(cropBox.Name, "_")(0) = "cropbox" Then
                            Set targetCenterCell = Range(CStr(Split(cropBox.Name, "_")(1)))
                            .Top = targetCenterCell.Top + (targetCenterCell.Height - .Height) / 2
                            .Left = targetCenterCell.Left + (targetCenterCell.Width - .Width) / 2
                        End If
                    End If
                    
                    If flagDeleteAfterCropping = vbYes Then cropBox.Delete
                    
                End If
Continue2:
            Next

        End With
Continue1:
    Next
End Sub

既知の問題

  • ボックスが画像より大きい場合、切り抜きが上手く機能しない。

No comments :

Post a Comment