投稿‎ > ‎

VBAで遊ぼう

posted Mar 17, 2016, 12:06 AM by Zhang Wenxu   [ updated Jul 12, 2016, 5:50 PM ]
Public Declare Sub Sleep Lib "kernel32"(ByVal dwMilliseconds As Long)
Public Function openDevNet() As InternetExplorer
    Dim ie As InternetExplorer
    Dim retryCnt As Integer
    
    retryCnt = 5
    Set ie = New InternetExplorer
    ie.Visible = True
RETRY_LOAD:
    On Error Resume Next
    Sleep 1000
    Ie.Navigate2 "http://qmsrv041.nndn.nri.co.jp/Top/Aa/fap0000.htm"
    If Err.Number <> 0 Then
        Err.Clear
        If retryCnt = 0 Then
             Set ie = Nothing
             Set openDevNet = Nothing
             Exit Function
        End If
        retryCnt = retryCnt - 1
        GoTo RETRY_LOAD
    End If
    Set ie = Nothing
    Sleep 1000
    Set ie = getIEByTitle("DevelopersNet")
    Call waitIE(ie)
    ie.document.all("kaisha").value = "your kaisha code"
    ie.document.all("user").value = "your user ID"
    ie.document.all("pass_in").value = "your password"

    Call ie.document.all("logon").Click
    Set ie = Nothing
RETRY_BIZMART_LOGON:
    DoEvents
    Set ie = getIEByTitle("BizMart ログオン")

    Call getImageByAlt(ie, "ログオン").Click
    Set ie = Nothing
    Set ie = getIEByTitle("BizMart")
    If ie Is Nothing Then GoTo RETRY_BIZMART_LOGON
    Call getLinkByInnerText(ie, "PROCENTERトップ").Click
    Call waitIE(ie)
    Set ie = getIEByTitle("PROCENTER")
    Set openDevNet = ie
End Function

Public Function getIEByTitle(title As String, Optional bExactMatch = True) As InternetExplorer
    Dim objShell As Object
    Dim objWin As Object
    Dim retryCnt As Integer

    retryCnt = 5
 RETRY_:
    Set getIEByTitle = Nothing
    Set objShell = CreateObject("Shell.Application")
    For Each objWin In objShell.Windows
         DoEvents   
         If objWin.name = "Internet Explorer" Then
              If bExactMatch And title = objWin.LocationName Or Not bExactMatch And InStr(objWin.LocationName, title) > 0 Then
                   Set getIEByTitle = objWin
                   Exit Function
              End If
         End If
     Next
     If retryCnt = 0 Then
          Exit Function
     End If

     retryCnt = retryCnt - 1
     Sleep 1000
     GoTo RETRY_
End Function

Public Sub waitIE(ie As InternetExplorer)
    On Error Resume Next
    Do While ie.Busy
          DoEvents
          Sleep 100
     Loop
     Do While ie.document.readyState <> "complete"
           DoEvents
           Sleep 100
     Loop
 End Sub

Public Function getImageByAlt(ie As InternetExplorer, alt As String) As Object
    Dim img
    Set getImageByAlt = Nothing
    For Each img In ie.document.images
         DoEvents
         If img.alt = alt Then
             Set getImageBtAlt = img
              Exit Function
         End If
     Next
End Function

Public Function getLinkByInnerText(ie As InternetExplorer, innerText As String, Optional bExactMatch = True) As Object
    Dim link
    Dim frm
    Dim i
    Set getLinkByInnerText = Nothing
    For Each link In ie.document.links
         DoEvents
         If bExactMatch And innerText = trim(link.innerText) Or Not bExactMatch And InStr(trim(link.innerText), innerText) > 0 Then
              Set getLinkByInnerText = link
              Exit Function
         End If
     Next

    For i = 0 To ie.document.frames.Length - 1
         Set frm = ie.document.frames(i)
         For Each link In frm.document.links
                DoEvents
                If bExactMatch And innerText = trim(link.innerText) Or Not bExactMatch And InStr(trim(link.innerText), innerText) > 0 Then
                      Set getLinkByInnerText = link
                      Exit Function
                End If
         Next
    Next
End Function
         
Public Sub DevNetSearch()
    Dim cel As Range
    Dim id As String
    Dim ie As InternetExplorer
    Set cel = ActiveCell
    id = getID(cel)
    Call searchID(id)
    Set ie = getProcenter()
    Call BringWindowToTop(ie.hWnd)
End Sub

public Function colName(col As Integer) As String
    colName = Split(Cells(1, col).Address, "$")(1)
End Function
Public Function colNum(name As String) As Intger
    colNum = Columns(name).Column
End Function
Comments