Attribute VB_Name = "Funes Comuns"
Option Compare Database
Option Explicit
'Funo para pegar nmero do HD
Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
'Funo para pegar a mquina da rede
Public Declare Function GetMachineName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'Funo para pegar o Login da mquina
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'Funo para tocar Wav
Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long

Dim MyDB As Database
Dim MyTB As Recordset

'Variveis para clculo do CGC e Processo
Dim O1, O2, O3, O4, O5 As Integer 'Nmero do rgo
Dim N1, N2, N3, N4, N5, N6, N7, N8, N9, N10 As Integer 'Nmero do Processo e nmero de telefone (Adquirente)
Dim A1, A2 As Integer 'Ano atual
Dim C1, C2, C3, C4, C5, C6, C7, C8, C9, C10, VLC1, VLC2 As Integer ' Dgito de controle e Adquirente
Dim DTANO As String 'Data
Dim TOTAL, TOTAL1, RESTO, RESTO1 As Single 'Calculos
Dim CALCULO As Integer 'Calculo
Public Function Desfazer()

    DoCmd.RunCommand acCmdUndo
    
End Function
Public Function Excluir()

    DoCmd.SetWarnings False
    DoCmd.RunCommand acCmdSelectRecord
    DoCmd.RunCommand acCmdDeleteRecord
    DoCmd.SetWarnings True
End Function
Public Function Salvar()

    DoCmd.RunCommand acCmdSaveRecord
    

End Function
Public Function Proximo()
On Error GoTo Err_Proximo

    DoCmd.GoToRecord , , acNext
    Exit Function
    
Err_Proximo:
If Err.Number = 2105 Then
    MsgBox "Voc Encontrou o ltimo registro", 16, "Ateno"
Else
    MSG_ERRO
End If
    
End Function
Public Function Anterior()
On Error GoTo Err_Anterior

     DoCmd.GoToRecord , , acPrevious
     Exit Function
     
Err_Anterior:
If Err.Number = 2105 Then
    MsgBox "Voc Encontrou o primeiro registro", 16, "Ateno"
Else
    MSG_ERRO
End If
    
End Function
Public Function Novo()

    DoCmd.GoToRecord , , acNewRec
    
End Function
Public Function Fechar()
  
  DoCmd.Close
 
End Function
Public Function MSG_ERRO()
    MsgBox "Ocorreu um erro inesperado de nmero: " & Err.Number & ", Comunique os responsaveis pelo sistema F: 410-8721.", 16, "Ateno"
End Function
Public Function Verificar_CGC(NRCGC_ADQ As String)
Dim X, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14 As Integer
Dim B1, B2, B3, B4, B5, B6, B7, V, DV As Integer

'Seleo de nmeros
    X = Left(NRCGC_ADQ, 1) 'Primeiro caractere
    X1 = Left(NRCGC_ADQ, 2) 'Dois caracteres
    X2 = Left(NRCGC_ADQ, 3) 'Trs caracteres
    X3 = Left(NRCGC_ADQ, 4)
    X4 = Left(NRCGC_ADQ, 5)
    X5 = Left(NRCGC_ADQ, 6)
    X6 = Left(NRCGC_ADQ, 7)
    X7 = Left(NRCGC_ADQ, 8)
    X8 = Left(NRCGC_ADQ, 9)
    X9 = Left(NRCGC_ADQ, 10)
    X10 = Left(NRCGC_ADQ, 11)
    X11 = Left(NRCGC_ADQ, 12)
    X12 = Left(NRCGC_ADQ, 13)
    X13 = Left(NRCGC_ADQ, 14)

'Atribuindo Selees

B1 = X
B2 = Right(X1, 1) 'ltimo caractere do X1
B3 = Right(X2, 1) 'ltimo caractere do X2
B4 = Right(X3, 1) 'ltimo caractere do X3
B5 = Right(X4, 1) 'ltimo caractere do X4
B6 = Right(X5, 1) 'ltimo caractere do X5
B7 = Right(X6, 1) 'ltimo caractere do X6
DV = Right(X7, 1) 'ltimo caractere do X7
O1 = Right(X8, 1) 'ltimo caractere do X8
O2 = Right(X9, 1) 'ltimo caractere do X9
O3 = Right(X10, 1) 'ltimo caractere do X10
O4 = Right(X11, 1) 'ltimo caractere do X11
C1 = Right(X12, 1) 'ltimo caractere do X12
C2 = Right(X13, 1) 'ltimo caractere do X13

'Calculo do dgito
Dim K1, K2, K3, K4, K5, K6, K7 As Integer

K1 = B1 * 2
K2 = B2 * 1
K3 = B3 * 2
K4 = B4 * 1
K5 = B5 * 2
K6 = B6 * 1
K7 = B7 * 2

