I am writing a macro for my users that grabs info off of a web page.
I want it to open a new worksheet with the info on it so that I can
work on it.

Below is my code it uses *ug* sendkeys and notepad to convert
documentelement.html into a text file is there a way of doing this
without using a program external to excel?

if not is there a way to close notepad without notepad asking if I want
to save?

Dim oIE As New SHDocVw.InternetExplorer
Dim sURL As String
Dim MyAppID As Long
sURL = "http://www.w3.org/2002/ws/" 'the page I'm loading is
'on the intranet but this is good for an
example

'open a new, visible IE window
Set oIE = New SHDocVw.InternetExplorer
oIE.Visible = false

'go to desired page
oIE.Navigate sURL

'wait for page to finish loading
Do Until oIE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop

MyAppID = Shell("notepad", 1)
DoEvents
On Error Resume Next
AppActivate "microsoft ex"
Application.DisplayAlerts = False

Worksheets("Webcopy").Delete

Application.DisplayAlerts = True
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Webcopy"
Range("A1") = oIE.Document.documentelement.innerhtml
Range("A1").Copy
AppActivate "Untit"
DoEvents
SendKeys "^v"
DoEvents
SendKeys "%ea"
DoEvents
SendKeys "^c"
DoEvents
SendKeys "% c"
DoEvents
ActiveSheet.Range("A1").ClearContents
ActiveSheet.Paste
oIE.Quit

Here's a function to download a URL to a text file. This is used in
production by several large banks - it's part of a larger library I wrote,
but this will set you on the right path...

As a friendly hint, avoid using the Internet Explorer libraries at all costs
- they suck!

--declares
'Constants
Private Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_SERVICE_FTP = 1
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const rDayZeroBias As Double = 109205# ' Abs(CDbl(#01-01-1601#))
Private Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# /
10000#

'Windows 32 bit API declarations
Private Declare Function InternetOpen Lib "wininet.dll" Alias
"InternetOpenA" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, _
ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal
dwFlags As Long) As Long

Private Declare Function InternetOpenUrl Lib "wininet.dll" 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

Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As _
Long, ByVal lpBuffer As String, ByVal dwNumberOfBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer

Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime
As Any, lpLocalFileTime As Any) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet
As Long) As Integer

Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias
"FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias
"FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String,
lpdwCurrentDirectory As Long) As Boolean

Private Declare Function InternetConnect Lib "wininet.dll" Alias
"InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal
nServerPort As Integer, _
ByVal sUsername As String, ByVal sPassword As String, ByVal lService As
Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long

Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal
dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean


'Private Const FTP_TRANSFER_TYPE_BINARY = &H2
'Private Const NO_ERROR = 0
'Private Const FILE_ATTRIBUTE_READONLY = &H1
'Private Const FILE_ATTRIBUTE_HIDDEN = &H2
'Private Const FILE_ATTRIBUTE_SYSTEM = &H4
'Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
'Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
'Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
'Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
'Private Const FILE_ATTRIBUTE_OFFLINE = &H1000
'Private Const INTERNET_FLAG_PASSIVE = &H8000000
'Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
'Private Const ERROR_NO_MORE_FILES = 18

'Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias
"InternetFindNextFileA" _
(ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long

'Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias
"FtpFindFirstFileA" _
(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal
dwContent As Long) As Long


'Private Declare Function InternetWriteFile Lib "wininet.dll" _
(ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToWite As Long, _
dwNumberOfBytesWritten As Long) As Integer

'Private Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileA" _
(ByVal hFtpSession As Long, ByVal sBuff As String, ByVal Access As Long,
ByVal Flags As Long, ByVal Context As Long) As Long

'Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

'Private Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
ByVal lpszFileName As String) As Boolean


'Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" _
Alias "InternetGetLastResponseInfoA" _
(ByRef lpdwError As Long, _
ByVal lpszErrorBuffer As String, _
ByRef lpdwErrorBufferLength As Long) As Boolean
'Private Declare Function FormatMessage Lib "kernel32" Alias
"FormatMessageA" _
(ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _
Arguments As Long) As Long
'Private Declare Function GetModuleHandle Lib "kernel32" Alias
"GetModuleHandleA" (ByVal lpLibFileName As String) As Long


Private Function CopyURLToFile(ByVal URL As String, ByVal FileName As
String) As Boolean
'Constants
Const strMethodName As String = "ETFSheetEngine.CopyURLToFile "
'variables
Dim hInternetSession As Long
Dim hUrl As Long
Dim FileNum As Integer
Dim ok As Boolean
Dim NumberOfBytesRead As Long
Dim Buffer As String
Dim fileIsOpen As Boolean

940 On Error GoTo ErrorHandler
950 CopyURLToFile = False

960 If oFSO Is Nothing Then
970 Set oFSO = New Scripting.FileSystemObject
980 End If

