Problem Set InvokePattern = Button.GetCurrentPattern (UIA_InvokePatternId) - vba

Question

Problem Set InvokePattern = Button.GetCurrentPattern (UIA_InvokePatternId) - vba

Navigation

#1 by (0 votes)

1

Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare PtrSafe Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Declare PtrSafe Function SetFocus Lib "user32.dll" (ByVal hWnd As Long) As Integer

Sub AtualizarBaseCRM()
    Dim ie As New InternetExplorerMedium
    Dim objEvent

    'COMANDO PARA DEIXAR O INTERNET EXPLORER VISIVEL
    'ie.Visible = True

    ie.navigate ("https://crm.cyrela.com.br")

    'AGUARDA O CARREGAMENTO DA PAGINA
    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend

    'CASO NÃO ESTEJA LOGADO, ENTRA COM O LOGIN E SENHA
    On Error GoTo BuscaAvancada
    ie.Document.getelementbyid("ContentPlaceHolder1_UsernameTextBox").Value = ThisWorkbook.Sheets("Apoio Importação").Cells(1, 2).Value
    ie.Document.getelementbyid("ContentPlaceHolder1_PasswordTextBox").Value = ThisWorkbook.Sheets("Apoio Importação").Cells(2, 2).Value
    ie.Document.getelementbyid("ContentPlaceHolder1_SubmitButton").Click

    'AGUARDA O CARREGAMENTO DA PAGINA
    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend
    BuscaAvancada:
    Err.Clear
    On Error GoTo 0
    'NAVEGA PARA O LINK DE LOCALIZAÇÃO AVNÇADA
    ie.navigate "https://crm.cyrela.com.br/main.aspx?extraqs=%3fDataProvider%3dMicrosoft.Crm.Application.Platform.Grid.GridDataProvi" _
              & "derQueryBuilder%26EntityCode%3d2029%26QueryId%3d%257b8EF40D37-0868-440C-AF6B-CAC0C62E78E3%257d%26UIProvider%3dMicrosoft.Crm.Application.Controls.GridUIProvider%26ViewType%3d1039&pagetype=advancedfind"

    'AGUARDA O CARREGAMENTO DA PAGINA
    Application.Wait (Now + TimeValue("00:00:01"))
    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend

    'SELECIONA A OPÇÃO DE RÉGUA DE REPASSE
    On Error Resume Next
    ºtentativas = 0
    ie.Document.getelementbyid("contentIFrame0").contentDocument.getelementbyid("slctPrimaryEntity").Value = "pjo_reguarepasse"
    Do Until Err.Number = 0
        Application.Wait (Now + TimeValue("00:00:01"))
        Err.Clear
        ie.Document.getelementbyid("contentIFrame0").contentDocument.getelementbyid("slctPrimaryEntity").Value = "pjo_reguarepasse"
        ºtentativas = ºtentativas + 1
        If ºtentativas > 30 Then
            MsgBox "falha no download, tente novamente!"
            ie.Quit
            Exit Sub
        End If
    Loop
    On Error GoTo 0

    'DISPARA O EVENDO DE ALTERAÇÃO DE VALOR NA COMBOBOX DO SITE
    Set objEvent = ie.Document.getelementbyid("contentIFrame0").contentDocument.createEvent("HTMLEvents")
    objEvent.initEvent "change", False, True
    ie.Document.getelementbyid("contentIFrame0").contentDocument.getelementbyid("slctPrimaryEntity").dispatchEvent objEvent

    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend

    'SELECIONA O RELATÓRIO ESPECIFICO
    ie.Document.getelementbyid("contentIFrame0").contentDocument.getelementbyid("savedQuerySelector").Value = "{883F9401-02B9-E711-80C0-00505695E94A}"

    'DISPARA O EVENTO DE ALTERAÇÃO DE VALOR NA COMBOBOX DE RELATÓRIOS
    Set objEvent = ie.Document.getelementbyid("contentIFrame0").contentDocument.createEvent("HTMLEvents")
    objEvent.initEvent "change", False, True
    ie.Document.getelementbyid("contentIFrame0").contentDocument.getelementbyid("savedQuerySelector").dispatchEvent objEvent

    'AGUARDA O CARREGAMENTO DA PAGINA
    Application.Wait (Now + TimeValue("00:00:01"))
    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend

    'CLICA NO BOTÃO PARA EXIBIÇÃO DO RESULTADO DA LOCALIZAÇÃO AVANÇADA
    On Error Resume Next
    ie.Document.getelementbyid("Mscrm.AdvancedFind.Groups.Show.Results-Large").Click
    ºtentativas = 0
    Do Until Err.Number = 0
        Application.Wait (Now + TimeValue("00:00:01"))
        Err.Clear
        ie.Document.getelementbyid("Mscrm.AdvancedFind.Groups.Show.Results-Large").Click
        ºtentativas = ºtentativas + 1
        If ºtentativas > 30 Then
            MsgBox "falha no download, tente novamente!"
            ie.Quit
            Exit Sub
        End If
    Loop
    On Error GoTo 0

    'AGUARDA O CARREGAMENTO DA PAGINA
    Application.Wait (Now + TimeValue("00:00:01"))
    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend


    'CLICA NA OPÇÃO DE EXPORTAÇÃO DO RELATÓRIO EM EXCEL NO CABEÇALHO DA PAGINA
    On Error Resume Next
    ie.Document.getelementbyid("pjo_reguarepasse|NoRelationship|SubGridStandard|Mscrm.SubGrid.pjo_reguarepasse.ExportToExcel-Large").Click
    ºtentativas = 0
    Do Until Err.Number = 0
        Application.Wait (Now + TimeValue("00:00:01"))
        Err.Clear
        ie.Document.getelementbyid("pjo_reguarepasse|NoRelationship|SubGridStandard|Mscrm.SubGrid.pjo_reguarepasse.ExportToExcel-Large").Click
        ºtentativas = ºtentativas + 1
        If ºtentativas > 30 Then
            MsgBox "falha no download, tente novamente!"
            ie.Quit
            Exit Sub
        End If
    Loop
    On Error GoTo 0

    'AGUARDA O CARREGAMENTO DA PAGINA
    Application.Wait (Now + TimeValue("00:00:01"))
    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend


    'COLOCA A OPÇÃO DE EXPORTAR EXCEL DE TODA EXTRAÇÃO E DA O OK PARA O DOWNLOAD
    On Error Resume Next
    ie.Document.getelementbyid("InlineDialog_Iframe").contentDocument.getelementbyid("printAll").Click
    ºtentativas = 0
    Do Until Err.Number = 0
        Application.Wait (Now + TimeValue("00:00:01"))
        Err.Clear
        ie.Document.getelementbyid("InlineDialog_Iframe").contentDocument.getelementbyid("printAll").Click
        ºtentativas = ºtentativas + 1
        If ºtentativas > 30 Then
            MsgBox "falha no download, tente novamente!"
            ie.Quit
            Exit Sub
        End If
    Loop
    On Error GoTo 0
    ie.Document.getelementbyid("InlineDialog_Iframe").contentDocument.getelementbyid("dialogOkButton").Click

    'AGUARDA O CARREGAMENTO DA PAGINA
    While ie.Busy Or ie.ReadyState <> 4
        DoEvents
    Wend

    'CONTA O NUMERO DE ARQUIVOS NA PASTA ANTES DO DOWNLOAD INICIAR
    ºArquivo = Dir("C:\Users\" & Environ("username") & "\Downloads\*.xls")
    ºN_arquivos = 0
    Do While ºArquivo <> ""
        ºN_arquivos = ºN_arquivos + 1
        ºArquivo = Dir
    Loop

    'FUNÇÃO PARA INICIAR O DOWNLOAD
    Application.Wait (Now + TimeValue("00:01:00"))
    hpass = ie.hWnd
    ie.Visible = True
    DownloadFile (hpass)
    ie.Visible = False

    'VERIFICA SE O DOWNLOAD ESTA CONCLUIDO COM BASE NO NUMERO DE ARQUIVOS NA PASTA
    ºN_arquivos_2 = 0
    Do Until ºN_arquivos_2 > ºN_arquivos
        ºArquivo = Dir("C:\Users\" & Environ("username") & "\Downloads\*.xls")
        ºN_arquivos_2 = 0
        Do While ºArquivo <> ""
            ºN_arquivos_2 = ºN_arquivos_2 + 1
            ºArquivo = Dir
        Loop
        Application.Wait (Now + TimeValue("00:00:02"))
    Loop

    ºArquivo_Baixado = NewestFile("C:\Users\" & Environ("username") & "\Downloads\", "*.xls")
    ºDestino_na_Rede = ThisWorkbook.Sheets("Apoio Importação").Cells(3, 2).Hyperlinks(1).Address

    If Dir(ºDestino_na_Rede) <> "" Then
        Kill ºDestino_na_Rede
    End If

    'COPIAR O ARQUIVO BAIXADO PARA O DESTINO
    FileCopy ºArquivo_Baixado, ºDestino_na_Rede

    'DELETA O ARQUIVO BAIXADO
    Kill ºArquivo_Baixado

    MsgBox "Download concluído!" & Chr(10) & " A importação sera iniciada"

    ie.Quit

    Call Importar

End Sub

Sub Importar()
    Application.ScreenUpdating = False
    CaminhoArquivo = ThisWorkbook.Sheets("Apoio Importação").Cells(3, 2).Hyperlinks(1).Address
    Workbooks.Open CaminhoArquivo, False, True
    ThisWorkbook.Sheets("base").UsedRange.ClearContents
    Workbooks(Dir(CaminhoArquivo)).Sheets(1).UsedRange.Copy
    ThisWorkbook.Sheets("base").Range("a1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    Workbooks(Dir(CaminhoArquivo)).Close False

    MsgBox "Importação concluída!"
    Sheets("Chart2").Activate
    Application.ScreenUpdating = True
End Sub

Sub DownloadFile(h As Long)
    Dim o As IUIAutomation
    Dim e As IUIAutomationElement
    Dim iCnd As IUIAutomationCondition
    Dim Button As IUIAutomationElement
    Dim InvokePattern As IUIAutomationInvokePattern

    Set o = New CUIAutomation
    h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
    If h = 0 Then Exit Sub

    Set e = o.ElementFromHandle(ByVal h)
    Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Salvar")
    Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
    Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
    InvokePattern.Invoke
End Sub

Function NewestFile(Directory, FileSpec)

    Dim FileName As String
    Dim MostRecentFile As String
    Dim MostRecentDate As Date

    FileName = Dir(Directory & FileSpec)

    If FileName <> "" Then
        MostRecentFile = FileName
        MostRecentDate = FileDateTime(Directory & FileName)
        Do While FileName <> ""
            If FileDateTime(Directory & FileName) > MostRecentDate Then
                MostRecentFile = FileName
                MostRecentDate = FileDateTime(Directory & FileName)
            End If
            FileName = Dir
        Loop
    End If

    NewestFile = Directory & MostRecentFile

End Function

vba

asked by anonymous 19.06.2018 / 16:12

1 answer

Error (Bitmap size too big) when using Timage in android firemonkey thread Error opening the V10 platform of an external application

score 0 · Answer 1

Reference

The UIAutomationClient reference must be added to the VBA project.

Code

'x64
Public Sub AddReference64()
    ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\SysWOW64\UIAutomationCore.dll"
End Sub

'x86
Public Sub AddReference64()
    ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\System32\UIAutomationCore.dll"
End Sub

Manually

To manually add, copy the file UIAutomationCore.dll to the Documents folder. Where the file path is specified previously.

And add the reference within VBE in Ferramentas -> Referências...

NormallyyouwouldnotneedtomovetotheDocumentsfolder,butthisparticularreferencehasabuginsomeversions...

SomeDeclarationsthatmaychangetox64

'https://www.jkp-ads.com/articles/apideclarations.asp'FindWindowPrivateDeclarePtrSafeFunctionFindWindowLib"USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
 Private Declare PtrSafe Function FindWindowEx Lib "USER32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
'Declarações
Declare PtrSafe Function SetWindowText Lib "USER32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Declare PtrSafe Function SetForegroundWindow Lib "USER32" (ByVal hWnd As Long) As Long
Declare PtrSafe Function SendMessageByString Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Declare PtrSafe Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare PtrSafe Function GetWindowTextLength Lib "USER32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Declare PtrSafe Function SetFocus Lib "user32.dll" (ByVal hWnd As Long) As Integer
Public Declare PtrSafe Function GetWindowText Lib "USER32" Alias "GetWindowTextA" _
                                      (ByVal hWnd As LongPtr, ByVal lpString As String, _
                                       ByVal cch As LongPtr) As Long
Private Declare Function URLDownloadToFileA Lib "urlmon" (ByVal pCaller As Long, _
    ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long

'Declara função Sleep
'https://stackoverflow.com/questions/41638504/sleep-lib-kernel32-gives-64-bit-systems-error
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

Extra

As the link you were unable to access, it is probably only used as an Intranet.

Here is an example of a file link download ...

Code

Dim IE As Object, Links As Object
Dim link As Variant, d_link As String
Dim h As LongPtr
Set IE = CreateObject("InternetExplorer.Application")

IE.navigate "http://www.cpearson.com/excel/Downloads.aspx"
IE.Visible = True

EsperaIE IE, 2000
Set Links = IE.document.getElementsByTagName("a")
For Each link In Links
    Debug.Print link
    If link = "http://www.cpearson.com/Zips/AlerterSample.ZIP" Then
        d_link = link
        downloadFile d_link, ThisWorkbook.Path & "\download-teste.zip"
        Exit For
    End If
Next link

Download Sub

Sub downloadFile(url As String, filePath As String)
'https://stackoverflow.com/questions/49198016/opening-the-downloaded-file-from-a-website?noredirect=1&lq=1
'ashleedawg
    Dim WinHttpReq As Object, attempts As Integer, oStream
    attempts = 3
    On Error GoTo TryAgain
TryAgain:
    attempts = attempts - 1
    Err.Clear
    If attempts > 0 Then
        Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
        WinHttpReq.Open "GET", url, False
        WinHttpReq.send

        If WinHttpReq.Status = 200 Then
            Set oStream = CreateObject("ADODB.Stream")
            oStream.Open
            oStream.Type = 1
            oStream.Write WinHttpReq.responseBody
            oStream.SaveToFile filePath, 2 ' 1 = no overwrite, 2 = overwrite
            oStream.Close
            MsgBox "Arquivo baixado para:" & vbLf & filePath
        End If
    Else
        MsgBox "Falhou."
    End If

End Sub

Expect IE

Public Sub EsperaIE(IE As Object, Optional time As Long = 250)
    'Código de: https://stackoverflow.com/questions/33808000/run-time-error-91-object-variable-or-with-block-variable-not-set
    Dim i As Long
    Do
        Sleep time
        Debug.Print CStr(i) & vbTab & "Ready: " & CStr(IE.readyState = 4) & _
                    vbCrLf & vbTab & "Busy: " & CStr(IE.Busy)
        i = i + 1
    Loop Until IE.readyState = 4 Or Not IE.Busy
End Sub