I have a VBA project that I am working on and have reached the end and just before the task is complete it does not do what I want it to do.
I am creating my first Access db and not real all that good with access or the VBA. The data that I am attempting to save will be the the key kog to my access database. Currently I use VBA in excel to navigate the website to access the data and have no problem doing so.
However, to make the system better and more multiuser friendly I am attempting to move this to access. I have re-written the VBA into access and I can navigate to the excel file no problem. However, currently the excel file opens in an IE instance window and I can not save it to my hard drive.
If you have any idea how I can tell it to save the file I would greatly appreciate your advise.
Current Code:
Module 2
I am creating my first Access db and not real all that good with access or the VBA. The data that I am attempting to save will be the the key kog to my access database. Currently I use VBA in excel to navigate the website to access the data and have no problem doing so.
However, to make the system better and more multiuser friendly I am attempting to move this to access. I have re-written the VBA into access and I can navigate to the excel file no problem. However, currently the excel file opens in an IE instance window and I can not save it to my hard drive.
If you have any idea how I can tell it to save the file I would greatly appreciate your advise.
Current Code:
Code:
Option Compare Database
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Function SKPIUPDATE()
Dim QPR As Object
Dim lnk As Object
Dim TimeOut As String
Dim frm As Object
Dim Start As Object
Dim Finish As Object
Dim drp2 As Object
Dim drp1 As Object
Dim src1 As Object
Dim p1 As Variant
Dim objWB As Object
Dim objExc As Object
Set QPR = CreateObject("InternetExplorer.application")
QPR.Visible = True
QPR.navigate "[URL]https://www.portal.toyotasupplier.com/wps/myportal/[/URL]"
TimeOut = Now + TimeValue("00:00:20") '-- wait maximum of 20 seconds
Do While QPR.Busy Or QPR.readyState <> 4
DoEvents
If Now > TimeOut Then
MsgBox "Time Out before Login"
Exit Function
End If
Loop
With QPR.Document.Forms("Login")
.User.Value = "xxxxxxx"
.Password.Value = "xxxxxxx"
.submit
End With
TimeOut = Now + TimeValue("00:00:40") '-- wait maximum of 10 seconds
Do While QPR.Busy Or QPR.readyState <> 4
DoEvents
If Now > TimeOut Then
MsgBox "Time Out after Login"
Exit Function
End If
Loop
QPR.navigate ("[URL]https://www.portal.toyotasupplier.com/skpi/[/URL]")
TimeOut = Now + TimeValue("00:00:05") '-- wait 1 second for above navigation to take effect
Do While Now < TimeOut
DoEvents
Loop
TimeOut = Now + TimeValue("00:00:50") '-- wait maximum of 10 seconds
Do While QPR.Busy Or QPR.readyState <> 4
DoEvents
If Now > TimeOut Then
MsgBox "Did not navigate to SKPI application"
Exit Function
End If
Loop
Set lnk = QPR.Document.Links(3) ' 3=TMMK-VEH,4=TMMK-PWT,5=TMMC,6=TMMTX,7=TABC,8=NUMMI,9=TMMI,10=TMMBC,11=TMMAL,12=TMMNK
lnk.Click
TimeOut = Now + TimeValue("00:00:20") '-- wait 1 second for above navigation to take effect
Do While Now < TimeOut
DoEvents
Loop
QPR.navigate ("[URL]https://www.portal.toyotasupplier.com/skpi/SkpiGatewayServlet?jadeAction=NCPARTS_SEARCH[/URL]")
TimeOut = Now + TimeValue("00:00:05") '-- wait 1 second for above navigation to take effect
Do While Now < TimeOut
DoEvents
Loop
Set frm = QPR.Document.Forms("form1")
Set Start = frm.all("SKPI_SEARCH_START_DATE_KEY")
Start.Value = "01/01/" & Year(Now)
Set Finish = frm.all("SKPI_SEARCH_END_DATE_KEY")
Finish.Value = Format(Now - 1, "mm/dd/yyyy")
Set drp2 = frm.all("SKPI_SEARCH_NC_TYPE_KEY")
drp2.Item(1).Selected = True
Set drp1 = frm.all("SKPI_SEARCH_NAMC_KEY")
drp1.Item(p1).Selected = True
Set src1 = frm.all("Submit")
src1.Click
TimeOut = Now + TimeValue("00:00:05") '-- wait 1 second for above navigation to take effect
Do While Now < TimeOut
DoEvents
Loop
QPR.navigate ("[URL]https://www.portal.toyotasupplier.com/skpi/DownloadNCPartListServlet[/URL]")
TimeOut = Now + TimeValue("00:01:00") '-- wait 1 minute for above navigation to take effect
Do While Now < TimeOut
DoEvents
Loop
'Insert the file link below
Const strUrl As String = "[URL]https://www.portal.toyotasupplier.com/skpi/DownloadNCPartListServlet[/URL]" 'example link
Dim strSavePath As String
Dim returnValue As Long
'Path to save the file
strSavePath = "C:\Documents and Settings\dsggodwin\My Documents\_DENSO QRE"
returnValue = URLDownloadToFile(0, strUrl, strSavePath, 0, 0)
'err_1:
'MsgBox Err.Description
'Resume Err_Exit
Err_Exit:
QPR.navigate ("[URL]https://www.portal.toyotasupplier.com/public/pr_logout.htm[/URL]")
End FunctionModule 2
Code:
Option Compare Database
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub DownloadFileFromWeb()
On Error GoTo err_1
'Insert the file link below
Const strUrl As String = "[URL]https://www.portal.toyotasupplier.com/skpi/DownloadNCPartListServlet.xls[/URL]" 'example link
Dim strSavePath As String
Dim returnValue As Long
'Path to save the file
strSavePath = "C:\Documents and Settings\dsggodwin\My Documents\_DENSO QRE\SKPI PARTS RETURN"
returnValue = URLDownloadToFile(0, strUrl, strSavePath, 0, 0)
Err_Exit:
Exit Sub
err_1:
MsgBox Err.Description
Resume Err_Exit
End Sub
Last edited:
