下载文件创建一个文件夹，将其存储

Question

我有很多的下载文件时处理，IE浏览器11下载栏问题。

我查了不同的解决方案，但只有这样，才能使其工作最可靠的可能是把他们两个人在一起。

然后我设置了默认的Internet下载文件夹作为我的桌面，这样每当我下载一个文件的SendKeys我知道在哪里的代码找到它。

对于小故事，我的代码被下载了所有不同的发病病例附加文件。数量/类型的附件可以改变和oragnize它一点点，我决定创建一个事件案例的名称的文件夹，里面存储的附件。

Answer 1

因此，这里是我的代码，如果你看到哪些可以改进的一部分，让我知道:)

Option Explicit 
Private objIE As SHDocVw.InternetExplorer 
Private ContentFrame As HTMLIFrame 
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long 
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) 
Public Const MOUSEEVENTF_LEFTDOWN = &H2 
Public Const MOUSEEVENTF_LEFTUP = &H4 
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8 
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10 
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 


Private Sub LeftClick() 
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 
    Sleep 50 
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 
End Sub 


Sub DownloadAttachment() 
    'make sure Cell A4 isn't empty because it has to contain the incident case 
    If Sheets(1).Cells(4, 1) = "" Or Sheets(1).Cells(4, 1) = " " Then End 
    'make sure it's a valid case No. before going on 
    On Error GoTo Fin 
    If Len(Cells(4, 1)) <> 8 Or CLng(Sheets(1).Cells(4, 1)) = 0 Then 
      MsgBox "Please enter a valid Case No." 
      End 
    End If 
    Call GetDataFromIntranet(Sheets(1).Cells(4, 1) 
    'Delete content on cell A4 
    Fin: 
      Sheets(1).Cells(4, 1) = "" 
End Sub 


Function GetDataFromIntranet(CaseNo As Long) 
    Dim i As Integer 
    If ("attachmentDivId").Children(0).Children(1).Children.Length >= 1 Then Call CreateFolder(CaseNo) ' If there is at least 1 attachment then we'll create a folder which has the name of the incident case 
    For i = 0 To objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children.Length - 1 ' For each attachment... 
RetourALaCaseDepart: 
      objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Click ' Click on it so that it gets activated (blue) 
      objIE.document.frames(1).frames(1).document.getElementsByName("download")(0).Click 'Click on Save as 
     'The following bit send keyboard keys to cope with the Internet Downaload window that appears down the page -> downloads the file and save it on the Desktop 
      Application.Wait Now + TimeSerial(0, 0, 10) 
      Application.SendKeys "%{S}" 
      Application.Wait Now + TimeSerial(0, 0, 10) 
      SendKeys "{F6}", True 
      SendKeys "{TAB}", True 
      SendKeys "{ENTER}", True 
     'Here we close the Desktop window which sometimes open because it can alter the SendKey codes which is very sensitive 
      Dim objShellWindows As New SHDocVw.ShellWindows 
      Dim win As Object 
      For Each win In objShellWindows 
       If win.LocationName = "Desktop" Then 
        win.Quit 
       End If 
      Next win 
      Application.Wait Now + TimeSerial(0, 0, 1) 
      If MakeSureDownloaded(objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Children(0).innerText, CaseNo) = False Then GoTo RetourALaCaseDepart ' We check if the attachment was successfully saved, if not we redo the saving process from "RetourALaCaseDepart 
    Next i 
    Exit Function 
Fini: 
    MsgBox "No attachments found or attachment tab not found" 
End Function 


Function MakeSureDownloaded(FileName As String, CaseNo As Long) As Boolean 
    Dim FileSys As Object 'FileSystemObject 
    Dim objFile As Object 'File 
    Dim myFolder 
    Dim strFilename As String 
    Const myDir As String = "C:\Users\Seb\Desktop\"   
    'set up filesys objects 
    Set FileSys = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject 
    Set myFolder = FileSys.GetFolder(myDir) 
    For Each objFile In myFolder.Files 
      If objFile.Name Like FileName & "*" Then ' If the file was saved then we will add it to the folder created earlier for that Case 
       strFilename = objFile.Name 
       MakeSureDownloaded = True 
       GoTo BienBien 
      End If 
    Next objFile 
    MakeSureDownloaded = False 
    Set FileSys = Nothing 
    Set myFolder = Nothing 
    Exit Function 

BienBien: 
    Dim fso As Object 
    Set fso = VBA.CreateObject("Scripting.FileSystemObject") 
    Call fso.MoveFile("C:\Users\Seb\Desktop\" & strFilename, "Path...\Case_Attachments\" & CaseNo & "\" & strFilename) 
    Set FileSys = Nothing 
    Set myFolder = Nothing 
End Function 


Sub CreateFolder(CaseNo As Long) 
    Dim fsoFSO 
    Set fsoFSO = CreateObject("Scripting.FileSystemObject") 
    If fsoFSO.FolderExists("Path...\Case_Attachments\" & CaseNo) Then ' do nothing actually... 
    Else 
      fsoFSO.CreateFolder ("Path...\Case_Attachments\" & CaseNo) 
    End If 
End Sub