投稿‎ > ‎

VBAで遊ぼう⑤

posted Mar 21, 2016, 6:26 PM by Zhang Wenxu   [ updated Mar 21, 2016, 10:05 PM ]
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal h As Long, ByVal hP As Long, ByVal lpsz As String, ByVal lpsz2 As String) As Long

Public Sub DevNetDownload()
    Dim ie As InternetExplorer
    Dim cel As Range
    Dim id As String
    Dim saveFile As String
    Dim path As String
    Dim relPath As String
    Dim celActive As Range

    Set celActive = ActiveCell

    For Each cel In Selection
        DoEvents
        If cel.EntireRow.Hidden Then GoTo NEXT_CEL
        If Not isID(cel) And getID(cel) = "" Then GoTo NEXT_CEL
        id = getID(cel)
        path = workDir & Format(Now, "yyyymmdd") & "\"
        relPath = getPath(cel)
        If left(relPath,1) ="\" Then
            path = path & Mid(relPath, 2)
        Else
             path = path & relPath
        End If
        SaveFile = DevNetDownloadByID(id, path, True, cel:= cel)
        If saveFile = "" Then
             cel.Offset(0, 1).value = "-"
             GoTo NEXT_CEL
        End If
        cel.Offset(0, 1).NumberFormatLocal = "G/標準"
        cel.Offset(0, 1),value = saveFile
        Call HyperlinkCell(cel.Offset(0, 1))
NEXT_CEL:
    Next
    Set ie = getProcenter()
    Call SetWindowPos(ie.hWnd, HWND_BOTTOM, 0, 0, 0, 0, SWP_SHOWWINDOW + SWP_NOMOVE + SWP_NOSIZE)
    Call BringWindowToTop(celActive.Application.hWnd)
End Sub

Public Function DevNetDownloadByID(id As String, path As String, Optional forceOverwrite = False, _
    Optional filename As String, Optional cel As Range) As String
    Const ROLE_SYSTEM_BUTTONDROPDOWN = &H38&
    Dim ie As InternetExplorer
    Dim downloadBtn As Object
    Dim cndDropDownRole As UIAutomationClient.IUIAutomationCondition
    Dim elmDropDown As UIAutomationClient.IUIAutomationElement
    Dim ptnAccDropDown As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
    Dim hPopupMenu As Long
    Dim elmPopupMenu As UIAutomationClient.IUIAutomationElement
    Dim cndSaveAsButtonAK As UIAutomationClient.IUIAutomationCondition
    Dim elmSaveAsButton As UIAutomationClient.IUIAutomationElement
    Dim ptnAccSaveAsButton As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
    Dim hSaveAsDialog As Long
    Dim elmSaveAsDialog As UIAutomationClient.IUIAutomationElement
    Dim cndButtonControl As UIAutomationClient.IUIAutomationCondition
    Dim aryButtonControl AS UIAutomationClient.IUIAutomationElementArray
    Dim i As Integer
    Dim elmSaveButton As UIAutomationClient.IUIAutomationElement
    Dim cndEditControl As UIAutomationClient.IUIAtomationCondition
    Dim aryEditControil As UIAutomationClient.IUIAutomationElementArray
    Dim j As Integer
    Dim elmFileName As UIAutomationClient.IUIAutomationElement
    Dim ptnValFilename As UIAutomationClient.IUIAutomationValuePattern
    Dim saveFilePath As String
    Dim fso As New FileSystemObject
    Dim reg As New RegExp
    Dim loginBtn As Object
    Dim retryCtn As Ineger
    Dim ptnAccSaveButton As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
    Dim cndNBTName As UIAutomationClient.IUIAutomationCondition
    Dim elmNBT As UIAutomationClient.IUIAutomationElement
    Dim cndButtonName As UIAutomationClient.IUIAutomationCondition
    Dim elmCloseButton As UIAutomationClient.IUIAutomationElement
    Dim ptnAccCloseButton As UIAutomationClient.IUIAutomationLegacyIAccessiblePatttern
    Dim wk As Workbook
    Dim seq As String
    
    If path <> "" Then
        Debug.Asssert right(path, 1) = "\"
    End If
    DevNetDownloadByID = ""
    reg.Pattern = "/"
    reg.Global = True
