온라인 이미지를 다운로드하여 아래로 이어 붙인 상품 이미지 일괄 생성

XLS+VBA 2024. 2. 14. 23:53

관련: 지식인1 , 지식인2

 여러 개의 URL주소의 이미지를 동일한 크기로 리사이즈(640X640)하여 또는 동일한 가로사이즈(640px)로 조절하여  하나의 긴 세로 이미지로 합쳐서 D:\E\대표 폴더에 원하는 이름으로 저장하는 매크로 만들수 있는지요?

 

 

시트에 이미지 URL과 저장할 이미지 파일명은 아래와 같이 입력합니다.

 

 

특히 엑셀에서 개체를 그림으로 저장하는 것에 약간의 난관이 있었습니다.

​

1. 일단 온라인 파일을 다운로드 하는 두 가지 코드입니다.

URLDownloadToFile 이라는 API를 이용하면 간단합니다. 간혹 티스토리 등에서 바이러스로 인식하기도 합니다.

#If VBA7 Then
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" _
        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 #Else
    Declare Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" _
        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Sub Test()
    URLDownload( "https://www.site.com/img/apple.jpg","C:\Some\apple.jpg")
End Sub

Sub URLDownload(myURL As String, DownloadFile As String)
    Dim LocalFilename$
    
    'DownloadFile$ = "someFile.ext" 'here the name with extension
    'Url$ = "http://some.web.address/" & DownloadFile 'Here is the web address
    LocalFilename$ = "C:\Some\Path" & DownloadFile
    'here the drive and download directory
    MsgBox "Download Status : " & URLDownloadToFile(0, myURL, LocalFilename, 0, 0) = 0
End Sub
 
 
아래와 같이 XMLHttp를 이용해서 직접 받아서 저장할 수도 있습니다.
 
Sub DownloadFile(myURL As String, saveFILE As String)

    'myURL = "https://YourWebSite.com/?your_query_parameters"
    'saveFILE = "C:\file.csv"
    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.send
    
    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Dim oStream As Object
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile saveFILE, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

End Sub

 

 

2. 화면 구성

​

Sheet1 에 URL주소와 저장할 파일명을 아래와 같이 입력한다고 가정합니다.

온라인 이미지들을 다운로드해서 오른쪽에 있는 이미지 파일명으로 합쳐서 저장하기로 합니다.

​

​

3. 처리 순서

  1.  셀을 순환하면서 이미지들을 하나씩 다운로드( D:\E\대표 폴더에 )
  2.  다운로드한 이미지를 임시로 Sheet2 에 이미지를 삽입 (640*640px 사이즈)
  3.  기존 이미지 높이 값을 누적해서 바로 아래에 삽입
  4.  새로운 Target 이미지가 나오면 지금까지의 이미지를 그룹으로 묶음
  5.  그룹을 그림으로 복사
  6.  그룹이미지와 크기가 같은 빈 차트를 생성
  7.  차트에 복사한 그룹이미지 붙여넣기
  8.  차트를 최종 이미지로 저장
  9.  그룹 이미지와 차트를 삭제
  10.  다음 셀(이미지 주소)로 계속 순환

 

 

​

4. 문제점들(난관들)

​

1) 엑셀은 그림 개체를 이미지 파일로 바로 저장하는 VBA 기능을 제공하지 않음

==>> 차트를 생성해서 붙여넣고 차트를 이미지 파일로 저장

​

2) 차트에 그룹이미지를 그냥 붙여넣으면 상단에 여백이 생기거나 그림 테두리에 윤곽선 여백이 나타남(파워포인트와 달리 엑셀 차트 이미지 저장에서 가장 큰 문제거리)

==>> 그룹.Copy 대신 그룹.CopyPicture이용. 인수로 1, 2 를 넘겨서 벡터가 아니라 비트맵으로 복사

​

3) 차트를 만드는 대신 파워포인트 개체를 생성해서 슬라이드에 그룹 이미지를 붙여넣고 이미지 파일로 저장할 수도 있음. 이 경우 그림 사이즈도 지정 가능.

​

​

5. 실행 결과

​

> 2개 이미지가 합쳐져서 640*1280 사이즈 이미지가 생성됨.

> 4개 이미지가 합쳐져서 640*2560 사이즈 이미지가 생성됨.

​

6. 전체 코드

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" _
        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 #Else
    Declare Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" _
        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Const TargetPath = "D:\E\대표"
Const TargetSize = 640