'Atribuindo valores para o calculo do dgito
Dim T1, T2, t3, T4, T5, T6, T7, T8, T9, T10, T11, D1, D2 As Integer
    
    If K1 < 10 Then
        T1 = 0
    Else
        T1 = Left(K1, 1)
    End If
        T2 = Right(K1, 1)
    t3 = K2
    
    If K3 < 10 Then
        T4 = 0
    Else
        T4 = Left(K3, 1)
    End If
        T5 = Right(K3, 1)
    T6 = K4
    If K5 < 10 Then
        T7 = 0
    Else
        T7 = Left(K5, 1)
    End If
    T8 = Right(K5, 1)
    T9 = K6
    
    If K7 < 10 Then
        T10 = 0
    Else
        T10 = Left(K7, 1)
    End If
        T11 = Right(K7, 1)
CALCULO = (Int(T1) + Int(T2) + Int(t3) + Int(T4) + Int(T5) + Int(T6) + Int(T7) + Int(T8) + Int(T9) + Int(T10) + Int(T11))
D1 = Right(CALCULO, 1)
D2 = Left(CALCULO, 1)
V = Int(D1)

    If V <> 0 Then
        V = ((Int(D2) + 1) * 10) - CALCULO
    End If

'Calcular o Primeiro controle "C1"

TOTAL = ((O4 * 2) + (O3 * 3) + (O2 * 4) + (O1 * 5) + (DV * 6) + (B7 * 7) + (B6 * 8) + (B5 * 9) + (B4 * 2) + (B3 * 3) + (B2 * 4) + (B1 * 5))

RESTO = TOTAL Mod 11

If RESTO = 0 Or RESTO = 1 Then
    C1 = 0
Else
    C1 = 11 - RESTO
End If

'Calcular o Segundo controle "C2"
TOTAL1 = ((C1 * 2) + (O4 * 3) + (O3 * 4) + (O2 * 5) + (O1 * 6) + (DV * 7) + (B7 * 8) + (B6 * 9) + (B5 * 2) + (B4 * 3) + (B3 * 4) + (B2 * 5) + (B1 * 6))
RESTO1 = TOTAL1 Mod 11

If RESTO1 = 0 Or RESTO1 = 1 Then
    C2 = 0
Else
    C2 = 11 - RESTO1
End If
VLC1 = C1 & C2
If Right(NRCGC_ADQ, 2) <> VLC1 Then
    Beep
    MsgBox "CGC no confere", 16, "Ateno"
    SendKeys "+{TAB}{DEL}"
End If


End Function

Public Function Verificar_CPF(Cpf As String)

Dim X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11 As String
Dim A, B, C, D, E, F, G, H, I, J, K As String
Dim TOTAL, R_Int1, Digito, Controle1, Controle2 As Integer
'Selecionando Nmeros

X1 = Left(Cpf, 1)
X2 = Left(Cpf, 2)
X3 = Left(Cpf, 3)
X4 = Left(Cpf, 4)
X5 = Left(Cpf, 5)
X6 = Left(Cpf, 6)
X7 = Left(Cpf, 7)
X8 = Left(Cpf, 8)
X9 = Left(Cpf, 9)
X10 = Left(Cpf, 10)
X11 = Left(Cpf, 11)

'Atribuindo Nmeros

A = Int(X1)
B = Int(Right(X2, 1))
C = Int(Right(X3, 1))
D = Int(Right(X4, 1))
E = Int(Right(X5, 1))
F = Int(Right(X6, 1))
G = Int(Right(X7, 1))
H = Int(Right(X8, 1))
I = Int(Right(X9, 1))
J = Int(Right(X10, 1))
K = Int(Right(X11, 1))


'Calculando o dgito

TOTAL = ((A * 3) + (B * 4) + (C * 5) + (D * 6) + (E * 7) + (F * 8) + (G * 9))
R_Int1 = Fix(TOTAL / 11) 'Pegando somente a parte inteira do TOTAL
R_Int1 = R_Int1 * 11
Digito = TOTAL - R_Int1

'Calculando o primeiro controle
TOTAL = ((A * 1) + (B * 2) + (C * 3) + (D * 4) + (E * 5) + (F * 6) + (G * 7) + (H * 8) + (I * 9))
R_Int1 = Fix(TOTAL / 11) 'Pegando somente a parte inteira do TOTAL
R_Int1 = R_Int1 * 11
Controle1 = TOTAL - R_Int1
If Controle1 = 10 Then
    Controle1 = 0
End If

