投稿‎ > ‎

VBAで遊ぼう③

posted Mar 18, 2016, 1:27 AM by Zhang Wenxu   [ updated Mar 18, 2016, 1:35 AM ]
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 name As String
    Dim td AsObject
    Application.ScreenUpdate = False
    Set ie = getProcenter()
    Call waitIE(ie)
    For Each link In ie.document.frames("main").document.links
        DoEvents
        If link.getEmentsByTagName("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")

                'File name
                Set td = link.parentElement
                For i = 1 To 7
                    Set td = td.nextSibling
                Next
                cel.Offset(0, 3).value = td.innerText

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

               'Seq
                Set td = link.parentElement
                For i = 1 To 2
                    Set td = td.nextSibling
                Next
                cel.Offset(0, 6).value = td.innerText
      
                cel.Parent.Cells(cel.row, "A").value = getDevNetPath(ie) & "/" & name
                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
           End If
       End If
NEXT_LINK:
     Next
     Application.ScreenUpdating = True
End Sub

Public Function getQueryString(href As String, key As String) As String
    Dim qs As Variant
    Dim q As Variant
    Dim keyValue As Variant

    qs = Split(href, "&")
    For Each q In qs
        DoEvents
        keyValue = Split(q, "=")
        If keyValue(0) = key Then
            getQueryString = keyValue(1)
            Exit For
        End If
     Next
End Function
 
Comments