' open an Internet session, and retrieve its handle
990 hInternetSession = InternetOpen(App.EXEName,
INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

1000 If hInternetSession = 0 Then
1010 Err.Raise vbObjectError + 1000, , "An error occurred calling
InternetOpen function"
1020 Else

' open the file and retrieve its handle
1030 hUrl = InternetOpenUrl(hInternetSession, URL, vbNullString, 0,
INTERNET_FLAG_EXISTING_CONNECT, 0)

1040 If hUrl = 0 Then
1050 Err.Raise vbObjectError + 1000, , "An error occurred calling
InternetOpenUrl function"
1060 Else
' open the local file
1070 FileNum = FreeFile
1080 Open FileName For Binary As FileNum
1090 fileIsOpen = True

' prepare the receiving buffer
1100 Buffer = Space(4096)

1110 Do
' read a chunk of the file - returns True if no error
1120 ok = InternetReadFile(hUrl, Buffer, Len(Buffer),
NumberOfBytesRead)
' exit if error or no more data
1130 If NumberOfBytesRead = 0 Or Not ok Then
1140 Exit Do
1150 End If
' save the data to the local file
1160 Put #FileNum, , Left$(Buffer, NumberOfBytesRead)
1170 Loop

1180 End If
1190 End If


1200 CopyURLToFile = True

' flow into the error handler
ErrorHandler:
' close the local file, if necessary
1210 If fileIsOpen Then
1220 Close #FileNum
1230 End If
' close internet handles, if necessary
1240 If hUrl Then
1250 InternetCloseHandle hUrl
1260 End If

1270 If hInternetSession Then
1280 InternetCloseHandle hInternetSession
1290 End If

' report the error to the client, if there is one
1300 If Err Then

1310 With Err
1320 gstrErrorDescription = .Description
1330 glngErrorNumber = .Number
1340 gstrErrorHelpContext = .HelpContext
1350 gstrErrorHelpFile = .HelpFile
1360 gstrErrorSource = .Source
1370 glngErrorLine = Erl
1380 .Clear
1390 End With

1400 CopyURLToFile = False
1410 RaiseEvent BadgerMessage(strMethodName & gstrErrorDescription
& "(" & glngErrorNumber & ") [" & gstrErrorSource & "]<" & glngErrorLine & "
")

1420 If globalWriteErrorToDebugWindow Then
1430 Debug.Print strMethodName & gstrErrorDescription & "(" &
glngErrorNumber & ") [" & gstrErrorSource & "]<" & glngErrorLine & " "
1440 End If

1450 End If

End Function

--
www.alignment-systems.com


"Necessitysslave" wrote:

I am writing a macro for my users that grabs info off of a web page.
I want it to open a new worksheet with the info on it so that I can
work on it.

Below is my code it uses *ug* sendkeys and notepad to convert
documentelement.html into a text file is there a way of doing this
without using a program external to excel?

if not is there a way to close notepad without notepad asking if I want
to save?

Dim oIE As New SHDocVw.InternetExplorer
Dim sURL As String
Dim MyAppID As Long
sURL = "http://www.w3.org/2002/ws/" 'the page I'm loading is
'on the intranet but this is good for an
example

'open a new, visible IE window
Set oIE = New SHDocVw.InternetExplorer
oIE.Visible = false

'go to desired page
oIE.Navigate sURL

'wait for page to finish loading
Do Until oIE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop

MyAppID = Shell("notepad", 1)
DoEvents
On Error Resume Next
AppActivate "microsoft ex"
Application.DisplayAlerts = False

Worksheets("Webcopy").Delete

Application.DisplayAlerts = True
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Webcopy"
Range("A1") = oIE.Document.documentelement.innerhtml
Range("A1").Copy
AppActivate "Untit"
DoEvents
SendKeys "^v"
DoEvents
SendKeys "%ea"
DoEvents
SendKeys "^c"
DoEvents
SendKeys "% c"
DoEvents
ActiveSheet.Range("A1").ClearContents
ActiveSheet.Paste
oIE.Quit

thanks for that, its gonna take me some time to digest that and work
out exacly whats going on. But that is a great help.

Option Explicit

Sub Tester()
GetWeb "http://www.google.com"
End Sub

Sub GetWeb(sURL As String)

Dim twbs As Object

Set twbs = ThisWorkbook.Sheets

Application.DisplayAlerts = False
On Error Resume Next
twbs("Webcopy").Delete
On Error GoTo 0
Application.DisplayAlerts = True

With Workbooks.Open(sURL)
.Sheets(1).Copy after:=twbs(twbs.Count)
.Close False
End With

twbs(twbs.Count).Name = "WebCopy"
End Sub

.... or just use the built-in WebQuery functionality.


--
Tim Williams
Palo Alto, CA


"Necessitysslave" wrote in message
oups.com...
I am writing a macro for my users that grabs info off of a web page.
I want it to open a new worksheet with the info on it so that I can
work on it.

Below is my code it uses *ug* sendkeys and notepad to convert
documentelement.html into a text file is there a way of doing this
without using a program external to excel?

if not is there a way to close notepad without notepad asking if I want
to save?

Dim oIE As New SHDocVw.InternetExplorer
Dim sURL As String
Dim MyAppID As Long
sURL = "http://www.w3.org/2002/ws/" 'the page I'm loading is
'on the intranet but this is good for an
example

'open a new, visible IE window
Set oIE = New SHDocVw.InternetExplorer
oIE.Visible = false

'go to desired page
oIE.Navigate sURL

'wait for page to finish loading
Do Until oIE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop

MyAppID = Shell("notepad", 1)
DoEvents
On Error Resume Next
AppActivate "microsoft ex"
Application.DisplayAlerts = False

Worksheets("Webcopy").Delete

Application.DisplayAlerts = True
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Webcopy"
Range("A1") = oIE.Document.documentelement.innerhtml
Range("A1").Copy
AppActivate "Untit"
DoEvents
SendKeys "^v"
DoEvents
SendKeys "%ea"
DoEvents
SendKeys "^c"
DoEvents
SendKeys "% c"
DoEvents
ActiveSheet.Range("A1").ClearContents
ActiveSheet.Paste
oIE.Quit