'Calculando o segundo controle
TOTAL = ((B * 1) + (C * 2) + (D * 3) + (E * 4) + (F * 5) + (G * 6) + (H * 7) + (I * 8) + (Controle1 * 9))
R_Int1 = Fix(TOTAL / 11) 'Pegando somente a parte inteira do TOTAL
R_Int1 = R_Int1 * 11
Controle2 = TOTAL - R_Int1
If Controle2 = 10 Then
    Controle2 = 0
End If

If Right(Cpf, 2) <> Controle1 & Controle2 Then
    Verificar_CPF = False
Else
    Verificar_CPF = True
End If

End Function
Public Function JanelaImprimir()
On Error GoTo Err_Imprimir

    DoCmd.RunCommand acCmdPrint
    Exit Function
    
Err_Imprimir:
If Err.Number = 2501 Then
    Exit Function
End If
End Function


Public Function AbrirFormularioNormal(NomeDoFormulario As String)

    DoCmd.OpenForm NomeDoFormulario
    
End Function
Public Function AbrirFormularioDialogo(NomeDoFormulario As String)

    DoCmd.OpenForm NomeDoFormulario, , , , , acDialog
    
End Function

Public Function AbrirFormularioOculto(NomeDoFormulario As String)

    DoCmd.OpenForm NomeDoFormulario, , , , , acHidden
    
End Function

Public Function ImprimirRelatorio(NomeDoRelatorio As String)

    DoCmd.OpenReport NomeDoRelatorio, acViewNormal
    
End Function
Public Function VizualizarRelatorio(NomeDoRelatorio As String)

    DoCmd.OpenReport NomeDoRelatorio, acViewPreview
        
End Function

Public Function Maximizar()
    DoCmd.Maximize
End Function

Public Function Minimizar()
    DoCmd.Minimize
    
End Function

Public Function Restaurar()
    DoCmd.Restore
End Function

Public Function AbrirConsulta(NomeDaConsulta As String)
    DoCmd.OpenQuery NomeDaConsulta
End Function

Public Function AbrirTabela(NomeDaTabela As String)
    DoCmd.OpenTable NomeDaTabela
End Function

Public Function ExecutarSQL(SQL As String)
    DoCmd.RunSQL SQL
End Function

Public Function RetirarAvisos()
    DoCmd.SetWarnings False
End Function

Public Function ColocarAvisos()
    DoCmd.SetWarnings True
End Function

Public Function ExecutarMacro(NomeDaMacro As String)
    DoCmd.RunMacro NomeDaMacro
End Function

Public Function OcultarBarraDeFerramentas(NomeDaBarra As String)
    DoCmd.ShowToolbar NomeDaBarra, acToolbarNo
End Function
Public Function ExibirBarraDeFerramentas(NomeDaBarra As String)
    DoCmd.ShowToolbar NomeDaBarra, acToolbarYes
End Function

Public Function ExecutarAplicativo(Caminho As String)
Dim Retorno
Retorno = Shell(Caminho, vbNormalFocus)
End Function

Public Function Datilografar()
Dim Retorno
Retorno = PlaySound("C:\Windows\Media\Office97\Digitar.wav", 1, 1)

End Function
Function Justifica(lpzText, ControlText As Control, objReport As Report) As String
'Simula o alinhamento justificado de texto em campos em relatrios do Access
'Verso 1.0
'Autor: Larissa Redeker

On Error GoTo Err_Justifica

Dim Carac As String, Newtext As String
Dim Numspaces As Integer, WidthSpace As Integer
Dim WidthControl As Integer
Dim I As Integer, Inicio As Integer
Dim LastPos As Integer, PosSpace As Integer, PoscharBreak As Integer
Dim FinalText As String, SpacesInStr As Integer
Dim SizeText As Integer
Dim POSI As Variant, CI As Integer
Dim NextCarac As String
Dim n As Integer

'As prximas 4 linhas definem as propriedades de fontes do relatrio com as
'definies da caixa de texto que ir receber o texto justificado, pois as
'dimenses do texto para clculos so feitas atravs da propriedade TextWidth
'do relatrio

objReport.FontName = ControlText.FontName
objReport.FontSize = ControlText.FontSize
objReport.FontBold = ControlText.FontBold
objReport.FontItalic = ControlText.FontItalic
'Obtm o tamanho da caixa de texto que ir receber o texto alinhado
WidthControl = ControlText.Width
'Obtm o tamanho de espao na fonte atual
WidthSpace = objReport.TextWidth(" ")
'obtm o tamanho do texto a ser justificado
SizeText = Len(lpzText)

I = 1
Inicio = 1

Do While I <> WidthControl
'Se a nova seqncia for maior que o controle que ir receber o texto,
'refaz a nova seqncia para caber na caixa de texto
Newtext = Mid(lpzText, Inicio, LastPos - Inicio)
'obtm o nmero de espaos necessrios, que devero ser inseridos na nova
'seqncia de texto
Numspaces = Fix((WidthControl - objReport.TextWidth(Newtext)) / WidthSpace) - 1
For n = 1 To Len(Newtext)
    'Calcula o nmero de espaos existentes na nova seqncia de texto
    Carac = Mid(Newtext, n, 1)
    If Carac = " " Then SpacesInStr = SpacesInStr + 1