Sub MergeOnlineImages()

    Dim Sht As Worksheet, tSht As Worksheet
    Dim Rng As Range, lastCell As Range, RngP As Range
    Dim i As Integer, j As Integer, SPR As String
    Dim Target As String, Temp As String
    Dim shp As Shape, gShp As Shape, tt As Single, ww As Single, hh As Single
    Dim cht As ChartObject, arr() As Long
    
    SPR = Application.PathSeparator
    Set Sht = Worksheets("Sheet1")          'ActiveSheet
    Set tSht = Worksheets("Sheet2")
    If tSht Is Nothing Then MsgBox "Temporary 'Sheet2' not found.": Exit Sub
    
    Set lastCell = Sht.Cells(Sht.Rows.Count, "C").End(xlUp) 'C열 맨 아래셀
    If lastCell.Row < 5 Then Exit Sub
    
    For Each Rng In Sht.Range(Sht.Range("C5"), lastCell)
        
        '새로운 대상 이미지
        If InStr(Rng.Offset(, 1), ".") > 1 Then
            Target = Rng.Offset(, 1)
            i = 0
        End If
        
        i = i + IIf(Len(Rng) > 4, 1, 0)
        ReDim Preserve arr(i)
        
        '진행률 상태바에 표시
        Application.StatusBar = "Downloading  " & Rng.Row - 4 & "/ " & lastCell.Row - 4 & " (" & _
                                CInt(i * 100 / (lastCell.Row - 4)) & " %) ..."
                                
        '사진 다운로드
        If Len(Dir(TargetPath, vbDirectory)) = 0 Then MkDir TargetPath
        Temp = TargetPath & SPR & Format(i, "000") & "_" & Mid(Rng, InStrRev(Rng, "/") + 1)
        URLDownloadToFile 0, Rng, Temp, 0, 0
        
       '사진 삽입
        ww = TargetSize * 0.75       '1px = 0.75pt, 1pt = 1.3333px
        hh = ww
        Set shp = tSht.Shapes.AddPicture(Temp, msoFalse, msoTrue, 0, tt, ww, hh)
        shp.Name = "Img_" & i
        tt = tt + hh
        arr(i - 1) = shp.ZOrderPosition
        DoEvents
        Kill Temp   'delete temp image
        
        '누적 이미지 저장
        If Target <> "" And InStr(Rng.Offset(1, 1), ".") > 0 Or Rng.Row = lastCell.Row Then
            
            'make a group with the images
            Set gShp = tSht.Shapes.Range(arr).Group
            '// should paste as 'Bitmap.' If not, 1-px-outline appears around each picture
            gShp.CopyPicture 1, 2   ' xlScreen/xlPrinter, xlBitmap(2)/xlPicture(-4147)=Vector
            DoEvents
            
            Set cht = tSht.ChartObjects.Add(0, 0, ww, tt)
            'cht.Chart.ChartArea.Clear
            cht.ShapeRange.Fill.Visible = msoFalse
            cht.ShapeRange.Line.Visible = msoFalse
            cht.Select      '// Need to select the chart before pasting
            cht.Chart.Paste
            DoEvents
            
            'export the chart image
            cht.Chart.Export TargetPath & SPR & Target
            j = j + 1
            
            '초기화
            tt = 0: i = 0
            gShp.Delete
            cht.Delete
        End If
        'If Rng.Row > 6 Then Exit Sub
    Next Rng
    
    Application.StatusBar = "Total '" & j & "' file(s) was(were) saved."
    Application.OnTime Now + TimeSerial(0, 0, 5), "StatusBarOff"   '5초 후 메시지 지우기
    
End Sub

Function StatusBarOff()
    Application.StatusBar = False
End Function

 

7. 기타

​

> 상태 표시줄에 진행 상황을 표시합니다.

​

> 아래 값은 변경 가능

Const TargetPath = "D:\E\대표"

Const TargetSize = 640

​

​

8. 샘플 파일

​

예제1.xlsm
0.03MB

 

9. 수정본

 

원본 이미지의 가로:세로 비율을 유지하면 가로 사이즈만 640px로 동일하게 조절해서 이미지를 세로로 합치고 싶은 경우는 아래처럼 사진 삽입 부분의 수정이 필요합니다.

 

'사진 삽입
        ww = TargetSize * 0.75       '1px = 0.75pt, 1pt = 1.3333px
        Set shp = tSht.Shapes.AddPicture(Temp, msoFalse, msoTrue, 0, tt, ww, ww)
        '일단 그림 삽입 후 원본 가로:세로 비율로 재조정
        shp.ScaleWidth 1, msoTrue
        shp.ScaleHeight 1, msoTrue
        shp.LockAspectRatio = msoTrue
        shp.Width = ww  '세로 높이는 자동 조절됨
        hh = shp.Height
        shp.Name = "Img_" & i
        tt = tt + hh

 

ScaleWidth 1 과 ScaleHeight 1 로 원본 사이즈로 바꾼 후

가로:세로 비율을 유지한 채로 가로 넓이를 640으로 맞추면

세로 높이는 자동적으로 설정됩니다. 저장경로는 'E:\E\대표' 입니다.

 

예제2.xlsm
0.02MB

 

 

저작자표시 비영리 동일조건

'XLS+VBA' 카테고리의 다른 글

모든 행 값을 랜덤으로 섞기  (1) 2024.03.01
네이버 API를 이용한 '네이버 쇼핑' 검색 결과 수집  (0) 2024.02.20
엑셀에서 실시간 유튜브 구독자수 모니터링  (0) 2024.02.15
엑셀에서 ppt의 특정 페이지를 링크  (0) 2023.11.21
juso.go.kr이용 한글주소 ↔ 영어주소 변환  (0) 2023.06.15
영어단어와 뜻 OCR인식 결과 정리하기  (0) 2023.06.12
PPT파일 순서를 확인/정렬해서 합치기  (0) 2023.02.11
구글 이미지 검색 결과 가져오기  (0) 2023.02.01

티스토리툴바