문서작업을 하다보면 도형들을 딱 붙여서 작업을 해야할 때가 있는데, 오피스 2003인가 부터 SNAP 기능이 있어, 꽤 편해졌지만, 도형들이 아주 많아지는 경우, SNAP 가이드라인이 미친듯이 많이 나오게 되는 관계로 그 또한 어려워진다.
아래와 같이 도형들이 산개해 있다고 치자. 빨간 도형을 기준으로 아래에 딱 붙여서 도형을 정렬하고자 한다면, 왼쪽 정렬을 한 뒤에, SNAP으로 하나씩 조정을 해줘야 한다.
최종 모양은 이런식이 될 것이다. 그런데, 손으로 하다보면, 삑사리가 나는 경우가 있고, 도형에 외곽선(STROKE)가 쳐져 있는 경우는 외곽선의 굵기인 1px 정도 어긋나는 경우가 자주 발생한다.
자주 사용할 일은 없지만, 예를 들어 아래와 같이 타이틀을 위한 도형을 만드는 경우, 사용이 필요하다. 나의 경우는 꽤나 자주 이런 형태를 사용하기 때문에, 코드를 만들어본다.
룰은 간단하다. 첫번째 선택하는 도형이 기준이 되고, 이후 도형들은 기준의 밑으로 따라 붙는다. 개수는 상관이 없도록 한다. 개발새발 작성한 코드는 아래와 같다.
Sub shape_align_bottom()
Dim standardshape As Shape
Dim shapename()
If ActiveWindow.Selection.Type = ppSelectionShapes Then
'selected shape name array
ReDim Preserve shapename(ActiveWindow.Selection.ShapeRange.Count)
'selected shape name array count
arrcount = UBound(shapename) - LBound(shapename)
For Each shp In ActiveWindow.Selection.ShapeRange
For x = 1 To arrcount
If shapename(x) = "" Then
shapename(x) = shp.Name
Exit For
End If
Next x
Next shp
Else
MsgBox "There is no shape currently selected!", vbExclamation, "No Shape Found"
Exit Sub
End If
'size
standardshape_height = ActiveWindow.Selection.ShapeRange(shapename(1)).Height
standardshape_width = ActiveWindow.Selection.ShapeRange(shapename(1)).Width
'position
standardshape_left = ActiveWindow.Selection.ShapeRange(shapename(1)).left
standardshape_top = ActiveWindow.Selection.ShapeRange(shapename(1)).top
For y = 2 To arrcount
ActiveWindow.Selection.ShapeRange(shapename(y)).top = standardshape_top + standardshape_height
If y > 2 Then
accheight = accheight + ActiveWindow.Selection.ShapeRange(shapename(y - 1)).Height
ActiveWindow.Selection.ShapeRange(shapename(y)).top = ActiveWindow.Selection.ShapeRange(shapename(y)).top + accheight
End If
ActiveWindow.Selection.ShapeRange(shapename(y)).left = standardshape_left
Next y
End Sub
구현된 화면은 아래와 같다.
## 코드 업데이트
안타깝게도 아래 그림처럼, 이름이 동일한 shape들이 있으면 에러가 나는 현상이 있다. 파워포인트 안에서 shape의 이름이 중복인 경우가 많다는 것을 처음 알게 되었다.
아래와 같이 코드를 수정해 주었다.
Sub shapealign_bottom()
Dim standardshape As Shape
Dim shapename()
Dim shapenameOrigin()
If ActiveWindow.Selection.Type = ppSelectionShapes Then
Set selectShapes = ActiveWindow.Selection.ShapeRange
'selected shape name array
ReDim Preserve shapename(selectShapes.Count)
ReDim Preserve shapenameOrigin(selectShapes.Count)
'selected shape name array count
arrcount = UBound(shapename) - LBound(shapename)
For x = 1 To arrcount
shapenameOrigin(x) = selectShapes(x).Name
selectShapes(x).Name = selectShapes(x).Name & x
Next x
For Each shp In selectShapes
For x = 1 To arrcount
If shapename(x) = "" Then
shapename(x) = shp.Name
Exit For
End If
Next x
Next shp
Else
MsgBox "There is no shape currently selected!", vbExclamation, "No Shape Found"
Exit Sub
End If
'size
standardshape_height = ActiveWindow.Selection.ShapeRange(shapename(1)).Height
standardshape_width = ActiveWindow.Selection.ShapeRange(shapename(1)).Width
'position
standardshape_left = ActiveWindow.Selection.ShapeRange(shapename(1)).left
standardshape_top = ActiveWindow.Selection.ShapeRange(shapename(1)).top
For y = 2 To arrcount
ActiveWindow.Selection.ShapeRange(shapename(y)).top = standardshape_top + standardshape_height
If y > 2 Then
culumheight = culumheight + ActiveWindow.Selection.ShapeRange(shapename(y - 1)).Height
ActiveWindow.Selection.ShapeRange(shapename(y)).top = ActiveWindow.Selection.ShapeRange(shapename(y)).top + culumheight
End If
ActiveWindow.Selection.ShapeRange(shapename(y)).left = standardshape_left
Next y
For x = 1 To arrcount
selectShapes(x).Name = shapenameOrigin(x)
Next x
End Sub
끝.