Next n
    
POSI = 1
CI = 1
PoscharBreak = 0
    
    Do While CI = ""
        NextCarac = Mid(Newtext, POSI + 1, 1)
        If NextCarac = " " Then
            Newtext = Mid(Newtext, 1, POSI) + String(1, " ") + Mid(Newtext, POSI + 1)
            POSI = POSI + 1
            CI = CI + 1
        End If
        PoscharBreak = PoscharBreak + 1
        If PoscharBreak = SpacesInStr Then
            PoscharBreak = 0
            POSI = 0
        End If

        POSI = POSI + 1
    Loop

    FinalText = FinalText + Newtext + Chr(13) + Chr(10)
    Newtext = ""
    I = LastPos
    LastPos = 0
    Inicio = I + 1

    LastPos = I


    I = I + 1
Loop
Justifica = FinalText & Newtext

Exit_Justifica:
Exit Function

Err_Justifica:
Resume Exit_Justifica

End Function

Public Function AutoNumeracao(NomeDaTabela As String, NomeDoCampo As String)
Dim MyDB As Database
Dim MyTB As Recordset

Set MyDB = CurrentDb()
Set MyTB = MyDB.OpenRecordset("Select Max(" & NomeDoCampo & ") as Codigo From " & NomeDaTabela)

If MyTB.RecordCount > 0 Then
    AutoNumeracao = Int(MyTB!Codigo) + 1
Else
    AutoNumeracao = 1
End If

End Function

Public Function FormularioAtivo()
On Error GoTo Err_Ativo
Dim frmFormulrioAtual As Form
Set frmFormulrioAtual = Screen.ActiveForm
FormularioAtivo = frmFormulrioAtual.Name
Exit Function

Err_Ativo:
If Err.Number = 2475 Then
    FormularioAtivo = "No ha formulario"
End If
End Function



Public Function CriarMalaDireta(NomeDaTabela As String)
RetirarAvisos
ExecutarSQL ("SELECT TB_MalaDireta.NM_AGENDADO, TB_CARGOS.NM_CARGO, " _
            & " TB_DEPARTAMENTO.NM_DEPARTAMENTO, TB_INSTITUICOES.NM_INSTITUICAO, " _
            & " TB_INSTITUICOES.SG_INSTITUICAO, TB_MalaDireta.NM_TRATAMENTO, " _
            & " TB_MalaDireta.DS_ENDERECO, TB_MalaDireta.NM_CIDADE, TB_MalaDireta.NM_BAIRRO, " _
            & " TB_MalaDireta.CD_UF, TB_MalaDireta.NR_CEP, TB_MalaDireta.NR_CPOSTAL, " _
            & " TB_MalaDireta.NR_DDD, TB_MalaDireta.NR_TEL1, TB_MalaDireta.NR_TEL2, " _
            & " TB_MalaDireta.NR_CELULAR, TB_MalaDireta.NR_FAX, " _
            & " TB_MalaDireta.DS_EMAIL INTO " & NomeDaTabela & " FROM ((TB_MalaDireta " _
            & " INNER JOIN TB_INSTITUICOES ON TB_MalaDireta.CD_INSTITUICAO = TB_INSTITUICOES.CD_INSTITUICAO)" _
            & " INNER JOIN TB_DEPARTAMENTO ON TB_MalaDireta.CD_DEPARTAMENTO = TB_DEPARTAMENTO.CD_DEPARTAMENTO)" _
            & " INNER JOIN TB_CARGOS ON TB_MalaDireta.CD_CARGO = TB_CARGOS.CD_CARGO")
            
ColocarAvisos

End Function
Function AlterarPropriedade(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer

    Dim dbs As Database, prp As Property
    Const conPropNotFoundError = 3270
    Set dbs = CurrentDb
    On Error GoTo Change_Err
    dbs.Properties(strPropName) = varPropValue
    AlterarPropriedade = True

Change_Bye:
    Exit Function

Change_Err:
    If Err = conPropNotFoundError Then  ' Propriedade no localizada.

Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)
        dbs.Properties.Append prp
        Resume Next
    Else
        ' Erro desconhecido.
        AlterarPropriedade = False
        Resume Change_Bye
    End If

End Function


Public Function DesativarShift()
AlterarPropriedade "AllowBypassKey", dbBoolean, False

End Function
Public Function AtivarShift()
AlterarPropriedade "AllowBypassKey", dbBoolean, True

End Function

