投稿‎ > ‎

VBAで遊ぼう②

posted Mar 17, 2016, 10:42 PM by Zhang Wenxu   [ updated Jun 14, 2016, 2:53 AM ]
Public Sub listDevNet()
    Dim cel As Range
    Dim ie As InternetExplorer
    Dim id As String
    Dim searchBox As Object
    Dim fromNID As String
    Dim path As String

    Set cel = ActiveCell

    id = getID(cel)
    If id <> "" Then
        Call searcID(id)
    Else
        Exit Sub
    End If
    fromNID = id
    Set ie = getProcenter()
    path = getDevNetPath(ie)
    Call listDevNetContinueFirst(fromNID, path)
    End If
End Sub
Public Function getProcenter() As InternetExplorer
    Dim objShell As Object
    Dim objWin As Object
    Dim loginBtn As Object
    Set getProcenter = Nothing
RETRY_GET_PROCETNER:
    Set objShell = CreateObject("Shell.Application")
    For Each objWin In objShell.Windows
        DoEvents
        If objWin.name = "Internet Explorer" Then
             If "PROCENTER" = objWin.LocationName Then
                  Set getProcenter = objWin
                  Exit For
             End If
        End If
     Next
     If getProcetner Is Nothing Then
         Set objShell = CreateObject("Shell.Application")
         For Each objWin In objShell.Windows
             DoEvents
             If objWin.Name = "Internet Explorer"Then
                 If "BizMart" = objWin.LocationName Then
                     Call getLinkByInnerText(objWin,"PROCENTER トップ”.Click
                     Call waitIE(objWin)
                     Set getProcenter = getIEByTitle("PORCENTER")
                     Exit For
                 End If
             End If
          Next
      End If
     If getProcenter Is Nothing Then
         Set getProcenter = openDevNet()
     End If
     If getProcenter Is Nothing Then
         GoTo RETRY_GET_PROCENTER
     End If
     If Not getProcenter.document.all("Password") Is Nothing Then
          getProcenter.document.all("Password").value = "your password"
          Set loginBtn = getInputByAlt(getProcenter, "ログイン"）
          Call loginBtn.Click
          Call waitIE(getProcenter)
     End If
End Function
Public Sub listFiles(cel As Range)
    Dim link As Object
    Dim ie As InternetExplorer
    Dim iconName As String
    Dim fso As New FileSystemObject
    Dim i As Integer
    Dim tdFilename As Object
    Dim tdClassName As Object
    Dim tdUpdateTime As Object
    Dim tdName As Object
    Dim tdSeq As Object
    Application.ScreenUpdating = False
    Set ie = getProcenter()
    Call waitIE(ie)
    For Each link In ie.document.frames("main").document.links
        DoEvents
        If link.getElementsByTagName("IMG").Length > 0 Then
            iconName = fso.getFilename(link.getElementsByTagName("IMG")(0).src)
            If link.innerText = "ファイル登録" Then
                GoTo NEXT_LINK
            End If
            If iconName = "file_node.gif" Then
                name = Trim(link.innerText)
                cel.Offset(0, 1).value = name
                cel.Offset(0, 2).NumberFormatLocal = "@"
                cel.Offset(0, 2).value = getQueryString(link.href, "Nid")
                'Filename
                Set tdFilename = link.parentElement
                For i = 1 To 7
                     Set tdFilename = tdFilename.nextSibling
                Next
                cel.Offset(0, 3).value = tdFilename.innerText
    
               'Update time
                Set tdUpdateTime = link.parentElement
                For i = 1 To 4
                     Set tdUpdateTime = tdUpdateTime.nextSibling
                Next
                cel.Offset(0, 4).NumberFormatLocal = "@"
                cel.Offset(0, 4).value = tdUpdateTime.innerText

               'Class name
                Set tdClassName = link.parentElement
                For i = 1 To 9
                     Set tdClassName = tdClassName.nextSibling
                Next
                cel.Offset(0, 5).NumberFormatLocal = "@"
                cel.Offset(0, 5).value = tdClassName.innerText
              
                'Seq                Set tdUpdateTime = link.parentElement
                For i = 1 To 4
                     Set tdUpdateTime = tdUpdateTime.nextSibling
                Next
                cel.Offset(0, 4).NumberFormatLocal = "@"
                cel.Offset(0, 4).value = tdUpdateTime.innerText

 Private Function gotoPath(path As String) As Object
    Dim ie As InternetExplorer
    Dim searchBox As Object
    Dim searchBtn As Objejct
    Dim leafItem As Object
    Dim nextSibling As Object
    Dim pathItem As Object
    Dim startIndex As Integer
    Dim i As Integer
    Dim pnides As String
    Dim nid As String
    Dim href As String
    Dim fso As New FileSystemObject
    nid = ""
    Set gotoPath = Nothing
    Set ie = getProcenter()
    StartIndex = 0
    For Each pathItem In Split(path, "/")
        DoEvents
        pathItem = Replace(pathItem, "%2f", "/")
        For i = startIndex To ie.document.frames("sidetree").document.links.Length - 1
             DoEvents
             Set leatItem = ie.document.frames("sidetree").document.links(i)
             pnides = getQueryString(leafItem.href, "Pnides")
             If Trm(leafItem.innerText) = pathItem And right(pnides, Len(nid)) = nid Then
                 startIndex = i + 1
                 Set gotoPath = leafItem
                 nid = getQueryString(leafItem.href, "Nid")
                 href = gotoPath.href
                 If gotoPath.PreviousSibling.Children.Length > 0 Then
                     If fso.getFilename(gotoPath.PrevisouSibling.Children(0).src) = "html_tree_close2.gif" _
                         Or fso.getFilename(gotoPath.PreviousSibling.Children(0).src) = "html_tree_close3.gif" Then
                         Call gotoPath.PreviousSibling.Click
                         Call waitIE(ie)
                     End If
                 End If
                 Exit For
            End If
        Next
     Next
     Set gotoPath = findLinkByHref(href)
     Call gotoPath.Click
     Call waitIE(ie)
     Set gotoPath = findLinkByHref(href)
End Function

Public Function getID(cel As Range) As String
    Dim reg As New RegExp
    Dim matches As Object
    getID = ""
    On Error GoTo EXIT_SUB
    reg.Pattern = "\d{10,10}"
    Set matches = reg.Execute(cel.value)
    getID = matches.Item(0).value
EXIT_SUB:
End Function 
   
Public Sub listDevNetContinueFirst(fromNID As String, path As String, Optional idUpdate As String)
    Dim cel As Range
    Dim nid As String
    Dim nextSibling As Object
    Dim fso As New FileSystemObject
    Dim iconNam AsString
    Dim href As String
    Dim pnides As String
    Dim br As Object
    Dim col As Integer
    Dim ie As InternetExplorer
    Dim searchBox As Object
    Dim searchBtn As Object
    Dim retryCnt As Integer
    Dim leafItem As Object
    Dim pathItem As Object
    Dim ret As Boolean 

    Set cel = ActiveCell
    Call searchID(fromID)
    Set ie = getProcenter()
    If Instr(ie.document.frames("main").document.body.innerText, "検索に失敗しました") > 0 Then
        MsgBox "検索に失敗しました", vbOKOnly, "DevNetList"
        Exit Sub
    End If
    Set treeItem = gotoPath(path)
    If Instr(ie.document.frames("side tree").document.body.innerText, "HTTP エラー") > 0 Then
        Call refreshIE
    End If
CONTINUE_LIST:
    nid = getQueryString(treeItem.href, "Nid")
    Set br = treeItem.PreviousSibling
    col = 0
    Do While Not br Is Nothing
         DoEvents
         If br.tagName = "BR" Then
               Exit Do
         End If
         col = col + 1
         Set br = br.PreviousSibling
     Loop
     col = col - 2
      
    cel.Offset(0, col).value = treeItem.innerText
    cel.Offset(0, 1 + col).NumberFormatLocal = "@"
    cel.Offset(0, 1 + col).value = nid

    Set cel = cel.Offset(1, 0)
    If Application.WorksheetFunction.CountA(Rows(cel.row)) > 0 Then
         cel.EntireRow.Insert
         Set cel = cel.Offset(-1, 0)
    End If
    Call listFiles(cel)

    Set nextSibling = treeItem.nextSibling
    Do While Not nextSibling Is Nothing
         DoEvents
                       If TypeName(nextSibling.getAttribute("href")) <> "Null" Then
                            href = nextSibling.getAttribute("href")
                            pnides = getQueryString(nextSibling.href, "Pnides")
                            If pnides <> "" And InStr(pnides, fromNID) < 1 Then
                                 Exit Do
                            End If
                            If pnides <> "" And idUpdate <> "" Then
                                If InStr(pnides, idUpdate) < 1 Then
                                     Exit Do
                                End If
                            End If
                       End If
         If nextSibling.getElementsByTagName("IMG").Length > 0 Then
              iconName = fso.getFilename(nextSibling.getElementsByTagName("IMG")(0).src)
              If iconName = "html_tree_close3.gif" Then
                   href = nextSibling.nextSibling.href
                   Call nextSibling.nextSibling.Click 
                   Call Sleep(500)
                   retryCnt = 0
 RETRY_IT2:
                   Set nextSibling = findLinkByHref(href)
                   path = getDevNetPath(ie)
                   If nextSibling Is Nothing Then
                        retryCnt = retryCnt + 1
                        If retryCnt > 15 Then
                            Call refreshIE
                        End If
                        Sleep 500
                        GoTo RETYR_IT2
                     Else
                         Set br = nextSibling.PreviousSibling
                         col = 0
                         Do While Not br Is Nothing
                             DoEvents
                             If br.tagName = "BR" Then
                                 Exit Do
                             End If
                             col = col + 1
                             Set br = br.PreviousSibling
                         Loop
                         col = col - 2
                         If Application.WorksheetFuntion.CountIf(cel.Parent.Range("C2:C" & (cel.row - 1)), getQueryString(nextSibling.href, "Nid")) > 0 Then
                              Set nextSibling = nextSibling.nextSilbing
                              GoTo CONTINUE_NEXT
                          End If
                          href = nextSibling.href
                          pnides = getQueryString(hreg, "Pnides")
                          path = getDevNetPath(ie)
                            If pnides <> "" And InStr(pnides, fromNID) < 1 Then
                                 Exit Do
                            End If
                            If pnides <> "" And idUpdate <> "" Then
                                If InStr(pnides, idUpdate) < 1 Then
                                     Exit Do
                                End If
                            End If
                          'Application.ScreenUpdating = False
                          cel.Offset(0, col).NumberFormatLocal = "@"
                          cel.Offset(0, col).value = nextSibling.innerText
                          cel.Offset(0, 1 + col).NumberFormatLocal = "@"
                          cel.Offset(0, 1 + col).value = getQueryString(href, "Nid")
                          cel.Parent.Cells(cel.row, "A").value = path
                          Set cel = cel.Offset(1, 0(
                          Call listFiles(cel)    
                     End If
                     GoTo CONTINUE_NEXT
                  End If
                  If nextSibling.taName = "A" And _
                       (iconName = "folder_node_link.gif" Or iconName = "folder_node.gif" Then
                       Set br = nextSiblingPreviousSibling
                       col = 0
                       Do While Not br Is Nothing
                            DoEvents
                            If br.tagName = "BR" Then
                                Exit Do
                            End If
                            col = col + 1
                            Set br = br.PreviousSibling
                      Loop
                      col = col - 2
                      If Application.WorksheetFunction.CountIf(cel.Parent.Range("C2:C" & (col.row - 1)), getQueryString(nextSibling.href, "Nid")) > 1 Then
                           Set nextSibling = nextSibling.nextSibling
                           GoTo CONTINUE_NEXT
                      End If
                      href = nextSibling.href
                      pnides = getQueryString(href, "Pnides")
                      Call nextSibling.Click
                      Call Sleep(1000)
                      Set nextSibling = findLindByHref(href)
                      path = getDevNetPath(ie)
                      Application.ScreenUpdating = False
                      cel.EntireRow.Insert
                      Set cel = cel.Offset(-1, 0)
                      cel.Offset(0, col).NumberFormatLoal = "@"
                      cel.Offset(0, col).value = nextSibling.innerText
                      cel.Offset(0, 1 + col).NumberFormatLocal = "@"
                      cel.Offset(0, 1 + col).value = getQeuryString(nextSibling.href, "Nid")
                      path = getDevNetPath(ie)
                      Cel.Parent.Cells(cel.row, "A").value = path
                      Set cel = cel.Offset(1, 0)
                      If Application.WorksheetFunction.CountA(Rows(cel.row)) > 0 Then
                          Cel.EntireRow.Insert
                          Set cel = cel.Offset(-1, 0)
                     End If
                     Application.ScreenUpdating = True
                     Call listFiles(cel)
                 End If
            End If
CONTINUE_NEXT:
            If nextSibling Is Nothing Then
                Call expandPath(fromNID, path)
                Set nextSibling = gotoPath(path)
            End If
            Set ie = getProcenter()
            If InStr(ie.document.frames("sidetree").document.body.innerText, "HTTP エラー") > 0 Then
                Call refreshIE
            End If
            If nextSibling Is Nothing Then
                retryCnt = retryCnt + 1
                If retryCnt > 10 Then
                    Call refreshIE
                End If
                Sleep 500
                GoTo CONTINUE_NEXT
            End If
            On Error Resume Next
            Set nextSibling = nextSibling.nextSibling
            If nextSilbing Is Nothing Then Exit Do
            nextSibling.Style.Border = "2px solid red" 
            If Err.Number <> 0 Then
                Set nextSibling = Nothing
                GoTo CONTINUE_NEXT
            End If
            retryCnt = 0
       Loop
       cel.Select
       Application.ScreenUpdating = True
End Sub

Private Sub refreshIE()
    Dim ie As InternetExploer
    Dim ret As Boolean
    
REFRESH_IE:
    Set ie = getProcenter()
    Call BringWindowToTop(ie.hWnd)
    Sleep 500
    Ie.Refresh2
    Ret = clickDialogButton("Windows Internet Explorer", "再試行(R)")
End Sub

Public Sub doExpandPath()
    Dim frmNID As String
    Dim path As String
    Dim ie As InternetExplorer
    fromNID = getID(Cells(1, 1))
    path = ActiveCell.value
    Call expandPath(fromNID, path)
    Set ie = getProcenter()
    Call BringWindowToTop(ie.hWnd)
End Sub

Private Sub expandPath(fromNID As String, path As String)
    Dim ie As InternetExplorer
    Dim searchBox As Object
    Dim searchBtn As Object
    Dim leftItem As Object
    Dim nextSibling As Object
    Dim pathItem As Object
    Dim startIndex As long
    Dim I As long
    Dim imgs As Object
    Dim fso As New FileSystemObject
    Dim imageName As String
    Dim pnids As String
    Dim nid As String
    nid = ""
    Call seachID(fromNID)
    Set ie = getProcenter()
    startIndex = 0
    For Each pathItem in Split(path, "/")
        DoEvents
        pathItem = Replace(pathItem, "%2f", "/")
DO_NEXT_IMG:
        Set imgs = ie.document.frames("sidetree").document.images
        For i = startIndex To imgs.Length - 1
            DoEvents
            Set leafItem = imgs(i)
            imageName = fso.getFilename(leafItem.src)
            If imageName = "html_tree_open1.gif" Or imageName = "html_tree_open2.gif" Or imageName = "html_tree_open3.gif" Then
                If Trim(leafItem.ParentNode.nextSibling.innerText) = pathItem Then
                    Call leafItem.ParentNode.nextSibling.Click
                    Sleep 1000
                    Exit For
               End If
               If Instr(path &"/", "/" & Trim(leafItem.ParentNode.nextSibling.innerText) & "/") > 0 Then
               Else
                   Call leafItem.Click
                   Sleep 1000
                   Set imgs = ie.document.frames("sidetree").document.images
                   GoTo DO_NEXT_IMG
              End If
          End If
          If imageName = "html_tree_close1.gif" Or imageName = "html_tree_close2.gif" Or imageName = "html_tree_close3.gif" Then
              pnides = getQueryString(leafItem.href, "Pnides")
              If Trim(leafItem.ParentNode.nextSibling.innerText) = pathItem And right(pnides, Len(nid)) = nid Then
                  nid = getQueryString(leafItem.href, "Nid")
                  Call leafImte.ParentNode.nexSiblikng.Click
                 Sleep 1000
                 Exit For
             End If
         End If
         If imageName = "folder_node.gif" Then
             pnides = getQueryString(leafItem.href, "Pnides")
             If Trim(leafItem.ParentNode.innterText) = pathItem And right(pnides, Len(nid)) = nid Then
                 nid = getQueryString(leafItem.href, "Nid")
                 Call leatItem.ParentNode.Click
                 Sleep 1000
                 Exit For
             End If
         End If
NEXT_IMG:
      Next
    Next
End Sub

Public Sub searchID(id As String)
    Dim ie As InternetExplorer
    Dim searchBox As Object
    Dim searchBtn As Object
    Dim loginBtn As Object
 RETRY_SEARCH:
    Set ie = getProcenter()
    Set searchBox = getInputByName(ie, "@i_ID=")
    searchBox.value = id
    Set searchBtn = getIputByValue(ie, "検索")
    Call searchBtn.Click
    Call waitIE(ie)
    If ie.document.frames.Length = 0 Then
        ie.document.all("Password").value = "your password"
        Set loginBtn = getInputByAlt(ie, "ログイン")
        Call loginBtn.Click
        Call waitIE(ie)
        GoTo RETRY_SEARCH
    End If
End Sub
Public Function getDevNetPath(ie As InternetExplorer) As String
    Dim link As Object
    Dim font As Object
    Dim firstRowInMain As Object
    Set firstRowInMain = ie.document.frames("main").document.getElementsByTagName("TR")(0)
    getDevNetPath = ""
    For each link In firstRowInMain.getElementsByTagName("A")
       getDevNetPath = getDevNetPath & Trim(link.innerText) & "/"
    Next 
    For Each font In firstRowInMain.getElementsByTagName("FONT")
       If font.getAttribute("color") = "#000080" Then 'navy
            GetDevNetPath = getDevNetPath & Replace(Trim(font.innerText), "/", "%2f")
             Exit For
       End If
    Next
End Function
Public Function getImageByAlt(ie As InternetExplorer, alt As String) As Object
    Dim img As Object
    Set getImageByAlt = Nothing
    For Each img In ie.document.images
        If img.alt = alt Then
            Set getImageByAlt = img
            Exit Funciton
        End If
     Next
End Function

Public Function clickDialogButton(dlgTitle As String, caption As String) As Boolean
    Dim elmDialog As UIAutoamtionClient.IUIAutomaitonElement
    Dim j As Integer
    Dim cndButtonName As UIAutomationClient.IUIAutomationCondition
    Dim elmButton As UIAutomationClient.IUIAutomationElement
    Dim ptnButton As UIAutomationClient.IUIAutomationLegacyIAccssiblePattern
    Dim h As Long
    Dim uiAuto As New UIAutomationClient.CUIAutomation

    clickDialogButton = False
    h = FindWindow(vbNullString, dlgTitle)
    If h = 0 Then Exit Function
    Set elmDialog = uiAuto.ElementFromHandle(ByVal h)
    Set cndButtonName = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, caption)
    Set elmButton = elmDialog.FindFirst(TreeScope_Subtree, cndButtonName)
    Set ptnButton = elmButton.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
    ptnButton.DoDefaultAction
    clickDialogButton = True
End Function
Comments