投稿‎ > ‎

VBAで遊ぼう⑥

posted Mar 21, 2016, 11:10 PM by Zhang Wenxu   [ updated Jun 9, 2016, 1:58 AM ]
Public Const HWND_TOP As Long = 0
Public Const HWND_BOOTTOM As Long = 1
Public Const HWND_TOPMOST As Long = -1
Public Const HWND_NOTTOPMOST As Long = -2

Public Const SWP_SHOWWINDOW= &H40
Public Const SWP_HIDEWINDOW= &H80
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4

Public Const INPUT_MOUSE As Long = 0
Public Const MOUSE_MOVED As Long = &H1
Public Const MOUSEEVENT_LEFTUP As Long = &H4
Public Const MOUSEEVENT_LEFTDOWN As Long = &H2

Public Const TemporaryFolder = 2

PublicType Rect
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Public Type INPUT_TYPE
    dwType As Long
    xi(0 To 23) As Byte
End Type
Public Type MOUSEINPUT
    dX As Long
    dY As Long
    mouseData As Long
    dwFlags As Long
    time As Long
    dwExtraInfo As Long
End Type
PublicType MOEVENTS
    mx As Long
    my As Long
    mFrg As Long
End Type
Public Type POINTAPI
    x As Long
    y As Long
End Type 
Public Declare Sub CopyMemory Lib "kernel32.dll" _
    Alias "RtlMoveMemory" (destination As Any, source As Any, ByVal Length As Long)
Public Declare Function GetWindowRect Lib "user32"( _
    ByVal hWnd As Long, lpRect As Rect) As Long 
Public Declare Function SetWindowPos Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal wFlags As Long) As Long
Public Declare Function SendInput Lib "user32.dll" (_
     ByVal nInputs As Long, pInputs As INPUT_TYPE, _
     ByVal cbsize s Long) As Long
Public Sub DevNetPushActiveWorkbook()
    Dim ie As InternetExplorer
    Dim id As String
    Dim seq As String
    Dim updateLink As Object
    Dim changeReason As Object
    Dim replaceBtn As Object
    Dim clientRect As Object
    Dim updateBtn As Object
    Dim retryCnt As Integer
    Dim unlockBtn As Object
    ActiveWorkbook.Save
    id = getCustomProp(ActiveWorkbook, C_DEVNET_ID)
    If id = "" Then Exit Sub
RETRY_SEARCH:
    Set  ie = getProcenter()
    Call searchId(id)
    Call BringWindowToTop(ie.hWnd)
    Set unlockBtn = getInputByValue(ie, "ロック解除")
    If Not unlockBtn Is Nothing Then
         Call BringWindowToTop(Application.hWnd)
         MsgBox "ファイルがロックされています。", vbOKOnly, "DevNet Push"
         Exit Sub
    End If
    seq = getValueByName(ie, "SEQ")
    If seq <> getCustomProp(ActiveWorkbook, C_DEVNET_SEQ) Then 
        Call BringWindowToTop(Application.hWnd)
        MsgBox "SEQ is not the same. DEVNET SEQ:" & seq & " This workbook:" & getCustomProp(ActiveWorkbook, C_DEVNET_SEQ), vbOKOnly, "DevNet Push"
        Exit Sub
    End If
    Set updateLink = getLinkByInnerText(ie, "ファイルの登録 / 更新", False)
    If Not updateLink Is Nothing Then
        Call updateLink.Click
        Call waitIE(ie)
        Set changeReason = getInputByName(ie, "Reason")
        If Not changeReason Is Nothing Then
             ChangeReason.value = getModifyDescription(ActiveWorkbook)
             If changeReason.value = "" Then
                 changeReason.value = "Up ActiveWorkbook by IE"
             End If
        End If
        Set replaceBtn = getInputByName(ie, "$REPLACE", False)
        If Not replaceBtn Is Nothing Then
             Set clientRect = replaceBtn.getBoundingClientRect()
        End If
        Call BringWindowToTop(ie.hWnd)
        Dim mPos As POINTAPI
        mPos.x = clientRect.left + ie.document.frames("main").screenLeft + replaceBtn.clientWidth - 20
        mPos.y = clientRect.top + ie.document.frames("main").screenTop + replaceBtn.clientHeight / 2
        Call SetCursorPos(mPos.x, mPos.y)
        //Call ClickLeftButton
        ie.document.Script.setTimeout "javascript:" & vbCrLf & _
             "(function(){" & vbCrLf & _
             "    try{" & vbCrLf & _
             "        var inputs = document.frames('main').document.getElementsByTagName('INPUT');" & vbCrLf & _
             "        for(var i = 0; i < inputs.length - 1; i++){" & vbCrLf & _
             "             if(inputs[i].name.substring(0, 8) == '$REPLACE'){" & vbCrLf & _
             "                  inputs[i].click();" & vbCrLf & _
             "                  break;" & vbCrLf & _
             "             }" & vbCrLf & _ 
             "         }" & vbCrLf & _
             "     }catch(e){" & vbCrLf & _
             "         alert(e);" & vbCrLf & _
             "     }" & vbCrLf & _
             "}())", 100
                  
        Sleep 1000
        Call setDialogInputValue("アップロードするファイルの選択", "ファイル名(N):", ActiveWorkbook.FullName)
        Call clickDialogButton("アップロードするファイルの選択", "開く(O)")
        Set updateBtn = getInputByName(ie, "$EXEC")
        If Not updateBtn Is Nothing Then
             Call updateBtn.Click
             Call waitIE(ie)
             retryCnt = 0
