vba modulo access

Por cesarhtc, Novembro 7, 2019 em Visual Basic

Recommended Posts

cesarhtc 0

Denunciar post

Postado Novembro 7, 2019

Boa tarde não estou conseguindo rodar o codigo abaixo:

Const IntervaloSegundos = 5 * 60 ' 5 minutos de intervalo
Sub Iniciar()
Alarme = Now + TimeSerial(0, 0, IntervaloSegundos)
Application.OnTime EarliestTime:=Alarme, procedure:="Macro_Atualizar_Tramite_web", schedule:=True
End Sub
Function Macro_Atualizar_Tramite_web()
On Error GoTo Macro_Atualizar_Tramite_web_Err

    DoCmd.SetWarnings False
    DoCmd.OpenQuery "CRIAR_TABELA_TRAMITACAO_CONTRATACAO", acViewNormal, acEdit
    DoCmd.OpenQuery "CRIAR_TABELA_TRAMITACAO_CONSUMO", acViewNormal, acEdit
    Beep
    MsgBox "Dados Atualizados!", vbExclamation, "Carga"


Macro_Atualizar_Tramite_web_Exit:
    Exit Function

Macro_Atualizar_Tramite_web_Err:
    MsgBox Error$
    Resume Macro_Atualizar_Tramite_web_Exit
Call Iniciar
End Function
 
Sub Parar()
On Error Resume Next
Application.OnTime EarliestTime:=Alarme, procedure:="Macro_Atualizar_Tramite_web", schedule:=False
End Sub

Obrigado

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ir para a lista de tópicos Visual Basic

- recuperando parametros simplexml_load_file
  
  Por daemon, Saturday às 18:11 em PHP
- PHP+Codeigniter - Adicionar Registro Plano de Contas
  
  Por violin101, Novembro 20 em PHP
- Javascript - Passar Parâmetros para uma Função.
  
  Por violin101, Outubro 28 em Javascript

Conteúdo Similar
- agregar dados em VBA excel
  Por biza
  
  Boa tarde,
  tenho um problema com VBA, que gostaria que me ajudassem a resolver, pretendo com recurso a código em VBA agregar os dados de forma a que eles sejam somados.
  Em baixo, existe uma imagem , com o exemplo do pretendido. A esquerda a tabela que possui os dados de forma massiva e a direita o pretendido.
  Será que alguém me pode auxiliar a resolver isto!
  Obrigado.
- Problemas com Pesquisar com filtros de pesquisa em VBA
  Por Pedro_Gomes
  
  Sou estudante de Programação e nunca tinha usado VBA e tenho de entregar um trabalho, mas nunca tive formação nesta linguagem, e estou a ter problemas no programa na parte de Pesquisar registros com filtros, já tentei ao máximo fazer seguindo tutoriais na internet, até que uma pessoua me ajudou e mandou-me codia e disse para fazer um passos só que eu nao sei seguir esses passos.
  Fico muito agradecido se alguém me conseguir ajudar.
  
  O que a pessoa me indicou:
  " Para testar o código coloque um filtro na planilha Dados no range A1:L1 e crie uma planilha com o nome de Auxiliar. Cole o código no formulário Pesquisar. "
  
  Option Explicit Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Call Filtro(TextBox1.Text, ComboBox1.Text) End Sub Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Call Filtro(TextBox2.Text, ComboBox2.Text) End Sub Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Call Filtro(TextBox3.Text, ComboBox3.Text) End Sub Private Sub UserForm_Initialize() ComboBox1.RowSource = "Relatório!A1:A12" ComboBox2.RowSource = "Relatório!A1:A12" ComboBox3.RowSource = "Relatório!A1:A12" End Sub Sub Filtro(ByVal Pesquisa As String, Campo As String) Dim Coluna As Integer Dim Area As Range Set Area = ThisWorkbook.Sheets("Dados").[A1:L1] Coluna = WorksheetFunction.Match(Campo, Area, 0) If Pesquisa <> "" Then If IsNumeric(Pesquisa) = False Then Pesquisa = "*" & Pesquisa & "*" Call Area.AutoFilter(Field:=Coluna, Criteria1:=Pesquisa) Call CopiaTabela Call PreencheListBox End If End Sub Sub CopiaTabela() ThisWorkbook.Sheets("Auxiliar").[A:L].Clear ThisWorkbook.Sheets("Dados").[A1].CurrentRegion.Copy ThisWorkbook.Sheets("Auxiliar").[A1].PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub Sub PreencheListBox() Dim Area As Range Set Area = ThisWorkbook.Sheets("Auxiliar").[A1].CurrentRegion ListBox1.ColumnCount = Area.Columns.Count ListBox1.ColumnHeads = True ListBox1.RowSource = "Auxiliar!" & Area.Offset(1).Address End Sub Link do Programa:
  https://drive.google.com/file/d/1ucJVL5Ijg0IcDqaFzoJi8aiMPb0NCbjI/view?usp=sharing
