| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):2010
* 아래줄에 질문을 작성하세요 >>
==============[빨강색님 글에 대한 답변입니다]==============
그림파일이 많으면 시트를 계속추가하여 그림을 삽입합니다.
Sub Pictures_Insert()
Dim wst As Worksheet
Dim oPic As Picture
Dim sPath As String, sFn As String
Dim rPic As Range
Dim iCnt As Integer
Dim iRow As Integer, iCol As Integer
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
Else
sPath = .SelectedItems(1) & Application.PathSeparator
End If
End With
sFn = Dir(sPath & "*.jpg") ' 폴더내 그림파일 : *.gif; *.jpg; *.jpeg
Set wst = ActiveSheet
wst.Pictures.Delete
iRow = 6: iCol = 1: iCnt = 0
Do While sFn <> ""
If iCnt > 3 Then
' 현재시트의 양식을 추가하기 위함
wst.Copy After:=Sheets(Sheets.Count)
Set wst = ActiveSheet
On Error Resume Next
wst.Name = "S" & (Val(Mid(wst.Previous.Name, 2)) + 1)
On Error GoTo 0
wst.Pictures.Delete
iRow = 6: iCol = 1: iCnt = 0
End If
Set oPic = wst.Pictures.Insert(sPath & sFn)
iCnt = iCnt + 1
Set rPic = wst.Cells(iRow, iCol).MergeArea
With oPic
.ShapeRange.LockAspectRatio = msoFalse
.Left = rPic.Left + 4
.Top = rPic.Top + 6
.Width = rPic.Width + 6
.Height = rPic.Height + 9
End With
sFn = Dir()
If iCnt Mod 2 = 1 Then
iCol = iCol + 3
Else
iRow = iRow + 2
iCol = 1
End If
Loop
Application.ScreenUpdating = True
End Sub
사진자동삽입 답변정말 감사합니다. 덕분에 훨씬 수월하게 작업하고 있습니다 ㅠ 욕심이지만 사진크기도 가로9.16 세로6.88 고정으로 수정이 가능할까요 ?? 부탁드립니다 ㅠㅠ |
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
