파일 다운로드 IE11 + 파일을 저장할 폴더 만들기

Question

파일을 다운로드 할 때 IE 11 다운로드 바를 다루는 데 많은 문제가있었습니다.

나는 다른 해결책을 확인했지만 가능한 가장 확실하게 작동하게하는 유일한 방법은 두 개를 함께 사용하는 것이 었습니다.

그렇다면 기본 인터넷 다운로드 폴더를 바탕 화면으로 설정하여 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