- Renomear vários arquivos com VBA
  Por gereiz
  
  Bom dia a todos. Adaptei um código para renomear vários arquivo com vba, que realiza a seguinte função:
  
  1) Eu seleiono a pasta,
  2) O VBA abre o PDF (Nota fiscal) , extrai a informação do texto e com a razão social fecha o pdf e renomeia ele com o nome extraido.
  
  O problema é que após renomear o primeiro arquivo corretamente a execução do código trava, e é necessário finalizar o processo.
  Segue abaixo o código.
  Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) Public Function ListaArquivos(ByVal Caminho As String) As String() 'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime Dim FSO As New FileSystemObject Dim result() As String Dim Pasta As Folder Dim Arquivo As File Dim Indice As Long ReDim result(0) As String If FSO.FolderExists(Caminho) Then Set Pasta = FSO.GetFolder(Caminho) For Each Arquivo In Pasta.Files Indice = IIf(result(0) = "", 0, Indice + 1) ReDim Preserve result(Indice) As String result(Indice) = Arquivo.Name Next End If ListaArquivos = result ErrHandler: Set FSO = Nothing Set Pasta = Nothing Set Arquivo = Nothing End Function Private Sub selecionar_pasta() Dim box As Folder Dim arquivos() As String Dim lCtr As Long Dim AdobeApp As String Dim StartAdobe Dim Arquivo As String Dim NomeAntigo As String Dim NomeNovo As String On Error Resume Next linha = 1 ultima_linha = Sheets("teste").Cells(Rows.Count, 1).End(xlUp).Row With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Buscar pasta" .InitialFileName = ThisWorkbook.Path .Show .AllowMultiSelect = False Pasta = .SelectedItems(1) End With TextBox1 = box arquivos = ListaArquivos(Pasta) Sleep 1000 For lCtr = 0 To UBound(arquivos) Debug.Print arquivos(lCtr) 'Inserir código aqui' 'Cells(linha, 1).Value = arquivos(lCtr) 'linha = (linha + 1) 'Sleep 500 pdf = arquivos(lCtr) AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe" Sleep 2000 For Each pdf In Pasta Adobefile = Pasta & "\" & pdf StartAdobe = Shell("" & AdobeApp & " " & """" & Adobefile & """" & "", 1) Sleep 2000 Application.SendKeys ("^a") Application.SendKeys ("^c") Sleep 2000 Dim KillPdf As String KillPdf = "TASKKILL /F /IM AcroRd32.exe" Shell KillPdf, vbHide AppActivate Application.Caption Sheets("teste").Range("A1").Activate SendKeys ("^v") DoEvents Dim Razao As String Razao = Sheets("teste").Range("A17").Value pontos = InStr(1, Razao, ":") qtdeLetras = Len(Razao) Nome = Right(Razao, qtdeLetras - pontos) Sheets("teste").Range("C1").Value = Nome Do While Not IsEmpty(Range("C1")) NomeAntigo = Pasta & "\" & pdf NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf" Sheets("teste").Range("C2").Value = Adobefile Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf" Name NomeAntigo As NomeNovo ' DoEvents Loop ' MsgBox "Nomes dos arquivos alterados!", vbOKOnly, "Processo Concluído" Next Next ' MsgBox ("Arquivos Encontrados = ") & (linha - 1) End Sub Já tentei de tudo, e não consegui resolver esse problema, se eu remover o Do while, ele executa normalmente, porem não renomeia os arquivos. Seu eu faço esse laço, ele renomeia só o primeiro e trava geral.
  
  Qualquer esclarecimento, agradeço.
- Exportar gráficos do Excel para slides específicos doPower Point em VBA
  Por kendy1290
  
  Olá! Estou com problema referente a exportação de gráficos do Excel via VBA para apresentação do PowerPoint. A maneira que encontrei, inclusive em várias fontes é de exportar vários gráficos de uma vez ou uma ,em uma nova apresentação. O que estou precisando é de exportar os gráficos do Excel em um arquivo do PowerPoint existente, em slides e locais específicos das apresentações. Se alguém tiver alguma ideia de como fazer seria de muita ajuda.
- [Resolvido] Erro em aplicação em VBA
  Por sapinhox
  
  Tenho um programa desenvolvido em VBA para Autocad, o mesmo tem duas linhas de programação que estão dando o seguinte erro:
  
  as linhas que estão dando erro são as seguintes
  
  Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
  Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
  
  Acredito que tenha alguma coisa a ver do fato do sistema instalado ser 64 bits, algum tem alguma solução para o caso.
  
  Desde já agradeço