[엑셀vba] 인터넷 익스플로러 컨트롤하기 4(이미지 다운로드)

사이트에서 올라온 이미지를 다운로드하여 저장해보자.

이미지는 저작권 문제가 있을 수 있으므로 무료 이미지 사이트를 찾아보았다.

• 픽사베이

https://pixabay.com/ko/

무료로 이미지를 받을 수 있는 사이트이다.

내 매크로를 테스트 할 수 있는 좋은 곳인거 같다.

감사염

 

• 매크로 동작 순서

1. 매크로 실행 !

2. 픽사베이 사이트 접속

3. 1페이지에 있는 이미지 저장

4. 잠시 후 저장된 폴더를 본다. (내 컴 기준 2초도 안걸림)

5. 만족스러워 한다.

6. 끝

 

• 매크로 실행 영상

이미지가 저장되었다 ! 오올 ㅋㅋ

• 코드 구성

코드는 크게 5가지로 구분된다.

1. 폴더 생성

2. 다운로드할 파일 url 추출

3. 파일 이름 정하기

4. 파일 다운로드 하기

5. ??

4가지 였나보다.

 

 

 

1. 폴더 생성 코드

    Dim Desktop_Oj As Object
    Dim Desktop_Path As String 
 
    Set Desktop_Oj = CreateObject("wscript.shell")
    '오브젝트 생성
 
    Desktop_Path = Desktop_Oj.specialfolders("desktop") & "\save_img"
    '바탕화면 경로 추출
 
    If Len(Dir(Desktop_Path, vbDirectory)) = 0 Then 
    '바탕화면에 save_img 폴더가 없으면 아래 구문 실행
        MkDir Desktop_Path
        MkDir Desktop_Path & "\" & Folder_Name
    ElseIf Len(Dir(Desktop_Path & "\" & "pixabay", vbDirectory)) = 0 Then
    'save_img 폴더가 존재하고 그 안에 pixaby 폴더없으면 아래 구문 생성
        MkDir Desktop_Path & "\" & Folder_Name
    End If

다 필요없고 폴더 생성하는건 mkdir 함수만 알면 된다.

Mkdir "폴더 생성 경로"

ex. mkdir "c:\test" c드라이브에 test 폴더 생성

 

 

2. 다운로드 할 파일 url 추출

    Dim IE As InternetExplorer '인터넷 오브젝트 변수
    Dim HTMLDoc As IHTMLDocument 'HTML 소스 담을 변수
    Dim Tag_Info As IHTMLElement '태그 정보 담을 변수
    Dim URL As String '주소 담을 변수    
 
    Set HTMLDoc = IE.Document
    '불러온 웹 페이지 소스코드 저장
 
    For Each Tag_Info In HTMLDoc.getElementsByTagName("img")
    '사이트를 분석하여 이미지의 URL을 가지고 있는 태그 찾음
    'img 태그에는 url말고 다양한 정보가 들어있으므로 내가 필요한 url만 추출하도록 가공해야함
    '아래 작업으로 이미지 url 주소만 추출함
 
        If InStr(1, Tag_Info.outerHTML, "data-lazy") Then
            URL = Tag_Info.outerHTML
            URL = Mid(URL, InStr(1, URL, "data-lazy=") + 11)
            URL = Mid(URL, 1, InStr(1, URL, Chr(34)) - 1)
        Else
            URL = Tag_Info.outerHTML
            URL = Mid(URL, InStr(1, URL, "src=") + 5)
            URL = Mid(URL, 1, InStr(1, URL, Chr(34)) - 1)
        End If
     Next

 

 

 

 

3. 파일 이름 정하기(feat. 런타임 3004)

Dim File_Name As String '파일 이름 변수
 
    File_Name = Folder_Name & "_" & Date & "_" & Format(Time, "hh-mm-ss") & "_" & i & ext
    'Folder_name에는 사이트 이름이 저장된 상태
    'date 오늘 날짜
    'format(time,"hh-mm-ss")  현재 시간 을 00-00-00 식으로 나타내줌, 일반적인 time을 넣게되면
    '오전 03:12:43 이렇게 나와서 파일 저장이 안됨, 왜냐 파일이름에 특수문자는 제한적으로 쓸 수 
    '있기때문에 포맷형식을 바꿔줘야 한다.
    'i 파일 하나 저장할 때마다 더하기 1해줌
    'ext 파일 확장자가 저장되어 있는 변수

파일이름에 특수문자는 웬만하면 쓰지 말도록하자.

이걸 모르고 있다가 1시간동안 3004 런타임 오류만 엄청나게 봤네;

런타임 3004 오류

3004 런타임 오류가 발생 할 때 해결방법

1. 경로가 제대로 됬는지 확인한다. (특수문자 확인, 실제로 있는 경로인지 확인)

2. 파일 이름을 제대로 확인한다. (특수문자 확인)

 

 

 

 

4. (핵심) 파일 다운로드 하기

Dim Download_Go As Object '파일 다운로드 위한 변수
    Dim Download As Object '파일 다운로드 위한 변수
 
    Set Download = CreateObject("microsoft.xmlhttp")
 
    Download.Open "GET", "다운로드 할 url 주소", False
    Download.send
 
    If Download.Status = 200 Then '요청한 웹 페이지가 정상적으로 왔는지 체크
        Set Download_Go = CreateObject("adodb.stream")
        Download_Go.Open
        Download_Go.Type = 1
        Download_Go.write Download.responseBody
        Download_Go.SaveToFile "저장할 파일 경로 + 저장할 파일 이름 + 저장할 파일 확장자", 1
        Download_Go.Close
     End If

Download_Go.SaveToFile 에서 두번째 파라미터의 의미

1 = 덮어쓰지 않음

2 = 덮어쓰기

위 코드만 있어도 다운로드 가능하다.

 

 

 

 

5. 코드 전문

Sub 이미지저장하기()
 
 
    Dim IE As InternetExplorer '인터넷 오브젝트 변수
    Dim HTMLDoc As IHTMLDocument 'HTML 소스 담을 변수
    Dim Tag_Info As IHTMLElement '태그 정보 담을 변수
    Dim URL As String '주소 담을 변수
    Dim Desktop_Oj As Object '바탕화면 경로 구할때 쓰는 오브젝트
    Dim Desktop_Path As String '바탕화면 경로
    Dim Folder_Name As String '폴더 이름
    Dim File_Name As String '파일 이름
    Dim ext As String '파일 확장자 저장
    Dim i As Integer
    Dim Download_Go As Object '파일 다운로드 위한 변수
    Dim Download As Object '파일 다운로드 위한 변수
 
    URL = "https://pixabay.com/ko/images/search/"
 
 
    '사이트 이름으로 폴더이름을 정할 준비
    '------------------------------------------------------------------
    Folder_Name = Replace(URL, "https://", "")
    Folder_Name = Replace(Folder_Name, "http://", "")
    Folder_Name = Replace(Folder_Name, "www", "")
    i = InStr(1, Folder_Name, ".")
    Folder_Name = Left(Folder_Name, i - 1)
 
 
    '바탕화면에 이미지 저장할 폴더 생성위한
    '바탕화면 경로 추출, 바탕화면 경로\save_img
    '-----------------------------------------------------------------
    Set Desktop_Oj = CreateObject("wscript.shell")
 
    Desktop_Path = Desktop_Oj.specialfolders("desktop") & "\save_img"
    '폴더 없으면 생성
    If Len(Dir(Desktop_Path, vbDirectory)) = 0 Then
        MkDir Desktop_Path
        MkDir Desktop_Path & "\" & Folder_Name
    ElseIf Len(Dir(Desktop_Path & "\" & Folder_Name, vbDirectory)) = 0 Then
        MkDir Desktop_Path & "\" & Folder_Name
    End If
    '-----------------------------------------------------------------
    Desktop_Path = Desktop_Path & "\" & Folder_Name
    i = 1
    '인터넷 컨트롤 시작
    '-----------------------------------------------------------------
    Set IE = New InternetExplorer
 
    With IE
    .Silent = True
    .Visible = False
    .Navigate URL
    End With
 
    Wait_Browser IE
 
    ' 이미지 url 저장하는 코드
    '-----------------------------------------------------------------------------------
    Set HTMLDoc = IE.Document
    For Each Tag_Info In HTMLDoc.getElementsByTagName("img")
 
        If InStr(1, Tag_Info.outerHTML, "data-lazy") Then
            URL = Tag_Info.outerHTML
            URL = Mid(URL, InStr(1, URL, "data-lazy=") + 11)
            URL = Mid(URL, 1, InStr(1, URL, Chr(34)) - 1)
 
        Else
            URL = Tag_Info.outerHTML
            URL = Mid(URL, InStr(1, URL, "src=") + 5)
            URL = Mid(URL, 1, InStr(1, URL, Chr(34)) - 1)
        End If
    '--------------------------------------------------------------------------------------
 
        ext = "." & Mid(URL, InStrRev(URL, ".", -1) + 1)
        '이미지 확장자 추출
 
        File_Name = Folder_Name & "_" & Date & "_" & Format(Time, "hh-mm-ss") & "_" & i & ext
        '파일 이름 설정, '사이트 이름 + 오늘날짜 + 현재시간 + 확장자"
 
 
        '파일 다운로드 하고 저장하는 코드
        '--------------------------------------------------
 
        Set Download = CreateObject("microsoft.xmlhttp")
 
        Download.Open "GET", URL, False
        Download.send
 
        If Download.Status = 200 Then '요청한 웹 페이지가 정상적으로 불러왔는지 체크
 
        Set Download_Go = CreateObject("adodb.stream")
            Download_Go.Open
            Download_Go.Type = 1
            Download_Go.write Download.responseBody
            Download_Go.SaveToFile Desktop_Path & "\" & File_Name, 1 '실제로 저장하는 부분
            Download_Go.Close
        End If
        i = i + 1
        '-------------------------------------------------
    Next
 
End Sub

뭐가 이리 길어 ;

나중에 보기쉽게 줄여봐야겠다.