Updating Check Boxes in User Form does not change worksheet
That's a 6+mb file, not practical to try a webQuery.
There are probably different approaches, following is something like this
start downloading the file to memory in chunks
look for the 2nd "short_selling" pos2
then look for "Total", pos3
Start adding chunks after Total to a big string
Stop when "-------" is found pos4
Split the bg string and dump to cells
Might want to do a bit more to put all the values in a table, but that's the
easy part which I'll leave to you.
This is very much bespoke, things could easily change which would require
the code to be modified. As of time of posting seems to work well,
particularly bearing in mind the size of the file
Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias _
"InternetOpenA" ( _
ByVal lpszAgent As String, _
ByVal dwAccessType As Long, _
ByVal lpszProxy As String, _
ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias _
"InternetOpenUrlA" ( _
ByVal hInternet As Long, _
ByVal lpszUrl As String, _
ByVal lpszHeaders As String, _
ByVal dwHeadersLength As Long, _
ByVal dwFlags As Long, _
ByRef dwContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
ByRef hInternet As Long) As Boolean ' byref or byval ??
Private Declare Function InternetReadFile Lib "wininet.dll" ( _
ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal dwNumberOfBytesToRead As Long, _
ByRef lpdwNumberOfBytesRead As Long) As Integer
'' note ByVal lpBuffer As String, not ByRef as Any which can crash
Sub Short_selling_To_Cells()
Dim bGrab As Boolean
Dim iRes As Integer
Dim i As Long, nLen As Long
Dim pos1 As Long, pos2 As Long, pos3 As Long, pos4 As Long
Dim hInternetSession As Long, hUrl As Long
Dim nBytes As Long
Dim Buffer As String
Dim bigBuffer As String
Dim sErr As String
Dim arr() As String
Dim cnt As Long
Const cURL As String = "http://www.hkex.com.hk/markdata/quot/d100114e.htm"
Const cANC As String = "short_selling"
On Error GoTo errH
Range("A:F").Clear
'' assumes IE installed
hInternetSession = InternetOpen("IExpore.exe", _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, vbNullString, 0)
If hInternetSession = 0 Then Err.Raise 10100
hUrl = InternetOpenUrl(hInternetSession, cURL, vbNullString, _
0, INTERNET_FLAG_EXISTING_CONNECT, 0)
If hUrl = 0 Then Err.Raise 10200
Buffer = Space(4096)
bigBuffer = Space(4096& * 8)
Do
iRes = InternetReadFile(hUrl, Buffer, Len(Buffer), nBytes)
If nBytes = 0 Or iRes = 0 Then Exit Do
If bGrab = False Then
If pos1 = 0 Then
pos1 = InStr(1, Buffer, cANC, vbTextCompare)
If pos1 And pos1 < 4096 Then
pos2 = InStr(pos1 + 1, Buffer, cANC, vbTextCompare)
End If
ElseIf pos2 = 0 Then
pos2 = InStr(1, Buffer, cANC, vbTextCompare)
If pos2 And pos2 < 4096 Then
pos3 = InStr(pos2 + 1, Buffer, "Total", vbTextCompare)
End If
ElseIf pos2 Then
pos3 = InStr(1, Buffer, "Total") + 1
End If
If pos3 Then
bGrab = True
If pos3 < (4096) Then
Buffer = Mid$(Buffer, pos3, Len(Buffer))
End If
End If
End If
If bGrab Then
pos4 = InStr(1, Buffer, "----------")
If pos4 Then
Buffer = Left$(Buffer, pos4 - 1)
End If
If nLen + Len(Buffer) Len(bigBuffer) Then
bigBuffer = bigBuffer & Space(4096& * 8)
End If
Mid$(bigBuffer, nLen + 1, Len(Buffer)) = Buffer
nLen = nLen + Len(Buffer)
If pos4 Then
Exit Do
End If
End If
Loop
If bGrab Then
bigBuffer = Left$(bigBuffer, nLen)
arr = Split(bigBuffer, vbCrLf)
With Range("A1:A" & UBound(arr) + 1)
.Font.Name = "Courier New"
' .Value = arr
End With
For i = 0 To UBound(arr)
Cells(i + 1, 1) = arr(i)
Next
End If
done:
If hUrl Then InternetCloseHandle hUrl
If hInternetSession Then InternetCloseHandle hInternetSession
Exit Sub
errH:
Select Case Erl
Case 10100
sErr = "Error calling InternetOpen"
Case 10200
sErr = "Error calling InternetOpenUrl function"
Case Else
sErr = Err.Description
End Select
MsgBox sErr
' Stop
' Resume
Resume done
End Sub
Regards,
Peter T
"Brian" wrote in message
...
I have a user Form with several Check Boxes on it. When I check or uncheck
the Boxes it does not change the boxes in the workbook/worksheet. The User
Form is a different workbook then the Worksheet I want to update.
When you click on the Check box on the worksheet it shows "Check Box ##".
This is the same Workbook/Sheet reference I am using for several other
things
and they all update correctly. What did I do wrong?
Here is the code I was trying to use:
Private Sub Update_Installer_Forms_8_Click()
With Workbooks("Master Installer Forms.xlsm").Sheets("Install Pack")
.Range("Check Box 59").Value =
Me("Office_Package_Preparations_101").Value
.Range("Check Box 60").Value =
Me("Office_Package_Preparations_102").Value
.Range("Check Box 61").Value =
Me("Office_Package_Preparations_103").Value
.Range("Check Box 62").Value =
Me("Office_Package_Preparations_104").Value
End With
End Sub
|