VBA-Access

10/04/2023

DoCmd

Abrir Relatório
DoCmd.OpenReport “NomeRel”, acViewPreview
Abrir Relatório com filtro
DoCmd.OpenReport “NomeRel”, acViewPreview, , “CampoRel= ” & Me!CampoForm

Gerar Relatório em PDF
DoCmd.OutputTo acOutputReport, “Rel”, acFormatPDF, “c:\_Dsv\Rel.pdf”

Abrir Formulário
DoCmd.OpenForm “Nome Formuário”

Abrir Macro
DoCmd.RunMacro “NomeMacro”

Filtrar dados do Formulário
xCodBacia = [Forms]![frmBacias]![txtCodBacia]
DoCmd.ApplyFilter , “CodBacia = ” & xCodBacia ‘ Campo Numérico

DoCmd.ApplyFilter , “LastName = ‘Silva'” ‘ Campo Texto

Abrir Consulta
DoCmd.OpenQuery “NomeConsulta”, acNormal, acEdit

Atualizar
DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70

Gerar Relatório PDF – Individual – Um arquivo para cada Agente
Function PDF_ProduçãoDiáriaAnalítica() ‘ produção Diária – Analítico
DoCmd.SetWarnings False
Dim dbs As Database, qdf As QueryDef, rst, rsDt As Recordset
Dim i As Integer
Dim diaMov, TitRel As String
Set dbs = CurrentDb
DoCmd.RunSQL (“UPDATE Agente set x2 = false”)
DoCmd.RunSQL (“UPDATE tblDadosDiáriosEmp_01 INNER JOIN Agente ON tblDadosDiáriosEmp_01.[Chave J] = Agente.CHAVE SET Agente.x2 = Yes”) ‘********
DoCmd.RunSQL (“UPDATE Agente set x1 = false”)
Set rst = dbs.OpenRecordset(“qryAgenteImpressão01”)
Set rsDt = dbs.OpenRecordset(“Auxilio”) ‘********** DtDadosDiários
diaMov = Format(Day(rsDt!DtDadosDiários), “00”) & “-” & Format(Month(rsDt!DtDadosDiários), “00”) & “-” & Format(Year(rsDt!DtDadosDiários), “0000”)
With rst
.MoveFirst
Do While Not .EOF
.Edit
.X1 = True
.Update
DoCmd.OpenReport “971-DadosDiáriosEmpréstimos-Analítico”, acViewPreview, “”, “([Nome]='” & rst!NOME & “‘)” ‘*****************
TitRel = “C:\_DSV\RealValor\” & diaMov & ” – ” & rst!NOME & ” – ” & rst!CHAVE
DoCmd.OutputTo acOutputReport, “971-DadosDiáriosEmpréstimos-Analítico”, acFormatPDF, TitRel & “.pdf”
DoCmd.Close acReport, “971-DadosDiáriosEmpréstimos-Analítico” ‘*****
.Edit
.X1 = False
.Update
.MoveNext
Loop
End With
DoCmd.RunSQL (“UPDATE Agente set x1 = true”)
End Function

Formulário Inicial – Ocultar menu e objetos

Private Sub Form_Load()
DoCmd.SelectObject acForm, “frmUsuário”, True
DoCmd.RunCommand acCmdWindowHide ‘ F11
Call ap_DisableShift
DoCmd.ShowToolbar “ribbon”, acToolbarNo
Me.Senha1 = “”
Me.txtUsuario = “”
Me.txtNovaSenha.Visible = False
Me.txtNovaSenhaConfirma.Visible = False
Me.RotNovaSenha.Visible = False
Me.RotNovaSenhaConfirma.Visible = False
Me.btTrocarSenha.Visible = False
Me.btIncluir.Visible = False
Me.txtNovoUsuário.Visible = False
Me.btEfetivaInclusão.Visible = False
Me.txtPerfil.Visible = False
Me.rotPerfil.Visible = False

End Sub

Formatar Formulário – Fechar Menus

Private Sub Form_GotFocus()
DoCmd.RunCommand acCmdWindowHide ‘ F11
DoCmd.ShowToolbar “ribbon”, acToolbarNo
End Sub

Marcar ou Desmarcar campo Booleano
Private Sub btnSimNao_Click()
DoCmd.SetWarnings False
If Ok Then
DoCmd.RunSQL (“UPDATE Calendário1 set X = True”)
Ok = False
Me.btnSimNao.Caption = “N”
Me.btnSimNao.ForeColor = “00255” ‘ Muda cor do botão
Else
DoCmd.RunSQL (“UPDATE Calendário1 set X = False”)
Ok = True
Me.btnSimNao.Caption = “S”
Me.btnSimNao.ForeColor = “135206235” ‘ Muda cor do botão
End If
DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70
End Sub

Classificar Campo / Filtrar

– Classificar
Me.OrderByOn = True
Me.OrderBy = “CodOrc” ou ”CodOrc & Prefixo”

– Filtrar
txtTip1 = Me.txtTip
DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70
Me.Filter = “Tipo = forms!rubricas!txtTip1”
Me.FilterOn = True

Enviar para Área de Transferência – Método RunCommand com a constante acCmdCopy para copiar o conteúdo do controle ativo de um formulário ou relatório para a Área de Transferência.
O exemplo a seguir copiar o conteúdo de uma caixa de texto (txt) para a Área de Transferência.

Private Sub EnviaParaÁreaDeTranferência_Click()
Me!txt.SetFocus
DoCmd.RunCommand acCmdCopy
End Sub

Trazer da Área de Transferência – Método RunCommand com a constante acCmdCopy para trazer conteúdo da Área de Transferência e depositar no controle ativo de um formulário ou relatório.
O exemplo a seguir copiar o conteúdo da Área de Transferência para uma caixa de texto (txt).

Private Sub TrazDaÁreaDeTranferência_Click()
Me!txt.SetFocus
DoCmd.RunCommand acCmdPaste
End Sub

Private Sub DtAtuaçãoMês_DblClick(Cancel As Integer)
Dim X As String
X = Me.DtAtuaçãoMês
Me.Filter = “DtAtuaçãoMês = ‘” & X & “‘”
Me.FilterOn = True
DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70
End Sub

Nome do Banco de dados

Set db = CurrentDb()
Set rs = db.OpenRecordset(“Auxílio”)
rs.Edit
rs!nr = Me.CodContrato
rs.Updatedb.Name

Private Sub RodapéDaPágina_Format(Cancel As Integer, FormatCount As Integer)
Dim db As Database
Set db = CurrentDb()
Me.txtEndS.Caption = db.Name
End Sub
obs: [txtEndS] é um Rótulo

Nome do Projeto nos Objetos
Public Function ProjetoTítulo()
ProjetoTítulo = DLookup(“[ProjetoTítulo]”, “tblSisCadastro”, _
“[CodCadastro] = 1”)
End Function
————————————
tblSisCadastro

ProjetoTítulo	CodCadastro
NomeProjeto	1

Replace ou Substituir
Substituir([DataContratação];”.”;”/”)
– (Substitui “.” por “/”)
Substituir([Data Contratação];”.”;”“)
– (Remove “.”)

DoCmd.RunSQL

‘(Atribui à variável txt o valor da ChaveJ; Altera o campo txtVar da tabela Auxílio; Abre o formulário frmTesteEdição (filtrado pelo campo txtVar).

Obs: Não deve haver espaços entre ‘Apóstrofo’ e “Aspas”, pois seriam acrescidos à variável “txt”, no início e/ou no final. ‘” & txt & “‘

Private Sub NOME_DblClick(Cancel As Integer)
DoCmd.SetWarnings False
Dim txt As String
txt = Me.ChaveJ
DoCmd.RunSQL (“UPDATE Auxílio set txtVar =‘ “ & txt & ” ‘ “)
DoCmd.OpenForm “frmTesteEdição”, acNormal

End Sub

———————————————

DoCmd.RunSQL
DoCmd.RunSQL (“DELETE * FROM Clientes”)
DoCmd.RunSQL (“UPDATE Age set x = false where age.tipo= ‘ “ & txt & ” ‘ “)
(txt é uma variável tipo string )

xReg = Me.NomeRegional
DoCmd.RunSQL (“UPDATE qryAgente00 set x = True where qryAgente00.NomeRegional='” & xReg & “‘”)
‘ (xReg é string)

DoCmd.RunSQL (“INSERT Into tabDestino ( Camp1, Camp2 ) SELECT Camp1, Camp2 From ObjOrig”)

SQL INSERT
Public Function AnexaDadosDiários()
Dim sql1, sql2, sql3, sql4, sql5 As String

DoCmd.RunSQL (“DELETE tblDadosDiáriosEmp_00.* FROM tblDadosDiáriosEmp_00;”)

sql1 = “INSERT INTO tblDadosDiáriosEmp_00 ( CodRegional, [Chave J], ValorFinanciado, ValorFinanciadoLíquido, Vr, Parcelas, Dt, DtContrato, Status, NrProp, CodConv, CodProd, Subcanal, Perc, Prefixo ) ”

sql2 = “SELECT Agente.CodRegional, ExcelDiaEmp.ChaveJ, [Valor Financiado]/100 AS Expr1, [Valor Financiado Líquido]/100 AS Expr2, [Valor Financiado Líquido]/100 AS Expr3, ExcelDiaEmp.Parcelas, ExcelDiaEmp.[Data Movimento], ExcelDiaEmp.[Data Proposta], ExcelDiaEmp.Status, ExcelDiaEmp.[Número Proposta], ExcelDiaEmp.[Código Convênio], ExcelDiaEmp.[Código Produto], ExcelDiaEmp.[Tipo de Subcanal] AS Expr4, [Taxa Mensal de Juros]/100 AS tx, Format([Prefixo Ag# Responsável],’0000′) AS Expr5 ”

sql3 = “FROM Agente RIGHT JOIN ExcelDiaEmp ON Agente.ChaveJ = ExcelDiaEmp.ChaveJ ”

sql4 = “WHERE(((ExcelDiaEmp.MCI)=123456789) AND ((ExcelDiaEmp.ChaveJ) Is Not Null And (ExcelDiaEmp.ChaveJ)<>’ChaveJ’)) ”

sql5 = “ORDER BY Agente.CodRegional, ExcelDiaEmp.ChaveJ;”

sql0 = sql1 + sql2 + sql3 + sql4 + sql5
DoCmd.RunSQL (sql0)

End Function

yRG = Me.Rg

DoCmd.RunSQL (“UPDATE qryUF set x = true where qryUF.RG=’ ” & yRG & ” ‘ ” )
(quando yRG for string – não deixar espaços entre ” ‘ “ aspas e apóstrofos)
DoCmd.RunSQL (“UPDATE qryUF set x = true where qryUF.RG=”& yRG )
(quando yRG for numérico)

DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70
(atualiza)

Criar Tabela – Código

Public Function CriaTabela()
Dim dbs As Database
Set dbs = CurrentDb ‘OpenDatabase(“teste.mdb”)
dbs.Execute “CREATE TABLE Tabela1 ” _
& “(Nome CHAR(30), DtNasc Date);”
dbs.Close
End Function
————————————————————

Criar Tabela – Consulta (Modo SQL)

CREATE TABLE EixoAtuação
(CodEixo AUTOINCREMENT,
[CodBacia] integer,
[NomeEixo] TEXT(50)
)

——————————–

Criar Tabela – Código

Public Function CriaTabela()
  Dim dbs As Database
  Set dbs = CurrentDb 'OpenDatabase("teste.mdb")
  dbs.Execute "CREATE TABLE Tabela1 " _
      & "(Nome CHAR(30), DtNasc Date);"
  dbs.Close
End Function

Criar Tabela - Consulta (Modo SQL)

CREATE TABLE EixoAtuação 
(CodEixo AUTOINCREMENT, 
[CodBacia] integer, 
[NomeEixo] TEXT(50) 
)

Exportar para Excel

If MsgBox(“Confirma gerar Excel para ” & [NomeCliente] & “?”, vbYesNo, “Excel para Mala_Lista.xls”) = vbYes Then

DoCmd.TransferSpreadsheet acExport, 8, “qryCadastro”, _

CurrentProject.Path & “” & “Mala_Lista” & “.xls”, True, “”

Else

MsgBox “Nao gerado”

End If

End Sub

Exemplo:
DoCmd.TransferSpreadsheet acExport, 8, "qry", "C:_dsvteste.xls", True, ""

LoadPicture

O exemplo a seguir utiliza a função LoadPicture para carregar um metarquivo em um controle ActiveX de um formulário Funcionários.

Sub ExibirGráfico()

Const strCaminhoBitmapsCon = “C:Arquivos de ProgramasMicrosoft OfficeOfficeBitmapsEstilos”

‘ Declara variáveis de objeto dos tipos Picture e Control.

Dim objFigura As Object, ctl As Control

‘ Define a variável Control para que se refira a um controle ActiveX no formulário.

Set ctl = Forms!Funcionários!AlgumControlePersonalizado

‘ Atribui o valor de retorno de LoadPicture ao objeto Picture.

Set objFigura = LoadPicture(strCaminhoBitmapsCon & “Globo.wmf”)

‘ Define a propriedade Picture de um controle ActiveX.

Set ctl.Picture = objFigura

End Sub

Quebra de Página Condicional –
no Rodapé do Grupo onde acontece a quebra – (Nomear o objeto quebra com o nome “QuebraCondicional”

Private Sub RodapéDoGrupo0_Format(Cancel As Integer, FormatCount As Integer)
If Me.Page Mod 2 > 0 Then
Me.QuebraCondicional.Visible = True
Else
Me.QuebraCondicional.Visible = False
End If
End Sub

Ranking – Sql – (Na consulta , modo SQL)

SELECT DISTINCTROW t.Prefixo, t.TipoInfor, t.CodOrc, t.Ano, t.Mes, t.Tip, t.Obs, t.Prod, t.Dot, (select count(*) from [matriz] where obs>t.obs and chave=t.chave)+1 AS Rnk

FROM Matriz AS t ORDER BY t.Obs DESC;

Relatório Zebrado

Private Sub Detalhe_Print(Cancel As Integer, PrintCount As Integer)

dim grade as boolean

Me.Section(0).BackColor = IIf(GRADE, 14935011, 16777215)

GRADE = Not GRADE

End Sub

Caption de Relatório

Private Sub Report_Load()

DoCmd.OpenReport “NomeRelatório”, acViewPreview, “”, “”

Reports![ NomeRelatório].Caption = “Rótulo do Relatório – ” & Me.MsRef

End Sub

SQL

UPDATE

UPDATE é especialmente útil quando você quer alterar vários registros ou quando os registros que você quer alterar estão em várias tabelas.

Você pode alterar vários campos ao mesmo tempo. O exemplo a seguir aumenta os valores de Quantia do Pedido em 10% e os valores de Frete em 3% para transportadores no Reino Unido (UK):

UPDATE Pedidos

SET QuantiaDoPedido = QuantiaDoPedido * 1.1,

Frete = Frete * 1.03

WHERE PaísDeDestino = ‘UK’;

Para testar os exemplos a seguir no Microsoft Access, crie primeiro uma nova consulta no banco de dados de exemplo Northwind. Feche a caixa de diálogo Mostrar Tabela sem especificar uma tabela ou consulta. Alterne para modo SQL, cole um exemplo individual na janela SQL e execute a consulta.

Aviso Esses exemplos fazem alterações no banco de dados de exemplo Northwind. Antes de começar, talvez você deseje fazer uma cópia de backup do banco de dados de exemplo.

O exemplo a seguir altera os valores do Supervisor para 5 em todos os registros de funcionários que têm atualmente o valor 2 em Supervisor:

UPDATE Funcionários SET Supervisor = 5 WHERE Supervisor = 2;

O próximo exemplo aumenta em 10 por cento o PreçoUnitário de todos os produtos não-descontinuados do fornecedor 8:

UPDATE Produtos SET PreçoUnitário = PreçoUnitário * 1.1

WHERE CódigoDoFornecedor = 8 AND Descontinuado = No;

O exemplo a seguir reduz em 5 por cento o PreçoUnitário de todos os produtos não-descontinuados fornecidos pela Tokyo Traders. As tabelas Produtos e Fornecedores têm um relacionamento muitos-para-um.

UPDATE Fornecedores INNER JOIN Produtos

ON Fornecedores.CódigoDoFornecedor = Produtos.CódigoDoFornecedor SET PreçoUnitário = PreçoUnitário * .95

WHERE NomeDaEmpresa = ‘Tokyo Traders’ AND Descontinuado = No;

INSERT

INSERT INTO Clientes SELECT * FROM NovosClientes;

O próximo exemplo cria um novo registro na tabela Funcionários:

INSERT INTO Funcionários (Nome,Sobrenome, Cargo) VALUES (‘Paulo’, ‘Braga’, ‘Estagiário’);

O próximo exemplo seleciona todos os estagiários de uma suposta tabela Estagiários que tenham sido contratados há mais de 30 dias e adiciona seus registros à tabela Funcionários.

INSERT INTO Funcionários SELECT Estagiários.* FROM Estagiários WHERE DataDaContratação < Now() – 30;

Você pode utilizar a cláusula INSERT INTO para fazer backup de informações em seu banco de dados antes de ele ser alterado. Você pode, por exemplo, fazer backup de informações em uma tabela Funcionários imediatamente antes de um usuário fazer qualquer alteração aos dados dessa tabela.

DELETE

delete Remaneja.* from Remaneja

sql – db.execute (“update

Public Function TesteDelete()

Dim db As Database

Set db = CurrentDb()

Dim StrSQL$

Dim k#

StrSQL = “DELETE * FROM OrcObservado where MESANO=“ & Forms!frmCaptura!MES & Forms!frmCaptura!ANO & “AND SERET=1”

db.Execute (StrSQL)
‘db.Execute (“DELETE * FROM OrcObser

Dim db As Database

Set db = CurrentDb()

db.Execute (“UPDATE Produtos SET Produtos.X = Yes WHERE produtos.obs = ‘1’ “)

DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70

DoCmd.RunSQL (“DELETE * FROM Clientes”)

DoCmd.RunSQL (“UPDATE Age set check = false”)

DoCmd.RunSQL (“UPDATE tabCbo551 INNER JOIN Agente ON tabCbo551.Usuário = Agente.CHAVE SET Agente.x2 = Yes”)

Private Sub NR_REDE_DblClick(Cancel As Integer)

Dim txtRede As String

txtRede = NR_REDE

Dim db As Database

Set db = CurrentDb()

db.Execute (“update age set age.x = false”)

db.Execute (“update age set age.x = true where age.nr_rede = ‘“ & txtRede & “‘“)

DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70

End Sub

Imprimir Relatórios Marcados

Private Sub cmdImprimeLote_Click()   ‘ Imprime Relatórios Marcados
DoCmd.SetWarnings False
DoCmd.RunSQL (“UPDATE [Sis-Relatorios-Balancete] set Dt = ” “)
DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70
Dim xComando As String
Dim db As Database
Dim rs As Recordset
Set db = CurrentDb()
Set rs = db.OpenRecordset(“qry-Sis-Relatorios-Balancete”) ‘ *
Do While Not rs.EOF
    xComando = rs!Rel
    DoCmd.OpenReport xComando, acPreview
    DoCmd.PrintOut acPrintAll, , , acHigh, 1, True
    DoCmd.Close acReport, xComando
    rs.Edit
    rs!dt = “*”
    rs!dt = Now()
    rs.Update
    rs.MoveNext
Loop
MsgBox “Concluído”, vbOKOnly, “Concluído”
End Sub
=======================

Observação: Consulta [Sis-Relatorios-Balancete] - Filtra relatórios escolhidos
SELECT [Sis-Relatorios-Balancete].RelX, [Sis-Relatorios-Balancete].Endereço, [Sis-Relatorios-Balancete].Ordem, [Sis-Relatorios-Balancete].Dt
FROM [Sis-Relatorios-Balancete]
WHERE ((([Sis-Relatorios-Balancete].RelX)=Yes));

———————————————————————————-

InStr ou EmSeq
Localiza uma sequencia de caracteres em um campo.
Retorna um número referente à posição da sequencia no campo. Zero para negativo. No exemplo abaixo, o nº 1 indica que a sequencia será procurada a partir do primeiro caractere do campo.

EmSeq(1;[CampoPesquisado];”Sequencia pesquisada”)

Teclas Especiais

Option Compare DatabaseOption Explicit

‘No exemplo a seguir, a propriedade KeyPreview está definida

‘como True (–1) no procedimento de evento Load do formulário.

‘Isto faz com que o formulário receba eventos de teclado antes

‘que estes sejam recebidos por qualquer outro controle.

‘Em seguida, o evento KeyDown de formulário verifica o valor

‘do argumento KeyCode para determinar se as teclas F2, F3 ou F4

‘foram pressionadas.

Private Sub Form_Load()

Me.KeyPreview = True

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

Select Case KeyCode

Case vbKeyF2

‘ Processa eventos da tecla F2.

MsgBox “Voce pressionou a tecla F2”

Case vbKeyF3

‘ Processa eventos da tecla F3.

MsgBox “Voce pressionou a tecla F3”

Case vbKeyF4

‘ Processa eventos da tecla F4.

MsgBox “Voce pressionou a tecla F4”

Case vbKeyDown

MsgBox “Voce pressionou Seta para baixo”

Case vbKeyPageDown

MsgBox “Voce pressionou Page Down”

Case Else

MsgBox “Voce nao pressionou as teclas solicitadas.”

End Select

End Sub

‘Você pode utilizar as constantes a seguir para representar

‘valores de teclado. Essas constantes podem ser utilizadas

‘no Microsoft Access em procedimentos de evento para os eventos

‘KeyDown e KeyUp.

‘vbKey0 vbKeyF5 vbKeyNumPad4

‘vbKey1 vbKeyF6 vbKeyNumPad5

‘vbKey2 vbKeyF7 vbKeyNumPad6

‘vbKey3 vbKeyF8 vbKeyNumPad7

‘vbKey4 vbKeyF9 vbKeyNumPad8

‘vbKey5 vbKeyF10 vbKeyNumPad9

‘vbKey6 vbKeyF11 vbKeyO

‘vbKey7 vbKeyF12 vbKeyP

‘vbKey8 vbKeyF13 vbKeyPageDown

‘vbKey9 vbKeyF14 vbKeyPageUp

‘vbKeyA vbKeyF15 vbKeyPause

‘vbKeyAdd vbKeyF16 vbKeyPrint

‘vbKeyB vbKeyG vbKeyQ

‘vbKeyBack vbKeyH vbKeyR

‘vbKeyC vbKeyHelp vbKeyRButton

‘vbKeyCancel vbKeyHome vbKeyReturn

‘vbKeyCapital vbKeyI vbKeyRight

‘vbKeyClear vbKeyInsert vbKeyS

‘vbKeyControl vbKeyJ vbKeySelect

‘vbKeyD vbKeyK vbKeySeparator

‘vbKeyDecimal vbKeyL vbKeyShift

‘vbKeyDelete vbKeyLButton vbKeySnapshot

‘vbKeyDivide vbKeyLeft vbKeySpace

‘vbKeyDown vbKeyM vbKeySubtract

‘vbKeyE vbKeyMButton vbKeyT

‘vbKeyEnd vbKeyMenu vbKeyTab

‘vbKeyEscape vbKeyMultiply vbKeyU

‘vbKeyExecute vbKeyN vbKeyUp

‘vbKeyF vbKeyNumLock vbKeyV

‘vbKeyF1 vbKeyNumPad0 vbKeyW

‘vbKeyF2 vbKeyNumPad1 vbKeyX

‘vbKeyF3 vbKeyNumPad2 vbKeyY

‘vbKeyF4 vbKeyNumPad3 vbKeyZ

Comandos Importantes
DoCmd.OpenForm stDocName, , , stLinkCriteria
DoCmd.OpenReport stDocName, acPreview
DoCmd.Close
DoCmd.GoToRecord , , acFirst
DoCmd.GoToRecord , , acPrevious
DoCmd.GoToRecord , , acNext
DoCmd.GoToRecord , , acLast
DoCmd.GoToRecord , , acNewRec
DoCmd.RunMacro stDocName
DoCmd.OpenQuery stDocName, acNormal, acEdit

(Marca todos os registros com SIM se o primeiro registro for NÃo e vice-versa)
If Me.X = True Then
DoCmd.RunSQL (“UPDATE Grupos set x = false”)
Else
DoCmd.RunSQL (“UPDATE Grupos set x = true”)
End If
DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70

Access 2007
DoCmd.SetWarnings False
DoCmd.ShowToolbar “ribbon”, acToolbarNo

SQL – Insert

Private Sub Comando20_Click()

On Error GoTo Err_Comando20_Click

Dim SQL, sql01, sql02, sql03, sql04, sql05, sql06, sql07, sql08, sql09, sql10 As String

DoCmd.RunSQL (“DELETE * FROM Agente”)

DoCmd.RunSQL (“DELETE * FROM tabCbo551”)

‘*******************************************

sql01 = “INSERT INTO Agente ( CHAVE, CodRegional, CodFunção, CodSupervisor,”

sql02 = “CodGerente, NOME, Piso, TaxaRemuneração, Redutor, TabelaComissão, TabelaComissãoCta,”

sql03 = “CPF, AGÊNCIA, PREFIXO, CONTA, VENCIMENTO, [E-MAIL], TELEFONE, CELULAR, x )”

sql04 = “SELECT Agente1.CHAVE, Agente1.CodRegional, Agente1.CodFunção,”

sql05 = “Agente1.CodSupervisor, Agente1.CodGerente, Agente1.NOME, Agente1.Piso,”

sql06 = “Agente1.TaxaRemuneração, Agente1.Redutor, Agente1.TabelaComissão,”

sql07 = “Agente1.TabelaComissãoCta, Agente1.CPF, Agente1.AGÊNCIA, Agente1.PREFIXO,”

sql08 = “Agente1.CONTA, Agente1.VENCIMENTO, Agente1.[E-MAIL], Agente1.TELEFONE,”

sql09 = “Agente1.CELULAR, Agente1.x ”

sql10 = “FROM Agente1”

SQL = sql01 & sql02 & sql03 & sql04 & sql05 & sql06 & sql07 & sql08 & sql09 & sql10

‘MsgBox SQL

CurrentDb.Execute SQL

GERAR PDF INDIVIDUAL
txtAp = Ap
txtCondômino = Condômino
DoCmd.OpenReport “Ap_Pagamentos_02”, acPreview
Reports![Ap_Pagamentos_02].Caption = “Ed PREVI-Extrato – Ap: “ & txtAp & “ – “ & txtCondômino

GERAR PDF INDIVIDUAL

Function PDF_ComEmpAgente()

MsgBox “Marque o PDF Creator como impressora padrão (Painel de Controle”

Dim dbs As Database, qdf As QueryDef, rst, rsDt, rsrub As Recordset

Dim i As Integer

Set dbs = CurrentDb

DoCmd.RunSQL (“UPDATE Agente set x = false”)

Set rst = dbs.OpenRecordset(“qryAgenteImpressão01”)

Set rsDt = dbs.OpenRecordset(“qryCbo551Mes”)

With rst

.MoveFirst

Do While Not .EOF

.Edit

.X = True

.Update

DoCmd.OpenReport “qryComissão-Agente”, acViewPreview, ““, “([Nome]=’“ & rst!NOME & “‘)”

Reports![qryComissão-Agente].Caption = rsDt!ms2 & “ – “ & rst!NOME & “ – “ & rst!CHAVE

DoCmd.PrintOut acPages, 2, 10, acHigh, 1, True

DoCmd.Close acReport, “qryComissão-Agente”

.Edit

.X = False

.Update

.MoveNext

Loop

End With

End Function

Funções

Public Function NrRegTab(xTab As String) ‘ Qte de Registros em Tabela
Dim db As Database
Dim rs As Recordset
Dim nr As Integer
Set db = CurrentDb()
Set rs = db.OpenRecordset(xTab)
NrRegTab = rs.RecordCount
End Function

Public Function AAAAMM(xDt) ‘ Ano – Mês de uma data

If xDt & “*” <> “*” Then
AAAAMM = Year(xDt) & “-” & Format(Month(xDt), “00”)
Else
AAAAMM = “0000-00”
End If
End Function

Public Function AAAMMDD(xDt) ‘ Ano – Mês – Dia de uma data
If xDt & “*” <> “*” Then
aaaammdd = Year(xDt) & Format(Month(xDt), “00”) & Format(Day(xDt), “00”)
Else
aaaammdd = “0000000”
End If
End Function

Public Function MMDD(xDt) ‘ Mês Dia de uma data
If xDt & “*” <> “*” Then
MMDD = Format(Month(xDt), “00”) & Format(Day(xDt), “00”)
Else
MMDD = “0000”
End If
End Function

Mostra o dia 1º do mês ref à string AAAAMM, em formato de data
Public Function d1AAAAMM(xAAAAMM As String) ‘
Dim x1 As String
Dim y1 As Date
x1 = xAAAAMM
y1 = “01/” & Right(x1, 2) & “/” & Left(x1, 4)
d1AAAAMM = y1
End Function

———————————–
Incrementa em um mês a string AAAAMM
Public Function Mais1AAAAMM(xDat As String)
Dim y01, y02, yDat As Date
y01 = d1AAAAMM(xDat) ‘ fornece o dia 1º do mês ref. à string
y02 = y01 + 33
y02 = (y02 – Day(y02)) + 1
Mais1AAAAMM = Year(y02) & Format(Month(y02), “00”)
End Function

Diminui em um mês a string AAAAMM
Public Function Menos1AAAAMM(xDat As String)
Dim y01, y02 As Date
y01 = d1AAAAMM(xDat)
y02 = y01 – 1
y02 = (y02 – Day(y02)) + 1
Menos1AAAAMM = Year(y02) & Format(Month(y02), “00”)
End Function

FERIADOSMÓVEIS
DT	DESCRIÇÃO
17/02/2015	Ter Carnaval
16/02/2015	Seg Carnaval
03/04/2015	Paixão de Cristo
04/06/2015	Corpus Cristi
19/06/2014	Corpus Cristi
18/04/2014	Paixão de Cristo
03/03/2014	Seg Carnaval
04/03/2014	Ter Carnaval

FERIADOSFIXOS
XMES	XDIA	DESCRIÇÃO
1	1	Confraternização Universal
3	25	Libertação Escravos Ceará
4	21	Tiradentes
5	1	Dia do Trabalho
8	15	Nossa Senhora Assunção
9	7	Independência
10	12	Nossa Senhora Aparecida
11	2	Finados
11	15	Proclamação da República
12	24	Natal

Public Function Feriado(xDt) ‘ Feriados
Dim xQt1, xMs, xDi, yMes, xAno As Integer
Dim AnoMes As Long
Dim xDat As String
Dim db As Database
Dim rsF, rsM As Recordset ‘ Feriados Fixos / Móveis
Set db = CurrentDb()
Set rsF = db.OpenRecordset(“FeriadosFixos”)
Set rsM = db.OpenRecordset(“FeriadosMóveis”)

Feriado = ““
‘**********************************************************
Do While Not rsF.EOF() ‘ Feriados Fixos
If MMDD(xDt) = Format(rsF!xMes, “00”) & Format(rsF!xDia, “00”) Then
Feriado = rsF!Descrição
Exit Do
End If
rsF.MoveNext
Loop
‘***********************************************************************
If Feriado = ““ Then
Do While Not rsM.EOF() ‘ Feriados Móveis
If xDt = rsM!dt Then
Feriado = rsM!Descrição
Exit Do
End If
rsM.MoveNext
Loop
End If
‘***********************************************************************
End Function

Public Function ddmmaaaa(yDat)
ddmmaaaa = Right(“0” + LTrim(Str(Day(yDat))), 2) + Right(“0” + LTrim(Str(Month(yDat))), 2) + Right(Str(Year(yDat)), 4)
End Function

Public Function aaaammdd(yDat)
aaaammdd = Right(Str(Year(yDat)), 4) + Right(“0” + LTrim(Str(Month(yDat))), 2) + Right(“0” + LTrim(Str(Day(yDat))), 2)
End Function

Public Function dSemana(yDat)
dSemana = IIf(WeekDay(yDat) = 1, “Dom”, IIf(WeekDay(yDat) = 2, “Seg”, IIf(WeekDay(yDat) = 3, “Ter”, IIf(WeekDay(yDat) = 4, “Qua”, IIf(WeekDay(yDat) = 5, “Qui”, IIf(WeekDay(yDat) = 6, “Sex”, “Sab”))))))
End Function
Public Function cMes(yDat, nTipo)
‘ nTipo: 0 = abreviado, 1 = completo
ReDim aMes(12)
aMes(1) = (“janeiro”)
aMes(2) = (“fevereiro”)
aMes(3) = (“março”)
aMes(4) = (“abril”)
aMes(5) = (“maio”)
aMes(6) = (“junho”)
aMes(7) = (“julho”)
aMes(8) = (“Agosto”)
aMes(9) = (“setembro”)
aMes(10) = (“outubro”)
aMes(11) = (“novembro”)
aMes(12) = (“dezembro”)
cMes = IIf(nTipo = 0, Left(aMes(Month(yDat)), 3), aMes(Month(yDat)))
‘nMes = IIf(Month(yDat) = 1, “Jan”, IIf(Month(yDat) = 2, “Fev”, IIf(Month(yDat) = 3, “Mar”, IIf(Month(yDat) = 4, “Abr”, IIf(Month(yDat) = 5, “Mai”, IIf(Month(yDat) = 6, “Jun”, IIf(Month(yDat) = 7, “Jul”, IIf(Month(yDat) = 8, “Ago”, IIf(Month(yDat) = 9, “Set”, IIf(Month(yDat) = 10, “Out”, IIf(Month(yDat) = 11, “Nov”, “Dez”)))))))))))
End Function

Public Function iEquiv(yn1, yn2, yi) ‘ Período Conhecida, Período Desconhecido, Taxa
iEquiv = (((yi / 100) + 1) ^ (yn2 / yn1) – 1) * 100
End Function

Public Function retiraStr(ByVal varStr As Variant, ByVal strChar As Variant) As String

‘Retira da string a substring indicada, quantas vezes ela apararecer.
‘Recebe string e substring a retirar.

Dim wCharPos As Integer
Dim varTemp As Variant

On Error Resume Next

If IsNull(varStr) Then
retiraStr = ““
Exit Function
Else
If IsNull(strChar) Then strChar = ““
End If

varTemp = ““
wCharPos = InStr(varStr, strChar)
Do Until wCharPos = 0
varTemp = varTemp & Left(varStr, wCharPos – 1)
varStr = Right(varStr, Len(varStr) – Len(strChar) – wCharPos + 1)
wCharPos = InStr(varStr, strChar)
Loop
retiraStr = varTemp & varStr

End Function

Função Extenso
Public Function Extenso(Valor As Variant) As String ‘ Extenso

ReDim cWord(1 To 6) As String, Cifra(6, 2) As String
Dim WExt As String, WExten As String, CodVar As String
Dim Counter As Integer, aa As Integer, Wsa As Integer

WExt = ““
WExten = ““
Counter = 1
aa = 1

For Wsa = 1 To 6
cWord(Wsa) = ““
Next

If VarType(Valor) = 8 Then
Valor = Val(Valor)
End If

CodVar = Format(Valor, “000000000000000.00”)
CodVar = Left(CodVar, 15) & “0” & Right(CodVar, 2)

Cifra(1, 1) = “TRILHAO”
Cifra(1, 2) = “TRILHOES”
Cifra(2, 1) = “BILHAO”
Cifra(2, 2) = “BILHOES”
Cifra(3, 1) = “MILHAO”
Cifra(3, 2) = “MILHOES”
Cifra(4, 1) = “MIL”
Cifra(4, 2) = “MIL”

Cifra(5, 1) = “REAL”
Cifra(5, 2) = “REAIS”
Cifra(6, 1) = “CENTAVO”
Cifra(6, 2) = “CENTAVOS”

While Counter <= 6
WExt = Extenso_Aux(Mid(CodVar, aa, 3))
If Not VarEmpty(WExt) Then
WExt = WExt + IIf(WExt = “UM “, Cifra(Counter, 1), Cifra(Counter, 2))
cWord(Counter) = WExt
End If
aa = aa + 3
Counter = Counter + 1
Wend

WExten = ““

For aa = 1 To 5
WExten = WExten + IIf(Not VarEmpty(cWord(aa)), cWord(aa), ““)
If aa < 5 Then If Not VarEmpty(cWord(aa + 1)) And Not VarEmpty(WExten) Then WExten = WExten & “, “ End If End If Next If VarEmpty(cWord(5)) And VarEmpty(cWord(4)) And Not VarEmpty(WExten) Then WExten = WExten + (“ DE “ + Cifra(5, 2)) ElseIf VarEmpty(cWord(5)) And Not VarEmpty(cWord(4)) Then WExten = WExten + (“ “ + IIf(Left(cWord(4), 3) = “UM”, Cifra(5, 1), Cifra(5, 2))) End If ‘Verifica Centavos WExten = WExten + IIf(Not VarEmpty(cWord(6)), IIf(Not VarEmpty(WExten), “ E “ + cWord(6), cWord(6)), ““) Extenso = WExten End Function Public Function VarEmpty(C As Variant) As Boolean Dim VTy As Integer Dim MyVar As String VTy = VarType(MyVar) If VTy = vbEmpty Or VTy = vbNull Then VarEmpty = True ElseIf VTy >= vbInteger And VTy <= vbCurrency Then
If C = 0 Then
VarEmpty = True
End If
ElseIf VTy = vbDate Then
If C = “ / / “ Then
VarEmpty = True
End If
ElseIf VTy = vbString Then
MyVar = StrTran(C, Chr(0), Chr(32))
If Len(Trim(MyVar)) = 0 Then
VarEmpty = True
End If
End If

End Function

Public Function StrTran(Texto As Variant, Acha As Variant, Troca As Variant) As String

Dim InicioString As Integer
Dim FinalString As Integer
Dim Temp As String

If VarType(Texto) <> vbString Or VarType(Acha) <> vbString Or VarType(Troca) <> vbString Then
If VarType(Texto) = vbNull Then
Temp = ““
Else
Temp = Texto
End If
ElseIf InStr(Texto, Acha) = 0 Then
Temp = Texto
Else
Do
InicioString = InStr(Texto, Acha)
FinalString = InicioString + IIf(Len(Acha) = 0, 1, Len(Acha))
Texto = Mid(Texto, 1, InicioString – 1) & Troca & Mid(Texto, FinalString)
Loop While InStr(Texto, Acha) <> 0
Temp = Texto
End If
StrTran = Temp
End Function

Public Function Extenso_Aux(ByVal Part As String) As String

Dim Posi As Integer, ii As Integer
Dim cWordExtenso As String, C1 As String, C2 As String, C3 As String
ReDim A_Num(1 To 37) As String

A_Num(1) = “001UM “
A_Num(2) = “002DOIS “
A_Num(3) = “003TRES “
A_Num(4) = “004QUATRO “
A_Num(5) = “005CINCO “
A_Num(6) = “006SEIS “
A_Num(7) = “007SETE “
A_Num(8) = “008OITO “
A_Num(9) = “009NOVE “
A_Num(10) = “010DEZ “
A_Num(11) = “011ONZE “
A_Num(12) = “012DOZE “
A_Num(13) = “013TREZE “
A_Num(14) = “014QUATORZE “
A_Num(15) = “015QUINZE “
A_Num(16) = “016DEZESSEIS “
A_Num(17) = “017DEZESSETE “
A_Num(18) = “018DEZOITO “
A_Num(19) = “019DEZENOVE “
A_Num(20) = “020VINTE “
A_Num(21) = “030TRINTA “
A_Num(22) = “040QUARENTA “
A_Num(23) = “050CINQUENTA “
A_Num(24) = “060SESSENTA “
A_Num(25) = “070SETENTA “
A_Num(26) = “080OITENTA “
A_Num(27) = “090NOVENTA “
A_Num(28) = “100CEM “
A_Num(29) = “200DUZENTOS “
A_Num(30) = “300TREZENTOS “
A_Num(31) = “400QUATROCENTOS “
A_Num(32) = “500QUINHENTOS “
A_Num(33) = “600SEISCENTOS “
A_Num(34) = “700SETECENTOS “
A_Num(35) = “800OITOCENTOS “
A_Num(36) = “900NOVECENTOS “
A_Num(37) = “000 “
C1 = Left(Part, 1)
C2 = Mid(Part, 2, 1)
C3 = Right(Part, 1)
Posi = 0
cWordExtenso = ““
For ii = 1 To 37
If Left(A_Num(ii), 3) = Part Then
Posi = ii
Exit For
End If
Next
If Posi <> 0 Then
cWordExtenso = Mid(A_Num(Posi), 4)
Else
Posi = 0
For ii = 1 To 37
If Left(A_Num(ii), 3) = Format(Val(Part) – Val(C3), “000”) Then
Posi = ii
Exit For
End If
Next
If Posi <> 0 Then
cWordExtenso = Mid(A_Num(Posi), 4) + “E “
If cWordExtenso = “CEM E “ And Val(C3) <> 0 Then
cWordExtenso = “CENTO E “
End If
Posi = 0
For ii = 1 To 37
If Left(A_Num(ii), 3) = Format(Val(C3), “000”) Then
Posi = ii
Exit For
End If
Next
cWordExtenso = cWordExtenso + Mid(A_Num(Posi), 4)
Else
Posi = 0
For ii = 1 To 37
If Left(A_Num(ii), 3) = Format(Val(Part) – Val((C2 + C3)), “000”) Then
Posi = ii
Exit For
End If
Next
cWordExtenso = Mid(A_Num(Posi), 4) + “E “
If cWordExtenso = “CEM E “ Then
cWordExtenso = “CENTO E “
End If
Posi = 0
For ii = 1 To 37
If Left(A_Num(ii), 3) = Format(Val((C2 + C3)), “000”) Then
Posi = ii
Exit For
End If
Next
If Posi <> 0 Then
cWordExtenso = cWordExtenso + Mid(A_Num(Posi), 4)
Else
Posi = 0
For ii = 1 To 37
If Left(A_Num(ii), 3) = Format(Val((C2 + C3)) – Val(C3), “000”) Then
Posi = ii
Exit For
End If
Next
cWordExtenso = cWordExtenso + Mid(A_Num(Posi), 4) + “E “
Posi = 0
For ii = 1 To 37
If Left(A_Num(ii), 3) = Format(Val(C3), “000”) Then
Posi = ii
Exit For
End If
Next
cWordExtenso = cWordExtenso + Mid(A_Num(Posi), 4)
End If
End If
End If

Extenso_Aux = cWordExtenso

End Function

Function FU_ValidaCPF(CPF As String) As Integer
‘
Dim soma As Integer
Dim Resto As Integer
Dim i As Integer

‘Valida argumento
If Len(CPF) <> 11 Then
FU_ValidaCPF = False
Exit Function
End If

soma = 0
For i = 1 To 9
soma = soma + Val(Mid$(CPF, i, 1)) * (11 – i)
Next i
Resto = 11 – (soma – (Int(soma / 11) * 11))
If Resto = 10 Or Resto = 11 Then Resto = 0
If Resto <> Val(Mid$(CPF, 10, 1)) Then
FU_ValidaCPF = False
Exit Function
End If

soma = 0
For i = 1 To 10
soma = soma + Val(Mid$(CPF, i, 1)) * (12 – i)
Next i
Resto = 11 – (soma – (Int(soma / 11) * 11))
If Resto = 10 Or Resto = 11 Then Resto = 0
If Resto <> Val(Mid$(CPF, 11, 1)) Then
FU_ValidaCPF = False
Exit Function
End If

FU_ValidaCPF = True

End Function

Function FU_ValidaCGC(CGC As String) As Integer
Dim retorno, a, j, i, d1, d2
If Len(CGC) = 8 And Val(CGC) > 0 Then
a = 0
j = 0
d1 = 0
For i = 1 To 7
a = Val(Mid(CGC, i, 1))
If (i Mod 2) <> 0 Then
a = a * 2
End If
If a > 9 Then
j = j + Int(a / 10) + (a Mod 10)
Else
j = j + a
End If
Next i
d1 = IIf((j Mod 10) <> 0, 10 – (j Mod 10), 0)
If d1 = Val(Mid(CGC, 8, 1)) Then
FU_ValidaCGC = True
Else
FU_ValidaCGC = False
End If
Else
If Len(CGC) = 14 And Val(CGC) > 0 Then
a = 0
i = 0
d1 = 0
d2 = 0
j = 5
For i = 1 To 12 Step 1
a = a + (Val(Mid(CGC, i, 1)) * j)
j = IIf(j > 2, j – 1, 9)
Next i
a = a Mod 11
d1 = IIf(a > 1, 11 – a, 0)
a = 0
i = 0
j = 6
For i = 1 To 13 Step 1
a = a + (Val(Mid(CGC, i, 1)) * j)
j = IIf(j > 2, j – 1, 9)
Next i
a = a Mod 11
d2 = IIf(a > 1, 11 – a, 0)
If (d1 = Val(Mid(CGC, 13, 1)) And d2 = Val(Mid(CGC, 14, 1))) Then
FU_ValidaCGC = True
Else
FU_ValidaCGC = False
End If
Else
FU_ValidaCGC = False
End If
End If
End Function

VBA-ACCESS

10/04/2023

DoCmd

Formulário Inicial – Ocultar menu e objetos

——————————–

Criar Tabela – Código

Compartilhe isso: