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 |
投稿 >