외한은행의 환율표를 긁어오는 VBA코드입니다.

 

요즘 DB의 과부하를 막기 위해 HTML소스를 암호화한다든가해서..

웹쿼리로 가져올 수 없는 부분에 대한 해결책이 될 수 있을 것 같습니다.

 

지금은 졸리니까..

 

내일부터 천천히 소스를 뒤집어봐야겠습니다. ^-^;;

 

지금은 잘 안되지만.. 소스를 분석해보는것만으로도 큰 도움이 될 것 같습니다...

그래서 일단 연구과제 카테고리에 남겨놨습니다. ^-^;;

 

출처 : http://www.excellove.com/tn/board.php?board=qqqNewQnA&search=Explorer&shwhere=tbody&command=body&no=27377

 

관련 코드의 원천은 아래 사이트에 있다지요..

http://www.dailydoseofexcel.com/archives/2006/11/29/html-tables/

 

 

관련 파일 다운 받기 : 2009_1_24_web_page_data_control_Book3.xls

 

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

내용추가 : 2011.12.04

VBA_웹페이지텍스트잘라오기_20100707-1.xls

 


'### ============================================================= ###


Option Explicit


Sub getXeMemberInfo()

    Dim strURL As String

    strURL = "http://abyul.com/"

    getTextFromWeb (strURL)

End Sub


Sub getTextFromWeb(strURL As String)

    Dim i As Integer

    Application.ScreenUpdating = False

    Application.Calculation = xlManual

    Dim ie As Object, objDoc As Object

    Set ie = CreateObject("internetexplorer.application")

    ie.Navigate strURL

    Do

        If ie.ReadyState = 4 Then

            ie.Visible = False

            Exit Do

        Else

            DoEvents

        End If

    Loop

    Set objDoc = ie.Document

    Dim v As Variant

    v = Split(objDoc.body.innertext, Chr(10))

    Sheets.Add

    For i = LBound(v) + 3 To UBound(v) - 1

        ActiveCell.Offset(i).Value = v(i)

    Next i

    ie.Quit

    Set objDoc = Nothing

    Set ie = Nothing

    Beep

    Application.ScreenUpdating = True

    Application.Calculation = xlAutomatic

End Sub



'### ============================================================= ###


'### From. http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=10402&docId=64441065&qb=7JeR7IWAIOybuey/vOumrA==&enc=utf8&section=kin&rank=22&search_sort=0&spq=0&sp=3&pid=gXkl4F5Y7ZlssZUXdXwssc--108648&sid=TubgItTB5k4AAEXuGY4


Private Sub Command1_Click()

Command1.Enabled = False

MousePointer = vbHourglass

DoEvents

Winsock1.RemoteHost = "sol-a.com"

Winsock1.RemotePort = 80

Winsock1.Connect

End Sub


Private Sub Winsock1_Close()

Command1.Enabled = True

MousePointer = vbDefault

End Sub


Private Sub Winsock1_Connect()

Dim Cmd$, URL$


URL = "http://www.sol-a.com/index.htm"

Cmd = "GET " & URL & " HTTP/1.0" & vbCrLf & "Accept: */*" & _

vbCrLf & "Accept: text/html" & vbCrLf & vbCrLf


Winsock1.SendData Cmd

End Sub


Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

Dim Data$

Winsock1.GetData Data, vbString

Text1.Text = Text1.Text & Data

End Sub


'### ============================================================= ###


'[출처] Read HTML Source- InternetReadFile (VB, Excel VBA, .NET & SQL) |작성자 서은아빠

'From. http://cafe.naver.com/xlsvba/6


Option Explicit


Private Const INTERNET_OPEN_TYPE_DIRECT = 1

Private Const INTERNET_OPEN_TYPE_PROXY = 3

Private Const INTERNET_FLAG_RELOAD = &H80000000


Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long

Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer

Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long


'=====================================================================================================

' Function    : GetHTMLSource

' Author      : 서은아빠(http://cafe.naver.com/xlsvba/6)

' DateTime    : 2007-08-08 14:09

' Purpose     : 지정된 URL의 HTML소스를 읽어온다.

'               INET등의 외부 컨트롤을 이용하지 않고 HTML소스를 읽어오며

'               메뉴프레임정도의 HTML문서의 구성등을 표현하는 페이지의 소스를 읽어올때 적합하다.

' Param       : strURL - 해당 URL

'               lngBufSize  - HTML소스를 받을 Buf사이즈

' Return      : 성공 여부 (Boolean)

'=====================================================================================================

Private Function GetHTMLSource(ByVal strURL As String, Optional lngBufSize As Long = 1024) As Boolean

 Dim hOpen  As Long

 Dim hURL   As Long

 Dim lngRet As Long

 Dim strBuf As String

   

   GetHTMLSource = False

   

   '## 공간 할당

   strBuf = String(lngBufSize, Chr(0))

   

   '## 인터넷 연결(INTERNET_OPEN_TYPE_DIRECT)

   hOpen = InternetOpen(ThisWorkbook.Name, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)

   

   '## 지정된 URL연결

   hURL = InternetOpenUrl("hOpen, strURL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)

   

   If hURL Then

       

       '## 지정된(lngBufSize) 사이즈만큼 해당 URL의 HTML소스를 읽어서 Buf에 담는다.

       Call InternetReadFile(hURL, strBuf, lngBufSize, lngRet)

       

       '## 핸들을 초기화한다.

       Call InternetCloseHandle(hURL)


       '## 공간할당시 담았던 문자를 제거한다.

       strBuf = Replace(strBuf, Chr(0), "", , , vbTextCompare)

       

       Debug.Print strBuf

       

       GetHTMLSource = True

       

   End If

   

   Call InternetCloseHandle(hOpen)

End Function


Sub Test()

   Call GetHTMLSource("http://examo.co.kr/old_index.html")

End Sub


'### ============================================================= ###


'### ============================================================= ###


'### ============================================================= ###


'### ============================================================= ###


'### ============================================================= ###


'### ============================================================= ###




profile