재능iN 월간최다 재능기부 회원

  • 필농군 채택재능수 (64)
  • ABCDE토렌트 채택재능수 (2)
  • 그까이꺼뭐라고 채택재능수 (1)
  • 남자는허뤼 채택재능수 (1)
  • 페이마임 채택재능수 (1)
  • 루비콘 채택재능수 (1)
  • ㄱㄴㅇ라ㅓ니 채택재능수 (1)
  • 深海 채택재능수 (1)
  • 서슴없이고고 채택재능수 (1)
       
    [문서작업]

    [엑셀 매크로] 사진 여러장 입력

    글쓴이 : 오말우왕자 날짜 : 2019-10-29 (화) 23:12 조회 : 1028

    아래의 코딩은 인터넷으로 검색해서 사용중인데


    한번에 사진 파일 한장씩만 넣을 수 있네요.


    이걸 한번에 여러장의 선택해서 삽입할 수 있는 방법은 없을까요?



    ================================================================================================================

    Sub ImportPictureFile()

      Dim strFile As String

        Dim sht As Worksheet

        Dim pic As Object

        Application.ScreenUpdating = True

        Set sht = ActiveSheet

      

        

        strFile = Application.GetOpenFilename(filefilter:="모든파일(*.*),*.*", _

            Title:="삽입할 그림을 선택하세요"

        If strFile = "False" Then

            MsgBox "아무 그림도 선택되지 않았습니다"

            Exit Sub

        End If


        Dim obj As Object

        Dim rnginsert As Range


        Set obj = sht.Pictures.Insert(strFile)


        Set rnginsert = Selection


        With obj

            .ShapeRange.LockAspectRatio = msoFalse

            .Top = rnginsert.Top

            .Left = rnginsert.Left

            .Height = rnginsert.Height

            .Width = rnginsert.Width

        End With

    End Sub

    ================================================================================================================

    위의 매크로로 작업하면 원본 사진의 경로나 파일명이 변경되면 엑셀 파일에서 수정이 안되는건 알고 있습니다.

    이부분은 수정없이 현상태에서 한번에 삽입할 수 있는 파일의 갯수를 여러장 삽입할 수 있으면 합니다.

    요청자가 자신의 3000포인트를 걸었습니다. 요청이 채택되면 1500포인트를 드립니다.

    나도익명 2019-10-30 (수) 01:14
    선택한 폴더에 있는 JPG 사진 모두 불러오기

    Sub AddImageFile()

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "작업할 폴더를 선택하세요."
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            selFolder = .SelectedItems(1) & "\"
        End If
    End With

    Filename = Dir(selFolder & "\*.JPG")

    If Filename = "" Then
        MsgBox "삽입할 사진이 없습니다."
        Exit Sub
    Else
        On Error GoTo Err_Image
        While Filename <> ""
            Set Picture = ActiveSheet.Shapes.AddPicture(Filename, False, True, Selection.Left, Selection.Top, -1, -1)
            Picture.LockAspectRatio = msoTrue
            ActiveCell.RowHeight = Picture.Height
            ActiveCell.Offset(1, 0).Select ' 아래 셀로 이동
            Filename = Dir()
        Wend
    End If

    Set Picture = Nothing
    Exit Sub

    Err_Image:
        If Err <> 0 Then MsgBox Err.Description

    End Sub
         
           
    글쓴이 2019-10-30 (수) 01:35
    방금 테스트 해봤는데요.

    삽입할 사진이 없습니다. 라고 메시지 나옵니다.
    -------------------------
    아 지정한 파일이 없습니다. 라고 나오네요.
    나도익명 2019-10-30 (수) 01:48
    저도 테스트 해보고 올린겁니다. 파일들 확장자가 어떻게 되나요?
         
           
    글쓴이 2019-10-30 (수) 01:52
    xlsm 입니다.

    이미지 파일은 jpg  이구요
         
           
    글쓴이 2019-10-30 (수) 01:58
    혹시 폴더 앞에 # 가 붙어 있거나 폴더명에 공백이 있는 경우도 테스트 해봐 주실 수 있으신가요?

    예를 들면

    #사진 목록 이런식의 폴더명입니다.

    현재 작업중이 경로에서 그렇게 네이밍된 폴더가 있는데 그것때문에 그런게 아닌가 싶네요.
         
           
    글쓴이 2019-10-30 (수) 02:11
    * 비밀글 입니다.
    나도익명 2019-10-30 (수) 11:46
    저는 루트에서 테스트 했는데..
    파일이름 앞에 경로명이 빠졌었네요.

    Sub AddImageFile()

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "작업할 폴더를 선택하세요."
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            selFolder = .SelectedItems(1) & "\"
        End If
    End With

    Filename = Dir(selFolder & "*.JPG")

    If Filename = "" Then
        MsgBox "삽입할 사진이 없습니다."
        Exit Sub
    Else
        On Error GoTo Err_Image
        While Filename <> ""
            Set Picture = ActiveSheet.Shapes.AddPicture(selFolder & Filename, False, True, Selection.Left, Selection.Top, -1, -1)
            Picture.LockAspectRatio = msoTrue
            ActiveCell.RowHeight = Picture.Height
            ActiveCell.Offset(1, 0).Select ' 아래 셀로 이동
            Filename = Dir()
        Wend
    End If

    Set Picture = Nothing
    Exit Sub

    Err_Image:
        If Err <> 0 Then MsgBox Err.Description

    End Sub
         
           
    글쓴이 2019-11-01 (금) 00:02
    도움 항상 감사합니다. ^^
    나도익명 2019-10-30 (수) 13:03
    폴더 안에서 선택한 파일만 삽입

    Sub AddImageFile()
        Filename = Application.GetOpenFilename(FileFilter:="모든 파일,*.*", Title:="삽입할 그림을 선택하세요", MultiSelect:=True)
        If Filename = False Then Exit Sub
        On Error GoTo Err_Image
        For i = 1 To UBound(Filename)
            Set Picture = ActiveSheet.Shapes.AddPicture(Filename(i), False, True, Selection.Left, Selection.Top, -1, -1)
            Picture.LockAspectRatio = msoTrue
            ActiveCell.RowHeight = Picture.Height
            ActiveCell.Offset(1, 0).Select ' 아래 셀로 이동
        Next i
        Set Picture = Nothing
        Exit Sub

    Err_Image:
        If Err <> 0 Then MsgBox Err.Description

    End Sub
         
           
    글쓴이 2019-10-30 (수) 20:26
    If Filename = False Then

    이 구문에서 에러가 생깁니다.
    나도익명 2019-10-30 (수) 20:38
    전 2010 입니다만 어떤 버전을 사용하시는지...

    아래처럼 해보세요.
    If Filename = "" Or Filename= "False" Then Exit Sub

    또는
    If VarType(Filename) = vbBoolean Then Exit Sub
         
           
    글쓴이 2019-10-31 (목) 18:14
    2016 사용합니다.

    첫번째거로 수정하면

    If Filename = "" Or Filename= "False" Then

    이 구문에서 에러가 나오고

    두번째거로 수정하면

    인수의 개수나 속성 지정이 잘못되었습니다.

    라는 팝업상자가 나오네요.
    나도익명 2019-10-31 (목) 21:02
    제가 2016에서 테스트 해보니까 아래 두 개 다 잘 되네요.
    아래 구문을 넣는 이유는 파일을 선택하지 않고 취소했을 때 종료하기 위함입니다.

    If VarType(FileName) = 11 Then Exit Sub

    If VarType(Filename) = vbBoolean Then Exit Sub
         
           
    글쓴이 2019-10-31 (목) 23:56
    네 도움 주셔서 감사합니다.
         
           
    글쓴이 2019-11-01 (금) 00:02
    위에 제가 복사한 코드는

    사진의 크기가 셀 크기에 맞도록 조정된 상태로 삽입되는데요.
    혹시 나도 익명님 엑셀 파일도 그렇게 작업이 가능한가요??

    그리고 엑셀 파일을 삽입을 할 때 원본에 영향이 없는 형태로 삽입되어 삽입되는 그림 파일의 갯수가 많거나 고화질의 이미지의 경우엔 엑셀 파일의 용량이 많이 증가가 되는데

    이또한 경로를 유지해서 원본이 삭제되면 표시할 수 없다는 메세지가 나오는 형태도 가능할까요?

    파일 용량이 비대해지는걸 방지해보려니 그 방법 밖에 없는것 같아요.

    도움 주시면 추가채택 또는 별도 포인트 선물을 드리겠습니다.
    나도익명 2019-11-01 (금) 06:19
    옵션 이름까지 넣은 것이니 위 답변처럼 빼도 됩니다.
    Sub AddImageFile()
        Filename = Application.GetOpenFilename(FileFilter:="모든 파일,*.*", Title:="삽입할 그림을 선택하세요", MultiSelect:=True)
        If VarType(Filename) = 11 Then Exit Sub
        On Error GoTo Err_Image
        For i = 1 To UBound(Filename)
            ActiveSheet.Shapes.AddPicture Filename:=Filename(i), linktofile:=msoTrue, savewithdocument:=msoFalse, Left:=Selection.Left, Top:=Selection.Top, Width:=Selection.Width, Height:=Selection.Height
            ActiveCell.Offset(1, 0).Select ' 아래 셀로 이동
        Next i
        Exit Sub

    Err_Image:
        If Err <> 0 Then MsgBox Err.Description

    End Sub

    =====

    위 구문이 오류나면 아래로 해보세요.
    ActiveSheet.Shapes.AddPicture(Filename:=Filename(i), linktofile:=msoTrue, savewithdocument:=msoFalse, Left:=Selection.Left, Top:=Selection.Top, Width:=Selection.Width, Height:=Selection.Height)

    =====

    linktofile 는 파일이름을 연결하는 옵션이고
    savewithdocument 는 사진파일을 포함하여 저장하는 옵션이니
    서로 반대로 하면 됩니다.
       

    (구)포토샵요청
    재능iN 재능상태  |   | 
     
    번호 재능분류 제목 글쓴이 상태 포인트 날짜 조회
    [공지사항] ※ 재능iN 게시판 이용안내 (포토샵요청 게시판 재능iN 게시판으로 변경) (8) eToLAND
    0 03-22
    1333 [기타요청] 배우 이름좀 찾습니다. 스샷첨부 또웃다또
    1000 05-29 126
    1332 [사주/운세/손금] 필농군님 손금및 사주 부탁드립니다. 스샷첨부 옴마나
    10000 05-29 58
    1331 [사주/운세/손금] 필농군님 사주 풀이좀 부탁드립니다. 아카니시
    10000 05-29 28
    1330 [] 필농군님 사주 부탁드립니다. (3) 스샷첨부 후파파
    5000 05-29 42
    1329 [사주/운세/손금] 아이이름 한자 추천 부탁드립니다. (2) 농약같은가시…
    3000 05-29 80
    1328 [사주/운세/손금] 필농군님 사주 부탁드립니다 (1) 별사탕7
    5000 05-28 71
    1327 [사주/운세/손금] 필농군님 사주 좀 부탁드립니다. (3) eachwa
    10000 05-28 59
    1326 [사주/운세/손금] 필농군님 사주좀 부탁드립니다 (1) RNtm
    5000 05-28 65
    1325 [디자인요청] 글씨 좀 지워주세요 (2) 스샷첨부 집샌물샌
    5000 05-28 62
    1324 [디자인요청] 이미지 이용하요 스티커 만들 이미지 요청 합니다.~ 스샷첨부 Inhoopapa
    2500 05-28 62
    1323 [디자인요청] 증명사진 용 포토샵 부탁드립니다. (1) 쿠쿠름
    1644 05-28 77
    1322 [디자인요청] 길드마크 이미지 제작 (3) 스샷첨부 nsyls
    10000 05-28 98
    1321 [디자인요청] 증명서 스캔이 삐뚤게 되어서 각도 조정 요청드립니다. (3) Alexei
    3000 05-27 225
    1320 [디자인요청] 전자직인 이미지 제작요청 (6) 스샷첨부 nemio
    2000 05-27 124
    1319 [재능나눔] 기타요청 (2) 묵고죽자
    1000 05-26 105
    1318 [사주/운세/손금] 필농군님 사주 확인 부탁 드립니다 (3) 얄라차
    5000 05-26 97
    1317 [사주/운세/손금] 필농군님 사주 부탁드립니다 (2) auaaia
    15000 05-25 79
    1316 [디자인요청] 그림에서 글자만 제거해주세요 (1) 스샷첨부 메롱이☆★☆
    1800 05-25 177
    1315 [사주/운세/손금] 필농군님 저도 사주 및 손금 부탁드립니다 (3) 스샷첨부 두리88
    10000 05-25 80
    1314 [사주/운세/손금] 필농군님 사주 부탁 드립니다. (4) scolra
    8000 05-25 68
    1313 [사주/운세/손금] 필농군님 사주 부탁드립니다~! (2) 나이아라게
    5000 05-25 54
    1312 [사주/운세/손금] 필농군님 사주 부탁드립니다. (2) 스샷첨부 LSY22
    5000 05-25 152
    1311 [디자인요청] 사진에 나온 로고를 없애고 싶습니다 (2) 스샷첨부 핫초코한잔
    1000 05-23 367
    1310 [사주/운세/손금] 필농군님, 저도 사주 풀이 부탁드립니다. (2) 울리히케슬러
    10000 05-23 118
    1309 [사주/운세/손금] 필농군님 사주 부탁 드려요 (1) 환일체
    3000 05-23 62
    1308 [사주/운세/손금] 필농군님 저도 사주 부탁 드려요 (2) 아델
    1200 05-23 89
    1307 [사주/운세/손금] 필농군님 저도 사주 부탁드려봅니다 (2) 센치로
    5000 05-23 70
    1306 [사주/운세/손금] 저도 사주 봐주세요.. (4) 러블리러브
    10000 05-22 191
    1305 [사주/운세/손금] 필농군님 손금 및 사주 부탁드립니다 (4) 스샷첨부 코비브랄리언…
    10000 05-22 119
    1304 [사주/운세/손금] 필농군님 저의 사주도 한 번 부탁드려봅니다 (2) 스샷첨부 위기는위기일…
    5000 05-21 140
     1  2  3  4  5  6  7  8  9  10  다음