Question

我想知道你是否可以提供帮助！我写了一个代码来浏览我公司的某个网站，从我们的服务器检索excel表，并设置这个宏在一定的时间间隔运行，它工作正常。问题是，在我的代码中，我使用SendKeys方法在IE 11提示打开，保存或取消时单击保存按钮。当我锁定我的PC时，我发现我的代码是PAUSED，无论如何，如果出于安全目的而不活动，PC会自动锁定。当我回来解锁我的电脑时，我看到代码从SendKeys开始。请不要忘记任务调度器的意思，因为它将无法工作！那么有任何代码可以自动保存这个xlsx文件吗？非常感谢提前:)）

Sub mySub()

    Set objIE = CreateObject("InternetExplorer.Application")
    WebSite = "example.com"
    logSite = "https://example.com/logoff.do"
    With objIE
        .Visible = True
        .Navigate WebSite
        Do While .Busy Or .readyState <> 4
            DoEvents
        Loop

        Set unElement = .Document.getElementsByName("username")
        unElement.Item(0).Value = "my username"
        Set pwElement = .Document.getElementsByName("password")
        pwElement.Item(0).Value = "my password"
        .Document.forms(0).submit
        '.quit

        Do While .Busy Or .readyState <> 4
            DoEvents
        Loop


        Set expElement = .Document.getElementsByClassName("nav__action dropdown-trigger js--tooltip")
        expElement(0).Click

        Do While .Busy Or .readyState <> 4
            DoEvents
        Loop

        .Document.getElementById("obb_EXPORT_EXCEL").Click

    End With


 application.Wait (Now + TimeValue("0:00:02"))
SendKeys "%S", True

   Const SOME_PATH As String = "C:\Users\Ali\Downloads\"


Dim file As String


file = Dir$(SOME_PATH & "BFUR *" & ".xlsx")

application.Wait (Now + TimeValue("0:00:03"))
If (Len(file) > 0) Then
  Workbooks.Open(SOME_PATH & file).Activate


End If
application.Wait (Now + TimeValue("0:00:02"))
ActiveSheet.Range("A4:BC600").Copy



Windows("macro testing final.xlsm").Activate

Range("A3").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

     [L:L].Select
With Selection
    .NumberFormat = "General"
    .Value = .Value
End With
Range("A3").Select
application.CutCopyMode = False

application.Wait (Now + TimeValue("0:00:40"))
Workbooks(file).Activate
application.Wait (Now + TimeValue("0:00:03"))
ActiveWorkbook.Close savechanges:=False


With New FileSystemObject
    If .FileExists(SOME_PATH & file) Then
        .DeleteFile SOME_PATH & file
    End If
End With



   Windows("macro testing final.xlsm").Activate
   Worksheets("Pivots").Activate

    ThisWorkbook.RefreshAll

    application.Wait (Now + TimeValue("0:00:03"))

    Worksheets("Email").Activate
    application.Wait (Now + TimeValue("0:00:03"))



Dim EmailSubject As String
Dim SendTo As String
Dim EmailBody As String
Dim ccTo As String
Dim r As Range
Set r = Sheets("Email").Range("A1:E72")

Range("A1") = "Hi All," & vbNewLine & "Please find the below report  generated at " & Format(Time, "hh:mm") & "." & vbNewLine


r.Copy

EmailSubject = "tNPS Update at " & Format(Time, "hh:mm")
SendTo = Range("Q10")
ccTo = Range("Q10")


Dim outlookApp As Outlook.application
Set outlookApp = CreateObject("outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = Outlook.CreateItem(olMailItem)



With outMail
.Subject = EmailSubject
.To = SendTo
.CC = ccTo
.body = EmailBody
.display

outMail.display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor


'paste as Table (remove the comma)
wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False


.send
End With
Set outlookApp = Nothing
Set outMail = Nothing


   Windows("macro testing final.xlsm").Activate
   Sheets("Raw").Select
   Range("A3:BC900").Select
   Selection.ClearContents
   Range("A3").Select


    With objIE
        .Visible = True
        .Navigate logSite
        Do While .Busy Or .readyState <> 4
            DoEvents
        Loop

objIE.Quit

 End With

End Sub

Answer 1

以下是如何仅使用URL保存它的示例。

Sub SaveInternetFile（myURL As String）

savePath = ActiveWorkbook.Path & "\"
Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
'exit sub if the file already exists
If fso.FileExists(savePath & "FileName.xls") Then
    Set fso = Nothing
Exit Sub
End If

Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.send

'myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile (savePath & "FileName.xls")
    oStream.Close
End If

End Sub

宏在底部的Internet Explorer 11消息栏上提示时选择“保存”而不是“另存为”

1 个答案: