엑셀 VBA로 포토샵 이미지 자르기(불투명 부분 날리기)

매크로 설명

• 개인적인 필요에 의해서 만든 포토샵 매크로이다.
• 파노라마 사진을 Merge 하고 남은 투명 배경, 여러 장의 사진을 Stack 모드로 불러와서 Align 했을 때 생기는 투명 배경,
• 렌즈에 의해 생긴 왜곡이나 수평 맞춤을 했을 때 잘라내야 하는 부분이 직사각형(Rectangle)이 아닌 경우
• 포토샵의 Trim 기능이 먹히지 않는 경우에 투명 배경만큼을 잘라내는 매크로이다.
• 전체적인 흐르은 1: 투명 배경의 일부 선택, 2: Grow 기능으로 투명 배경 확장, 3: 투명배경의 좌표(Coordinate) 탐색 및 삭제
• 동영상을 보면 이해가 쉬울 것으로 생각한다.
• 원래 사진 작업을 하시는 분들은 Content-aware Fill 기능을 활용하여 원본 픽셀을 보존/확장하면서 훼손을 최소화하지만
• 본인은 원본 픽셀을 보존할 일이 없어서 스트레스 받지 않고 1px이라도 손해보지 않기 위해 본 매크로를 만들었다.

VBA Code

Option Explicit
Sub largest_inner_rectangle()
Dim appPhoto As Photoshop.Application
Dim docPhoto As Photoshop.Document
Dim layerPhoto As Photoshop.ArtLayer
Dim selHorizon As Double, selVertical As Double '선택영역의 가로, 세로 길이

Set appPhoto = New Photoshop.Application
appPhoto.Visible = True
appPhoto.DisplayDialogs = psDisplayNoDialogs

Set docPhoto = appPhoto.ActiveDocument
Set layerPhoto = docPhoto.ActiveLayer

Call docPhoto.Selection.Grow(0, True) '선택영역과 인접한 유사영역으로 선택영역 확장

With docPhoto.Selection          '선택영역에서 크기가 작은 쪽을 선택
    selHorizon = Abs(.Bounds(0) - .Bounds(2))
    selVertical = Abs(.Bounds(1) - .Bounds(3))
    If selHorizon > selVertical Then
        selHorizon = 0
    Else
        selVertical = 0
    End If
End With

If selHorizon > selVertical Then
    If docPhoto.Selection.Bounds(0) < docPhoto.Width / 2 Then '선택영역이 왼쪽에 있다면
        Call docPhoto.ResizeCanvas(docPhoto.Width - selHorizon, docPhoto.Height - selVertical, psMiddleRight)
    Else
        Call docPhoto.ResizeCanvas(docPhoto.Width - selHorizon, docPhoto.Height - selVertical, psMiddleLeft)
    End If
Else
    If docPhoto.Selection.Bounds(1) < docPhoto.Height / 2 Then '선택영역이 위쪽에 있다면
        Call docPhoto.ResizeCanvas(docPhoto.Width - selHorizon, docPhoto.Height - selVertical, psBottomCenter)
    Else
        Call docPhoto.ResizeCanvas(docPhoto.Width - selHorizon, docPhoto.Height - selVertical, psTopCenter)
    End If
End If


docPhoto.Selection.SelectAll     '아래 코드는 캔버스 사이즈에 맞게 레이어 Crop

With docPhoto
.Selection.SelectAll
Call .Crop(.Selection.Bounds, 0, .Width, .Height)
End With

Set layerPhoto = Nothing
Set docPhoto = Nothing
Set appPhoto = Nothing

End Sub

매크로 실행 동영상

 Copyright (2018) Ruahneuma. All Rights Reserved.