RETRY_SEARCH:
    Set ie = getProcenter
    Call searchID(id)
    On Error Resume Next
    If ie.document.frames.Length = 0 Then
        Ie.document.all("Password").value = ""your password"
        Set loginBtn = getInputByAlt(ie, "ログイン")
        If Not loginBtn Is Nothing Then
            Call loginBtn.Click
        End If
        Call waitIE(ie)
        GoTo RETRY_SEARCH
    End If
    If InStr(ie.document.frames("main").document.body.innerText, "検索に失敗しました") > 0 Then
        Exit Function
    End If
    seq = getValueByName(ie, "SEQ")
    Set downloadBtn = getInputByName(ie, "DownLoad")
    If filename <> "" Then
        saevFilePath = path & filename
    Else 
        saveFilePath = path & getValueByName(ie, "ファイル名")
    End If
    saveFilePath = reg.Replace(saveFilePath, "_")
    If fso.FileExists(saveFilePath) Then
         On Error Resume Next
         Workbooks(fso.getFilename(saveFilePath)).Close False
         On Error GoTo 0
         Set wk = Workbooks.Open(saveFilePath, False, True)
         If Not forceOverwrite And id = getCustomProp(wk, C_DEVNET_ID) And seq = getCustomProp(wk, C_DEVNET_SEQ) Then
              DevNetDownloadByID = saveFilePath
              wk.Close False
              Exit Function
        End If
        Call fso.DeleteFile(saveFilePath)
    End If
