[VBA] 엑셀 그림 일괄 저장하기

안녕하세요

 

오늘은 엑셀에 있는 그림을 자동으로 저장하는 프로그램을 짜보도록 하겠습니다.

 

먼저 아래와 같은 그림이 있구요

 

 

 

그림을 저장시 구분하기 위하여 박지성.jpg, 이영표.jpg, ... 이런 식으로 저장을 해보겠습니다.

 

VBA에서는 그림을 바로 저장하지 못합니다.

 

그래서 꼼수를 쓰는게

 

맨 먼저 차트개체를 생성하고

 

그림을 카피를 한 다음에 차트개체에 붙여넣기를 합니다.

 

그리고 차트개체를 그림으로 저장하게 됩니다.

 

코딩 내용입니다.

 

---

차트개체를 생성합니다.

Dim Mychart As ChartObject

 

차트개체를 대략 10,10 위치에 20,20 크기로 만들어 놓습니다. 아무값이나 괜찮습니다.

Set Mychart = ActiveSheet.ChartObjects.Add(10, 10, 20, 20)

 

차트개체의 이름을 임의로 짓습니다. 'temp' 로 지었습니다.
Mychart.Name = "temp"

 

그리고 현재 시티의 모든 그림을 순환하면서

For Each Pic In ActiveSheet.Pictures

 

그림을 선택하고
  Pic.Select

 

그림의 가로,세로크기를 일단 저장합니다.(뒤에 이 값을 다시 쓸겁니다.)
  oldwidth = Pic.Width
  oldheight = Pic.Height

 

그림의 가로세로 크기를 원래대로 되돌립니다.

(엑셀에 보여지는 비율 및 크기로 저장 시 아래 문구를 삭제하셔야 합니다.)
  Selection.ShapeRange.LockAspectRatio = msoTrue
  Selection.ShapeRange.ScaleHeight 1, msoTrue, msoScaleFromTopLeft

 

그림의 클립보드에 카피하고요.
  Pic.Copy

 

그림을 저장 시 앞셀의 내용으로 저장하게 됩니다.

따라서 지금 그림이 위치한 셀의 위치는  Pic.TopLeftCell.Address 로 가져오고요.그 앞의 셀이므로 오프셋을 아래처럼 Offset([0], [-1])을 주면 앞 셀의 내용을 가져오게 됩니다.

  picname = Range(Pic.TopLeftCell.Address).Offset([0], [-1])

 

차트개체의 크기를 그림의 가로,세로 크기로 수정합니다.
  Mychart.Width = Pic.Width
  Mychart.Height = Pic.Height

 

여기까지 실행을 하시면

 

 

 

1에 보시는 것처럼 박지성의 사진이 원래 크기대로 돌아갔구요.

2에 보시는 것처럼 차트개체의 크기가 그림의 크기와 같아진 것을 볼 수 있습니다.

 

그리고 차트개체를 활성화 한 다음

  ActiveSheet.ChartObjects("temp").Activate

 

붙여넣기를 하면 차트개체에 사진이 표시되게 됩니다.
  ActiveChart.Paste

 

이 상태에서 차트개체를 저장하게 되면 사진이 저장되게 됩니다.
  ActiveChart.Export Filename:="e:\사진\" + picname + ".jpg", filtername:="jpg"

 

다시 사진은 원래 크기대로 되돌려야 됩니다.

사진을 다시 선택하고
  Pic.Select

 

사진의 가로,세로 크기를 다시 지정해줍니다.
  Selection.ShapeRange.LockAspectRatio = msoFalse
  Pic.Width = oldwidth
  Pic.Height = oldheight

Next

 

그림을 다 저장했으면 차트개체는 필요 없으므로 삭제해줍니다.

Mychart.Delete

 

실행 결과입니다.

 

 

 

그림이 잘 저장되었네요!!

 

엑셀파일도 같이 올려드립니다.

 

 

save.xlsm

0.02MB

 

궁금하신 사항이나 도움이 필요하시면 댓글 부탁드립니다.

 

감사합니다!!

---

Dim Mychart As ChartObject

Set Mychart = ActiveSheet.ChartObjects.Add(10, 10, 20, 20)
Mychart.Name = "temp"


For Each Pic In ActiveSheet.Pictures
    Pic.Select
    oldwidth = Pic.Width
    oldheight = Pic.Height
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
    Pic.Copy
    
    picname = Range(Pic.TopLeftCell.Address).Offset([0], [-1])
    Mychart.Width = Pic.Width
    Mychart.Height = Pic.Height
    ActiveSheet.ChartObjects("temp").Activate
    ActiveChart.Paste
    ActiveChart.Export Filename:="e:\\사진\\" + picname + ".jpg", filtername:="jpg"
    Pic.Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Pic.Width = oldwidth
    Pic.Height = oldheight
    
Next
Mychart.Delete