RETRY_SEQ:
             seq = getValueByName(ie, "SEQ")
             If seq = "" Then
                 retryCnt = retryCnt + 1
                 If retryCnt < 10 Then
                     GoTo RETRY_SEQ
                 End If
             End If
             Call saveCustomProp(ActiveWorkbook, C_DEVNET_SEQ, seq)
         End If
    End If
    Set ie = getProcenter()
    Call SetWindowPos(ie.hWnd, HWND_BOTTOM, 0, 0, 0, 0, SWP_SHOWWINDOW + SWP_NOMOVE + SWP_NOSIZE)
End Sub
Public Sub saveCustomProp(wk As Workbook, key As String, value As String)
    Dim p
    For Each p In wk.CustomDocumenetProperties
        If p.name = key Then
            pt.value = value
            wk.Save
            Exit Sub
        End If
    Next
    Call wk.CustomDocumentProperties.Add(name:=key, LinkToContent:=False, Type:=msoPropertyTypeString, value:=value)
    wk.Save
End Sub
Public Function getModifyDescription(wk As WorkBook) As String
    Dim sh As Object
    Dim cel As Range
    getModifyDescription = ""
    For Each sh In wk.Sheets
        If sh.name = "改訂" Then
            Set cel = sh.Cells(WorksheetFunction.CountA(sh.Range("A6:A200")) + 5, "C")
            getModifyDescription = cel.value
            Exit Function
        End If
    Next