RETRY_CREATE_FOLDER:
    If Not fso.FolderExists(fso.getParentFolder(saveFilePath))  Then
        Call runCmd("mkdir """ & fso.GetParentFolderName(saveFilePath) & """")
    End if
    If Not fso.FolderExists(fso.GetParentFolderName(saveFilePath)) Then
        saveFilePath = workDir & Format(Now, "yyyymmdd") & "\" & getValueByName(ie, "ファイル名")
        Call runCmd("mkdir " & fso.GetParentFolderName(saveFilePath))
        saveFilePath = reg.Replace(saveFilePath, "_")
    Else
        saveFilePath = """" & saveFilePath & """"
    End If
    If downloadBtn Is Nothing Then Exit Function
    Call downloadBtn.Click
    Call Sleep(1000)
    Set ie = getProcenter()
    Call waitIE(ie)
    
Dim h As Long
 RETRY_DOWNLOAD_BAR:
    h = FindWindow(ie.hWnd, 0, "Frame Notification Bar", vbNullStrin)
    If h = 0 Then
        retryCnt = retryCnt + 1
        If retryCnt > 15 Then
            retryCnt = 0
            Exit Function
        Else
             Sleep 500
             GoTo RETRY_DOWNLOAD_BAR
        End If
        Dim uiAuto As New UIAutomationClient.CUIAutomation
        Dim elmFNB As UIAutomationClient.IUIAutomationElement
        Set elmFNB = uiAuto.ElementFromHandle(ByVal h)
        Call Sleep(1000)
        Set cndDropDownRole = uiAuto.CreatePropertyCondition(UIA_LegacIAccessibleRolePropertyId, ROLE_SYSTEM_BUTTONDROPDOWN)
        Set elmDropDown = elmFNB.FindFirst(TreeScope_Subtree, cndDropDownRole)
        If elmDropDown Is Nothing Then
             Set ie = getIELast()
             GoTo RETRY_DOWNLOAD_BAR
        End If
        Set ptnAccDropDown = elmDropDown.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
        ptnAccDropDown.doDefaultAction
        retryCnt = 0
        Do
             Sleep 500
             hPopupMenu = FindWindowEx(0, 0, "#32768", vbNullString)
             DoEvents
             retryCnt = retryCnt + 1
             If retryCnt > 15 Then
                  GoTo RETRY_DOWNLOAD_BAR
             End If
        Loop Untile hPopupMenu <> 0
        Set elmPopupMenu = uiAuto.ElementFromHandle(ByVal hPopupMenu)
        Set cndSaveAsButtonAK = uiAuto.CreatePropertyCondition(UIA_AccessKeyPropertyId, "a")
        Set elmSaveAsButton = elmPopupMenu.FindFirst(TreeScope_SubTree, cndSaveAsButtonAK)
        Set ptnAccSaveAsButton = elmSaveAsButton.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
        ptnAccSaveAsButton.DoDefaultAction
RETRY_SAVE_DIALOG:
        retryCnt = 0
        Do
             hSaveAsDialog = FindWindowEx(0, 0, "#32770", "名前を付けて保存")
             DoEvents
             rtryCnt = retryCnt + 1
             If retryCnt > 10 Then
                GoTo RETRY_DOWNLOAD_BAR
             End If
             Sleep 500
        Loop Until hSaveAsDialog <> 0
       Sleep 1000
       Set elmSaveAsDialog = uiAuto.ElementFromHandle(ByVal hSaveAsDialog)
       Set cndButtonControl = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_ButtonControlTypeId)
       Do
            Set aryButtonControl = elmSaveAsDialog.FindAll(TreeScope_SubTree, cndButtonControl)
             DoEvents
       Loop Until aryButtonControl.Length > 1
      For i = 0 To aryButtonControl.Length - 1 
          If LCase(aryButtonControl.GetElement(i).CurrentAccessKey) = "alt+s" Then
              Set elmSaveButton = aryButtonControl.GetElement(i)
              Exit For
          End If
      Next
      If elmSaveButton Is Nothing Then Exit Function
      Set cndEditControl = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_EditControlTypeId)
      Do
          Set aryEditControl = elmSaveAsDialog.FindAll(TreeScope_Subtree, cndEditControl)
          DoEvents
      Loop Until aryEditControl.Length > 1
      For j = 0 To aryEditControl.Length - 1
           If LCase(aryEditControl.GetElement(j).CurrentAccessKey) = "alt+n" Then
                Set elmFileName = aryEditControl.GetElement(j)
                Exit For
          End If
     Next
     If elmFileName Is Nothing Then Exit Function
     Set ptnValFileName = elmFileName.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
     ptnValFileName.SetValue saveFilePath
RETRY_CLOSE_SAVEAS:     
     Set ptnAccSaveAsButton = elmSaveButton.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
     pttnAccSaveButton.DoDefaultAction
     Set ie = getProcenter()
RETRY_FINNISH_DIALOG:
    h = FindWindowEx(ie.hWnd, 0, "FrameNotify Bar", vbNullString)
    If h = 0 Then Exit Function
    Set elmFNB = uiAuto.ElementFromHandle(ByVal h)
    Set cndNBTName = uiAuto.CreatePropertyControl(UIA_NamePropertyId, "通知バーのテキスト")
    Set elmNBT = elmFNB.FindFirst(TreeScope_Subtree, cndNBTName)
    If elmNBT Is Nothing Then
         Set ie = getIELast()
         GoTo RETRY_FIND_DIALOG
    End if
    retryCnt = 0
    Do
        DoEvents
        retryCnt = retryCnt + 1
        If retryCnt > 10 Then
             Set ie = getIELast()
             GoTo RETRY_CLOSE_SAVEAS
        End If 
        Sleep 500
    Loop Unitl InStr(elmNBT.GetCurrentPropertyValue(UIA_ValueValuePropertyId), "ダウンロードが完了しました") > 0
    Set cndButtonName = uiAuto.CreatePropertyCondition(UIA_NamePropeertyId, "閉じる")
    Set elmCloseButton = elmFNB.FindFirst(TreeScope_Subtree, cndButtonName)
    Set ptnAccCloseButton = elmCloseButton.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
    ptnAccCloseButton.DoDefaultAction
    If left(saveFilePath, 1) = """" Then
        saveFilePath = Mid(saveFilePaht, 2)
    End If 
    If right(saveFilePath, 1) = """" Then
        saveFilePath = left(saveFilePath, Len(saveFilePath) - 1)
    End If
    Dim ext
    ext = fso.GetExtensionName(safeFilePath)
    DoEvents
    If ext = "xls" Or ext = "xslx" Or ext = "xlsm" Then
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        Set wk = Workbooks.Open(saveFilePath, False)
        Call saveCustomProp(wk, C_DEVNET_ID, id)
        Call saveCustomProp(wk, C_DEVNET_SEQ, seq)
        wk.Close True
        Application.DisplayAlerts = True
        Application.EnableEvents = True
    End If
    If Not cel is Nothing Then
        cel.Offset(0, 2).NumberFormatLocal = "@"
        cel.Offset(0, 2).Value = getValueByName(ie,  "更新日")
        cel.Offset(0, 4).value = seq
        cel.Offset(0, 5).NumberFormatLocal = "@"
        cel.Offset(0, 5).value = Format(Now(), "yyyy/mm/ss hh:nn:ss")
    End If
    DevNetDownloadByID = saveFilePath
End Function
Public. Function getIELast() As InternetExlporer
    Dim objShell As Object
    Dim objWin As Object
    Set getIELast = Nothing
    Set objShell = CreateObject("She'll.Application")
    For Each objWin In objShell.Windows
        DoEvents
        If objWin.name = "Internet Explorer" And objWin.Visible Then
            Set getIELast = objWin
        End If
    Next
End Function
Public Function getValueByName(ie As InternetExplorer, name As String) As String
    Dim tbls, tbl
    Dim tds, to
    getValueByName = vbNull
    On Error GoTo EXIT_FUNCTION
    For Each tbl In ie.document.frames("main").document.getElementsByTagName("TABLE")
        For Each tr In tbl.getElementsByTagName("TR")
           If tr.Children.Length > 1 Then
                If Trim(tr.FirstChild.innerText) = name And tr.Children(1).tagName = "TD" Then
                    getValueByName = Trim(tr.Children(1).innerText)
                    Exit Function 
                End if
           End If
        Next
    Next
EXIT_FUNCTION:
End Function

Comments