End Function
Public Sub DevNetUpdate()
    Dim cel As Range
    Dim filename As String
    Dim fso As New FileSystemObject
    Dim wk s Workbook
    Dim id As String
    Dim seq As String
    Dim path As String
    Dim celActive As Range
    Dim selCount As Integer
    Dim ie As InternetExplorer

    Set celActive = ActiveCell
    selCount = Selection.Cells.Count
    frmProgressBar.Show False
    For Each cel In Selection
       DoEvents
       text = cel.value
       If cel.value = "" Then GoTo NEXT_ROW
       If cel.EntireRow.Hidden Then GoTo NEXT_ROW
       
       id = getID(cel)
       seq = ""
       If Not re.Execute(text) Is Nothing And re.Execute(text).Count > 0 Then
            seq = re.Execute(text).Item(0).SubMatches(0)
       End If
       If id = "" Then
           filename = getFileName(cel)
           If filename = "" Then GoTo NEXT_ROW
           If Not fso.FileExists(filename) Then GoTo NEXT_ROW
           Set wk = Workbooks.Open(filename, False, True)
           id = getCustomProp(wk, C_DEVNET_ID)
           seq = getCustomProp(wk, C_DEVNET_SEQ)
           wk.Close False
       End If
       'path = "d:\"
       
       If seq <> "" Then
            filename = DevNetDownloadByIDAndSEQ(id, seq)
       Else
            filename = DevNetDownloadByID(id, workDir)
       End If
       If filename = "" Then
          GoTo NEXT_ROW
       End If
       cel.value = filename
       'Call HyperlinkCell(cel)
       cel.value = "=hyperlink(""" & filename & """, """ & text & """)"
NEXT_ROW:
    Next
    Unload frmProgressBar

    Call BringWindowToTop(celActive.Application.hWnd)
    Set ie = getProcenter()
    Call SetWindowPos(ie.hWnd, HWND_BOTTOM, 0, 0, 0, 0, SWP_SHOWWINDOW + SWP_NOMOVE + SWP_NOSIZE)
End Sub
Public Sub ClickLeftButton()
    Dim mes() As MOEVENTS
    ReDim Perserve mes(1) As MOEVENTS
    mes(0).mFrg = MOUSEEVENT_LEFTDOWN
    mes(1).mFrg = MOUSEEVENT_LEFTUP
    Call SendMouseInput(mes)
End Sub
Public Function SendMouseInput(ByRef mes() As MOEVENTS) As Integer
    Dim nInput As Integer
    Dim inputEvents() As INPUT_TYPE
    Dim MOUSEEVENT AS MOUSEINPUT
    nInput =UBound(mes)
    Dim i As Integer
    ReDim inputEvents(nInput) As INPUT_TYPE
    For i = 0 To nInput
        With mouseEvent
             .dX = mes(i).mx
             .dY = mes(i).my
             .mouseData = 0
             .dwFlags = mes(i).mFrg
             .time = 0
             .dwExtraInfo = 0
       End With
       inputEvents(i).dwType = INPUT_MOUSE
       CopyMemory inputEvents(i).xi(0), mouseEvent, Len(inputEvents(0)))
    Next
    SendMouseInput = SendInput(nInput + 1, inputEvents(0), Len(inputEvents(0)))
End Function

Public Sub DevNetSearchActiveworkbook()
    Dim ie As InternetExplorer
    Dim cel As Range
    Dim id As String
    id = getCsutomProp(ActiveWorkbook, C_DEVNET_ID)
    If id = "" Then
        Exit Sub
    End If
    Call searchID(id)
    Set ie = getProcenter()
    Call BringWindowToTop(ie.hWnd)
End Sub

Public Sub hyperlinkCell(cel As Range)
    Dim fso As New FileSystemObject
    Dim re As New RegExp
    Dim path As String
    re.Pattern = """"
    re.Global = True
    path = re.Replace(cel.value, "")
    re.Pattern = "file:///"
    path = re.Replace(path, "")
    If fso.FileExists(path) Then
        cel.NumberFormatLocal = "G/標準"
        cel.value = "=hyperlink(""" & path & """, """ & fso.getFilename(path) & """)"
   End If
End Sub
Public Sub hyperlinkIt()
    Dim cel As Range

    For Each cel In Selection
        DoEvents
        If cel.entrireRow.Hidden Then GoTo NEXT_CEL
        Call hyperlinkCell(cel)
NEXT_CEL:
     Next
End Sub

Public Function setDialoginputValue(dlgTitle As String, label As String, value As String) As Boolean
    Dim elmDialog As UIAutomationClient.IUIAutomationElement
    Dim cndEditControl As UIAutomaitonClient.IUIAutomationCondition
    Dim aryEditControl As UIAutomationClient.IUIAutomationElementArray
    Dim j As Integer
    Dim ptnVal As UIAutomationClient.IUIAutomationValuePattern
    Dim inputText As UAutomationClient.IUIAutomationElement
    Dim h As Long
    
    setDialogInputValue = False
    h = FindWindow(vbNullString, dlgTitle)
    If h = 0 Then Exit Function
    Dim uiAuto As New UIAutomationClient.CUIAutmation
    Set elmDialog = uiAuto.ElementFromHandle(ByVal h)
    Sleep 500
    Set cndEditControl = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_EditControlTypeId)
    Do 
         Set aryEditControl = elmDialog.FindAll(TreeScope_Subtree, cndEditControl)
         DoEvents
    Loop Until aryEditControl.Length > 0
    For j = 0 To aryEditControl.Length- 1
        DoEvents
        If LCase(aryEditControl.GetElement(j).CurrentName = LCase(label) Then
            Set inputText = aryEditControl.GetElement(j)
            Set ptnVal = inputText.GetCurrentPattern(UIA_ValuePatternId)
            ptnVal.SetValue value
            Exit For
         End If
    Next
    setDialogInputValue = True
End Function
Comments