Cada uma das funções abaixo deve ser guardada por você no seu 'cinto de utilidades', nem que seja num simples arquivo texto. Com isso você evitaria perder tempo sempre que tiver que criar essas funções e praticamente toda app sua elas.
Ler arquivo Texto
A função abaixo foi feita para uma aplicação tipo Console que lê os dados de um arquivo texto e devolve um dado tipo string.
O nome do arquivo pode ter o path completo para leitura do arquivo mas sugiro que use o chdir antes para navegar até a pasta do arquivo (veja abaixo).
Public Function LeArqTexto(NomeArq As String) As String
Dim linha As String
Dim dado As String
Console.WriteLine("Lendo os dados do Arquivo : " + NomeArq)
dado = ""
Try
Dim sr As StreamReader = New StreamReader(NomeArq, System.Text.Encoding.Default)
Do
linha = sr.ReadLine()
dado += dado + vbCrLf
Loop Until linha Is Nothing
sr.Close()
Console.WriteLine("Leitura dos dados do arquivo " + NomeArq + " feita com Sucesso")
Catch e As Exception
Console.Write("Erro ao ler o arquivo: " + e.Message)
Console.WriteLine("Falha na leitura dos dados do arquivo " + NomeArq + ", Terminando o processo")
sair()
End Try
Return dado
End Function
Exemplo de uso:
Public Sub x()
Dim a As String
a = LeArqTexto("nomeDoArquivo")
End Sub
A função abaixo foi feita em windows forms application e lê um arquivo texto:
Public Function LeArqTexto(arq As String) As String
Return (My.Computer.FileSystem.ReadAllText(arq))
End Function
Gravar arquivo Texto
Segue os mesmos princípios do LeArqTexto acima contudo os parâmetros são o nome do arquivo a ser gerado e os dados a serem gravados.
Public Sub GravarArqTexto(NomeArq As String, dado As String)
Dim a As String
Console.Write("Gravando os dados no arquivo: " + NomeArq)
Try
a = PegaPasta(NomeArq)
ChDir("C:\")
ChDir(Mid(a, 4))
Dim sw As StreamWriter = New StreamWriter(PegaNomeArq(NomeArq), True)
sw.WriteLine(dado)
sw.Close()
Console.Write("Gravação dos dados no arquivo: " + NomeArq + " terminada com sucesso")
Catch ex As Exception
Console.Write("Erro ao gravar o arquivo: " + ex.Message + ", terminando o Processo")
sair()
End Try
End Sub
Exemplo de uso:
Public Sub x()
Dim a As String
a = "algum dado"
GravarArqTexto("nomeDoArquivo", a)
End Sub
Sair da aplicação
Suponha que sua app tenha feito um monte de coisas e no console.writeline você tenha emitido um monte de mensagens.
Antes de terminar a aplicação você gostaria de dar um tempinho para o usuário ler as mensagens antes de fechar a aplicação.
A sugestão aqui é usar a instrução sleep e no exemplo abaixo 5000 é o tempo em milisegundos, ou seja, 5 segundos antes de fechar a aplicação.
Public Sub sair()
System.Threading.Thread.Sleep(5000) '5 segundos
End
End Sub
Public Sub dormir(tempo As Integer)
Dim a As Integer
a = tempo
While a > 0
System.Threading.Thread.Sleep(1000)
Application.DoEvents()
a -= 1
End While
End Sub
Pega Pasta
Suponha que você tem um string com a pasta e o nome do arquivo e você deseja pegar apenas a pasta do arquivo desse string. A função abaixo faz isso:
Public Function PegaPasta(NomeArq As String) As String
Dim a As String
a = NomeArq
a = Left(a, InStrRev(a, "\") - 1)
Return a
End Function
Exemplo de uso:
Public Sub x()
Dim a As String
a = PegaPasta("C:\pastax\arquivoy")
End Sub
Executando a função acima a variável a viria com o valor "C:\pastax". Note que o -1 remove o \ final da pasta.
Pega NomeArquivo
Suponha que você tem um string com a pasta e o nome do arquivo e você deseja pegar apenas o nome do arquivo desse string. A função abaixo faz isso:
Public Function PegaNomeArq(NomeArq As String) As String
Dim a As String
a = NomeArq
a = Mid(a, InStrRev(a, "\") + 1)
Return a
End Function
Exemplo de uso:
Public Sub x()
Dim a As String
a = PegaNomeArq("C:\pastax\arquivoy")
End Sub
Executando a função acima a variável a viria com o valor "arquivoy".
Carregar Arquivo de Opções 1
Suponha que você tenha um arquivo de opções do programa que deseja salvar os parâmetros de funcionamento dele para que não precise mudar o programa cada vez que um desses parâmetros for mudado. No exemplo abaixo menciono como ler os parâmetros de conexão de um servidor MS SQL, o nome da proc (procedure) a ser executada e o nome do arquivo onde os dados da proc devem ser armazenados.
Exemplo:
MS_SQL_servidor = srv1
MS_SQL_bd = bd2
MS_SQL_Usuario = usu3
MS_SQL_Senha = senha4
MS_SQL_proc = procmssql5
nomearq = C:\pasta6\NomeArq7.txt
Parte 1 : Definição das variáveis de configuração do sistema
'servidor MS SQL
Public MS_SQL_servidor As String
Public MS_SQL_bd As String
Public MS_SQL_Usuario As String
Public MS_SQL_Senha As String
Public MS_SQL_proc As String
Public nomearq As String
Parte 2 : Mostro agora a rotina que vai separar o parâmetro de seu dado retornando apenas o dado, ou seja:
Info recebida aquivo texto = MS_SQL_servidor = srv1 seria desmembrado em:
Parâmetro = MS_SQL_servidor
Dado = srv1
Public Function PegaParametro(dado As String)
Dim a As String
a = dado
a = Mid(a, InStrRev(a, "=") + 1)
Return a
End Function
Parte 3 : Lê o arquivo texto de parâmetros e colocar nos strings de configuração do programa.
Public Sub DefineParametros()
Dim pasta As String
Dim sr As IO.StreamReader
Dim dado As String
Console.WriteLine("Lendo o arquivo de configuração: config.txt")
'pasta = Environment.SpecialFolder.DesktopDirectory
pasta = Environment.CurrentDirectory
If IO.File.Exists(pasta + "\config.txt") Then
Console.WriteLine("Arquivo de configuração encontrado...Lendo...")
sr = New IO.StreamReader(pasta + "\config.txt")
dado = sr.ReadLine
While dado <> Nothing
If InStr(dado, "MS_SQL_servidor") > 0 Then
MS_SQL_servidor = PegaParametro(dado)
End If
If InStr(dado, "MS_SQL_bd") > 0 Then
MS_SQL_bd = PegaParametro(dado)
End If
If InStr(dado, "MS_SQL_Usuario") > 0 Then
MS_SQL_Usuario = PegaParametro(dado)
End If
If InStr(dado, "MS_SQL_Senha") > 0 Then
MS_SQL_Senha = PegaParametro(dado)
End If
If InStr(dado, "MS_SQL_proc") > 0 Then
MS_SQL_proc = PegaParametro(dado)
End If
If InStr(dado, "nomearq") > 0 Then
nomearq = PegaParametro(dado)
End If
dado = sr.ReadLine
End While
Console.WriteLine("Leitura do arquivo de configuração terminada com Sucesso...")
sr.Close()
Else
Console.WriteLine("Arquivo de configuração config.txt não existe...criando um novo")
Dim sw As New IO.StreamWriter(pasta + "config.txt", True)
sw.WriteLine("MS_SQL_servidor = srv1")
sw.WriteLine("MS_SQL_bd = bd2")
sw.WriteLine("MS_SQL_Usuario = usu3")
sw.WriteLine("MS_SQL_Senha = senha4")
sw.WriteLine("MS_SQL_proc = senha5")
sw.WriteLine("nomearq = C:\pasta6\Arquivo7.txt")
sw.Close()
Console.WriteLine("Arquivo de configuração Criado com Sucesso...")
End If
End Sub
Carregar Arquivo de Opções 2
Suponha que você tenha um arquivo texto tipo 'config.txt' que tenha a configuração do seu sistema
''' <summary>
''' Esta sub Carrega as opçoes do programa do arquivo opcoes.txt
''' </summary>
Public Function CarregarOpcoes() As List(Of String)
Dim ArquivoTexto As IO.StreamReader
Dim DadoArqTexto As String
Dim pasta As String
Dim b As New List(Of String)
'Environment.SystemDirectory
'Environment.CurrentDirectory
'pasta = Environment.GetFolderPath(Environment.SpecialFolder.System)
pasta = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData)
If Right(pasta, 1) <> "\" Then
pasta = pasta + ""
End If
If IO.File.Exists(pasta + "opcoes.Text") Then
b.Clear()
ArquivoTexto = New IO.StreamReader(pasta + "opcoes.Text")
'primeira linha : Pasta de Arquivos de Origem
DadoArqTexto = ArquivoTexto.ReadLine
b.Add(DadoArqTexto) 'PastaOrigem
'segunda linha : Pasta de Arquivos de Destino
DadoArqTexto = ArquivoTexto.ReadLine
b.Add(DadoArqTexto) 'PastaDestino
'terceira linha : Número de horas para repetir processo
DadoArqTexto = ArquivoTexto.ReadLine
b.Add(DadoArqTexto) 'NumHoras
'quarta linha : Incluir subpastas
DadoArqTexto = ArquivoTexto.ReadLine
If DadoArqTexto = "SIM" Then
b.Add("True") 'IncluirSubPastas
Else
b.Add("False") 'IncluirSubPastas
End If
ArquivoTexto.Close()
Return b
Else
Return Nothing
End If
End Function
Salvar o Arquivo de Opções
''' <summary>
''' Esta rotina salva as opções do usuário sobre o programa no arquivo opcoes.txt
''' </summary>
Public Sub SalvarOpcoes(a As List(Of String))
Dim ArquivoTexto As IO.StreamWriter
Dim pasta As String
pasta = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData)
If Right(pasta, 1) <> "\" Then
pasta = pasta + ""
End If
ArquivoTexto = New IO.StreamWriter(pasta + "opcoes")
'primeira linha : Pasta de Arquivos de Origem
ArquivoTexto.WriteLine(a(0))
'segunda linha : Pasta de Arquivos de Destino
ArquivoTexto.WriteLine(a(1))
'terceira linha : Número de horas para repetir processo
ArquivoTexto.WriteLine(a(2))
'quarta linha : Pasta de Arquivos de Destino
If a(3) = "True" Then
ArquivoTexto.WriteLine("SIM")
Else
ArquivoTexto.WriteLine("NAO")
End If
ArquivoTexto.Close()
End Sub
End Module
Modulo Utilitarias
Função Limpa : Muitas vezes recebemos dados com informações inválidas como NULL, datas desformatadas onde o 0 do dia ou mês foram suprimidos e se a informação for utilizada com esse formato irá provocar um erro. Esta função limpa retorna ou o dado formatado ou um string vazio evitando erros.
Public Function limpa(ByVal dado As Object) As String
Dim dia, mes, ano As Integer
Dim data As DateTime
Dim saida As String
If IsDBNull(dado) Then
Return "'NULL'"
End If
If IsDate(dado) Then
data = CDate(dado)
dia = data.Day
mes = data.Month
ano = data.Year
If dia < 10 Then
saida = "0" + CStr(dia)
Else
saida = CStr(dia)
End If
saida = saida + "/"
If mes < 10 Then
saida = saida + "0" + CStr(mes)
Else
saida = saida + CStr(mes)
End If
saida = saida + "/" + CStr(ano)
Return saida
End If
If IsNumeric(dado) Then
saida = Trim(CStr(dado))
saida = Replace(saida, ",", ".")
Return saida
End If
saida = Trim(dado)
saida = Replace(saida, "'", "´")
Return saida
End Function
A função abaixo retorna true se o sring recebido é um CNPJ válido.
Public Function E_CNPJ(ByVal ID As String) As Boolean
' validando se CGC ou CNPJ
'o campo deve vir com 14 caracteres numéricos completados com zeros a esquerda
'a validação é feita com o formato xxx.xxx.xxx-xx
Dim a As Integer
Dim j As Integer
Dim d1 As Integer
Dim i As Integer
Dim d2 As Integer
Dim b As String
E_CNPJ = True
If ID = "" Then
E_CNPJ = False
Exit Function
End If
b = Limpa_CPF_CNPJ(ID)
While (Left(b, 1) = "0") And (Len(b) > 8)
b = Mid$(b, 2, 2000)
End While
If (Len(b) > 8) And (Len(b) < 14) Then
While Len(b) < 14
b = "0" + b
End While
End If
If Len(b) = 8 And Val(b) > 0 Then
a = 0
j = 0
d1 = 0
For i = 1 To 7
a = Val(Mid(b, 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(b, 9, 1)) Then
E_CNPJ = True
Else
E_CNPJ = False
End If
Else
If Len(b) = 14 And Val(b) > 0 Then
a = 0
i = 0
d1 = 0
d2 = 0
j = 5
For i = 1 To 12 Step 1
a = a + (Val(Mid(b, 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(b, 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(b, 13, 1)) And d2 = Val(Mid(b, 14, 1))) Then
E_CNPJ = True
Else
E_CNPJ = False
End If
Else
E_CNPJ = False
End If
End If
Return E_CNPJ
End Function
A função abaixo retorna true se o sring recebido é um CPF válido.
Public Function E_CPF(ByVal ID As String) As Boolean
' valida se cpf
Dim soma As Integer
Dim Resto As Integer
Dim i As Integer
Dim b As String
E_CPF = True
If ID = "" Then
E_CPF = False
Exit Function
End If
If Len(ID) < 5 Then
E_CPF = False
Exit Function
End If
b = Limpa_CPF_CNPJ(ID)
If Not IsNumeric(b) Then
E_CPF = False
Exit Function
End If
While (Strings.Left(b, 1) = "0") And (Len(b) > 11)
b = Mid$(b, 2, 2000)
End While
While Len(b) < 11
b = "0" + b
End While
'Valida argumento
If Len(b) <> 11 Then
E_CPF = False
Exit Function
End If
soma = 0
For i = 1 To 9
soma = soma + Val(Mid$(b, 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$(b, 10, 1)) Then
E_CPF = False
Exit Function
End If
soma = 0
For i = 1 To 10
soma = soma + Val(Mid$(b, 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$(b, 11, 1)) Then
E_CPF = False
Exit Function
End If
Return E_CPF
End Function
A função abaixo retorna true se o sring recebido é um CEI (veja IBGE) válido.
Public Function E_CEI(cei As String) As Boolean
'CEI = Código Específico do INSS
'O CEI são 11 digitos mais 1 digito verificador
Try
Dim numcei As String
Dim Pesos = New Integer() {7, 4, 1, 8, 5, 2, 1, 6, 3, 7, 4}
Dim soma As Integer = 0
Dim SOMA_CEI(11) As Integer
Dim dv As String = ""
Dim Total As Integer = 0
Dim CEI1(11) As Integer
Dim i As Integer
Dim j As Integer
'retirando os zeros não significativos a esquerda
numcei = cei
While (Left(numcei, 1) = "0") And (Len(numcei) > 12)
numcei = Mid(numcei, 2, 100)
End While
If (numcei.Length < 12) Then
Return False
End If
'Convertendo os caracteres do CEI para inteiro e criando um array
For i = 0 To Len(numcei) - 2
CEI1(i) = CInt(Mid(numcei, i + 1, 1))
SOMA_CEI(i) = CEI1(i) * Pesos(i)
Next
soma = 0
For j = 0 To 10
soma = soma + SOMA_CEI(j)
Next
j = Int(soma / 10)
j = soma Mod 10 + j
j = (Math.Abs(10 - j) Mod 10)
dv = CStr(j)
If (numcei.Substring(11, 1) = dv) Then
Return True
Else
Return False
End If
Catch ex As Exception
MsgBox("Ocorreu um Erro : " + Err.Description, vbCritical, "Function E_CEI")
Return False
End Try
End Function
A função abaixo retornira os caracteres acentuados e retorna em seu lugar o caractere sem acento. Muito util quando convertemos dos codepages 1252 e UTF-8.
Public Function RetiraAcentuacao(ByVal dado As String) As String
Dim a As String
a = dado
'substutuição de acentuação - minúsculas
a = Replace(a, "á", "a")
a = Replace(a, "à", "a")
a = Replace(a, "ã", "a")
a = Replace(a, "â", "a")
a = Replace(a, "ä", "a")
a = Replace(a, "é", "e")
a = Replace(a, "è", "e")
a = Replace(a, "ê", "e")
a = Replace(a, "ë", "e")
a = Replace(a, "í", "i")
a = Replace(a, "ì", "i")
a = Replace(a, "î", "i")
a = Replace(a, "ï", "i")
a = Replace(a, "ó", "o")
a = Replace(a, "ò", "o")
a = Replace(a, "õ", "o")
a = Replace(a, "ô", "o")
a = Replace(a, "ö", "o")
a = Replace(a, "ú", "u")
a = Replace(a, "ù", "u")
a = Replace(a, "û", "u")
a = Replace(a, "ü", "u")
a = Replace(a, "ç", "c")
'substutuição de acentuação - maiúsculas
a = Replace(a, "Á", "A")
a = Replace(a, "À", "A")
a = Replace(a, "Ã", "A")
a = Replace(a, "Â", "A")
a = Replace(a, "Ä", "A")
a = Replace(a, "É", "E")
a = Replace(a, "È", "E")
a = Replace(a, "Ê", "E")
a = Replace(a, "Ë", "E")
a = Replace(a, "Í", "I")
a = Replace(a, "Ì", "I")
a = Replace(a, "Î", "I")
a = Replace(a, "Ï", "I")
a = Replace(a, "Ó", "O")
a = Replace(a, "Ò", "O")
a = Replace(a, "Õ", "O")
a = Replace(a, "Ô", "O")
a = Replace(a, "Ö", "O")
a = Replace(a, "Ú", "U")
a = Replace(a, "Ù", "U")
a = Replace(a, "Û", "U")
a = Replace(a, "Ü", "U")
a = Replace(a, "Ç", "C")
Return a
End Function
End Module
Critica MS SQL 1 - Parâmetros versus dados.
Suponha que você seja um cara super organizado e que preze muito a identação e as boas práticas de programação.
Contudo algumas situações são cruéis até para os mais masoquistas. Veja o exemplo abaixo, tenho uma instrução insert do MS SQL.
Ao executar ela o programa exibe uma mensagem de erro...o número de parâmetros não bate com o número de dados.
Saberia me dizer aonde está o erro ?
txtQuery.Text = "insert into tbl_aux_turma (id_turma, id_curso, id_dependencia, emp_coordenador, re_coordenador, & _
id_superintendencia, id_competencia, id_classificacao, id_emp_instrutor, id_instrutor, & _
id_emp_instrutor_01, id_instrutor_01, id_emp_instrutor_02, id_instrutor_02, id_vendor, & _
max_vagas, min_vagas, custo, tipo_turma, carga_horaria, status, dt_criacao_turma, dt_inicio_inscricao, & _
dt_fim_inscricao, dt_inicio_treinamento, dt_fim_treinamento, hora_inicio_treinamento, & _
hora_fim_treinamento, hora_intervalo, dias_cancelamento, dias_semana, observacao, & _
hr_inicio_inscricao, hr_fim_inscricao, publico_alvo, id_produto, contrato, ordem_interna, & _
re_usuario, dt_ult_atu,tipo_competencia) & _
values ('0001;;T91000', 'T91000', 'M23', '0020', '0000000', 'H*HS', '7', '47', '0020', & _
'R26686388', '', '', '', '', '000222', 9, 1 , 22500 , '2', 1,8, '1', convert(datetime,'18/8/2004',103), & _
convert(datetime,'19/8/2004',103), convert(datetime,'19/8/2004',103), convert(datetime,'20/8/2004',103), & _
convert(datetime,'20/8/2004',103), '1/1/1900 14:00:00', '1/1/1900 16:00:00', '1/1/1900 00:12:00', '1', & _
'0000100', 'Turma cadastrada para testes no sistema.', '', '', '', '', '', '', '0000000', & _
convert(datetime,'19/8/2004',103), '3')"
Vou ajudar...Os parâmetros do insert são:
id_turma, id_curso, id_dependencia, emp_coordenador, re_coordenador, & _
id_superintendencia, id_competencia, id_classificacao, id_emp_instrutor, id_instrutor, & _
id_emp_instrutor_01, id_instrutor_01, id_emp_instrutor_02, id_instrutor_02, id_vendor, & _
max_vagas, min_vagas, custo, tipo_turma, carga_horaria, status, dt_criacao_turma, dt_inicio_inscricao, & _
dt_fim_inscricao, dt_inicio_treinamento, dt_fim_treinamento, hora_inicio_treinamento, & _
hora_fim_treinamento, hora_intervalo, dias_cancelamento, dias_semana, observacao, & _
hr_inicio_inscricao, hr_fim_inscricao, publico_alvo, id_produto, contrato, ordem_interna, & _
re_usuario, dt_ult_atu,tipo_competencia)
Mais uma ajudinha...Os dados são :
values ('0001;;T91000', 'T91000', 'M23', '0020', '0000000', 'H*HS', '7', '47', '0020', & _
'R26686388', '', '', '', '', '000222', 9, 1 , 22500 , '2', 1,8, '1', convert(datetime,'18/8/2004',103), & _
convert(datetime,'19/8/2004',103), convert(datetime,'19/8/2004',103), convert(datetime,'20/8/2004',103), & _
convert(datetime,'20/8/2004',103), '1/1/1900 14:00:00', '1/1/1900 16:00:00', '1/1/1900 00:12:00', '1', & _
'0000100', 'Turma cadastrada para testes no sistema.', '', '', '', '', '', '', '0000000', & _
convert(datetime,'19/8/2004',103), '3')"
Complicado né...e se você mexe muito com SQL pode deparar com erros semelhantes.
Funções para bater os parâmetros com os dados
Private Sub btnProcessar_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnProcessar.Click
Dim a As Integer 'varre caractere por caractere da querie
Dim b As String 'parte da query desmembrada
Dim campos(1000) As String 'campos do insert
Dim dados(1000) As String 'parametros recebidos
Dim pnt1 As Integer = 0 'aponta para campos() e dados()
Dim pnt2 As Integer = 0 'aponta para campos() e dados()
Dim flg_apostrofo As Boolean 'flag dentro de apóstrofo-desconsiderar vírgulas
Dim flg_abreparenteses As Boolean 'flag dentro de apóstrofo-desconsiderar vírgulas
Dim c As String 'caractere da querie
frmQuerieDecomposta.Visible = True
frmQuerieDecomposta.ListBox1.Items.Clear()
'separando a parte inicial - até o abre parenteses
a = 1
b = ""
c = Mid(txtQuery.Text, a, 1)
While c <> "("
b = b + c
a = a + 1
c = Mid(txtQuery.Text, a, 1)
End While
b = b + Mid(txtQuery.Text, a, 1)
frmQuerieDecomposta.txtOperacao.Text = b 'insert into tabela(
'separando os campos da tabela
a = a + 1
b = ""
pnt1 = 0
c = Mid(txtQuery.Text, a, 1)
While c <> ")"
b = b + c
If c = "," Then
b = Strings.Left(b, Len(b) - 1)
campos(pnt1) = limpa(b)
pnt1 = pnt1 + 1
b = ""
End If
a = a + 1
c = Mid(txtQuery.Text, a, 1)
End While
'separando a parte intermediaria - ) values ( - insert into tabela(campos) values (
b = ""
c = Mid(txtQuery.Text, a, 1)
While c <> "("
b = b + c
a = a + 1
c = Mid(txtQuery.Text, a, 1)
End While
b = b + c
a = a + 1
'frmQuerieDecomposta.ListBox1.Items.Add(b) ') values (
flg_apostrofo = False 'flag dentro de apóstrofo-desconsiderar vírgulas
flg_abreparenteses = False 'flag dentro de apóstrofo-desconsiderar vírgulas
'separando os parametros
b = ""
pnt2 = 0
c = Mid(txtQuery.Text, a, 1)
While c <> ")" Or (flg_apostrofo = True) Or (flg_abreparenteses = True)
b = b + c
'verificando as vírgulas - só contabilizar virgulas se estiver fora de 'Endereço x,x,x,' e convert(x,x,x)
If (flg_apostrofo = False) And (flg_abreparenteses = False) Then
If c = "," Then
b = Strings.Left(b, Len(b) - 1)
dados(pnt2) = Limpa(b)
pnt2 = pnt2 + 1
b = ""
End If
End If
'verificando abre parenteses
If c = "(" Then
flg_abreparenteses = True
End If
If Mid(txtQuery.Text, a, 1) = ")" Then
flg_abreparenteses = False
End If
'verificando apostrofe
If c = "'" Then
If flg_apostrofo Then
flg_apostrofo = False
Else
flg_apostrofo = True
End If
End If
a = a + 1
c = Mid(txtQuery.Text, a, 1)
End While
'verificando se o número de campos bate com o número de parametros
If pnt1 <> pnt2 Then
b = "Falha : Foram encontrados : " + CStr(pnt1) + " campos e " + CStr(pnt2) + " parâmetros"
txtMsg.Text = b
'frmQuerieDecomposta.ListBox1.Items.Add(b)
If pnt2 > pnt1 Then
pnt1 = pnt2
End If
End If
'exibindo o resultado
For a = 0 To pnt1 - 1
b = Strings.Right("0000" + CStr(a), 4) + " " + formata(campos(a), 30) + formata(dados(a), 3 0)
frmQuerieDecomposta.ListBox1.Items.Add(b)
Next
End Sub
Function Limpa(dado As String) As String
Dim a As String
a = dado
retorno:
If Strings.Left(a, 2) = vbCrLf Then
a = Mid(a, 3)
GoTo retorno
End If
If Strings.Left(a, 1) = vbTab Then
a = Mid(a, 2)
GoTo retorno
End If
If Strings.Left(a, 1) = " " Then
a = Mid(a, 2)
GoTo retorno
End If
If Strings.Left(a, 1) = "&" Then
a = Mid(a, 2)
GoTo retorno
End If
If Strings.Left(a, 1) = "_" Then
a = Mid(a, 2)
GoTo retorno
End If
'----------------------------------------------
If Strings.Right(a, 2) = vbCrLf Then
a = Mid(a, 1, Len(a) - 2)
GoTo retorno
End If
If Strings.Right(a, 1) = vbTab Then
a = Mid(a, 1, Len(a) - 1)
GoTo retorno
End If
If Strings.Right(a, 1) = " " Then
a = Mid(a, 1, Len(a) - 1)
GoTo retorno
End If
If Strings.Right(a, 1) = "&" Then
a = Mid(a, 1, Len(a) - 1)
GoTo retorno
End If
If Strings.Right(a, 1) = "_" Then
a = Mid(a, 1, Len(a) - 1)
GoTo retorno
End If
Return a
End Function
Public Function formata(dado As String, tam As Integer)
Dim a As String
a = dado
While Len(a) < tam
a += " "
End While
Return a
End Function
Rodando a pesquisa acima você irá descobrir que tem um dado a mais que parâmetro. O ruim é descobrir qual é mas o erro fica claro.
Abrindo um documento PDF.
A sub abaixo abre o Acrobat PDF Reader instalado no sistema operacional para exibir um arquivo PDF numa pasta específica.
Private Sub btnDoc_Click(sender As Object, e As EventArgs) Handles btnDoc.Click
Dim a As String
Dim b As String
Dim c As String
b = Chr(34) + "C:\Program Files\Adobe\Acrobat DC\Acrobat\Acrobat.exe" + Chr(34)
a = System.Windows.Forms.Application.StartupPath
a += "Documentox.pdf"
'a = Chr(34) + a + Chr(34)
c = b + " " + Chr(34) + a + Chr(34)
If ArquivoExiste(a) Then
Process.Start(c)
End If
End Sub
Função Data
Emitir mensagens e alertar os usuários sobre as tarefas do processo muitas vezes é fundamental mas algumas vezes precisamos de algo mais, de um complemento como a data e o horário que as mensagens foram emitidas para que fique documentado.
Sendo assim antes das mensagens nós gostaríamos de colocar a data e o horário que a mensagem foi exibida.
A função abaixo formata a data e horário num string trocando o / do dia/mes/ano por _, o : do horario por _ e o espaço por _.
Sendo assim a data ficaria como um string no formato : DD_MM_AAAA_HH_MM_SS
Public Function fncDataHorario() As String
Dim a As String
a = CStr(Now) '20/03/2023 13:33:02
a = Replace(a, "/", "_")
a = Replace(a, ":", "_")
a = Replace(a, " ", "_")
Return (a) '20_03_2023_13_34_08
End Function
Public Sub msg(mens As String)
Dim a As String
a = fncDataHorario() + "_" + mens
frmPrincipal.LstBox1.Items.Add(a)
frmPrincipal.LstBox1.SelectedIndex = frmPrincipal.LstBox1.Items.Count - 1
frmPrincipal.LstBox1.Refresh()
Application.DoEvents()
End Sub
Arquivo existe
A função abaixo retorna true se o arquivo for encontrado na pasta fornecida.
Public Function ArquivoExiste(arq As String) As Boolean
Return (My.Computer.FileSystem.FileExists(arq))
End Function
Gravar log
Suponha que num listbox você tenha colocado um monte de mensagens que deseja salvar num arquivo texto de log da aplicação
Public Sub GravarLog(dthr As String)
Dim a As Integer
Dim b As String
Dim file As System.IO.StreamWriter
b = "C:\Pastax\NomeArqy"
b = Left(b, InStrRev(b, "\"))
b = b + "LOGx_" + dthr + ".txt"
msg("Salvando o LOG do processo : " + b)
file = My.Computer.FileSystem.OpenTextFileWriter(b, True)
For a = 0 To frmPrincipal.LstBox1.Items.Count - 1
frmPrincipal.LstBox1.SelectedIndex = a
file.WriteLine(frmPrincipal.LstBox1.Text)
Next
file.Close()
End Sub
Carregar Arquivo de Opções
''' <summary>''' Esta sub Carrega as opçoes do programa do arquivo opcoes.txt
''' </summary>
Public Function CarregarOpcoes() As List(Of String)
Dim ArquivoTexto As IO.StreamReader
Dim DadoArqTexto As String
Dim pasta As String
Dim b As New List(Of String)
'Environment.SystemDirectory
'Environment.CurrentDirectory
'pasta = Environment.GetFolderPath(Environment.SpecialFolder.System)
pasta = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData)
If Right(pasta, 1) <> "\" Then
pasta = pasta + ""
End If
If IO.File.Exists(pasta + "opcoes.Text") Then
b.Clear()
ArquivoTexto = New IO.StreamReader(pasta + "opcoes.Text")
'primeira linha : Pasta de Arquivos de Origem
DadoArqTexto = ArquivoTexto.ReadLine
b.Add(DadoArqTexto) 'PastaOrigem
'segunda linha : Pasta de Arquivos de Destino
DadoArqTexto = ArquivoTexto.ReadLine
b.Add(DadoArqTexto) 'PastaDestino
'terceira linha : Número de horas para repetir processo
DadoArqTexto = ArquivoTexto.ReadLine
b.Add(DadoArqTexto) 'NumHoras
'quarta linha : Incluir subpastas
DadoArqTexto = ArquivoTexto.ReadLine
If DadoArqTexto = "SIM" Then
b.Add("True") 'IncluirSubPastas
Else
b.Add("False") 'IncluirSubPastas
End If
ArquivoTexto.Close()
Return b
Else
Return Nothing
End If
End Function
Salvar o Arquivo de Opções
''' <summary>''' Esta rotina salva as opções do usuário sobre o programa no arquivo opcoes.txt
''' </summary>
Public Sub SalvarOpcoes(a As List(Of String))
Dim ArquivoTexto As IO.StreamWriter
Dim pasta As String
pasta = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData)
If Right(pasta, 1) <> "\" Then
pasta = pasta + ""
End If
ArquivoTexto = New IO.StreamWriter(pasta + "opcoes")
'primeira linha : Pasta de Arquivos de Origem
ArquivoTexto.WriteLine(a(0))
'segunda linha : Pasta de Arquivos de Destino
ArquivoTexto.WriteLine(a(1))
'terceira linha : Número de horas para repetir processo
ArquivoTexto.WriteLine(a(2))
'quarta linha : Pasta de Arquivos de Destino
If a(3) = "True" Then
ArquivoTexto.WriteLine("SIM")
Else
ArquivoTexto.WriteLine("NAO")
End If
ArquivoTexto.Close()
End Sub
End Module
Função que limpa separadores de campos
Public Function limpa(ByVal dado As Object) As String
Dim dia, mes, ano As Integer
Dim data As DateTime
Dim saida As String
If IsDBNull(dado) Then
Return "'NULL'"
End If
If IsDate(dado) Then
data = CDate(dado)
dia = data.Day
mes = data.Month
ano = data.Year
If dia < 10 Then
saida = "0" + CStr(dia)
Else
saida = CStr(dia)
End If
saida = saida + "/"
If mes < 10 Then
saida = saida + "0" + CStr(mes)
Else
saida = saida + CStr(mes)
End If
saida = saida + "/" + CStr(ano)
Return saida
End If
If IsNumeric(dado) Then
saida = Trim(CStr(dado))
saida = Replace(saida, ",", ".")
Return saida
End If
saida = Trim(dado)
saida = Replace(saida, "'", "´")
Return saida
End Function
Função que valida um CNPJ
Public Function E_CNPJ(ByVal ID As String) As Boolean' validando se CGC ou CNPJ
'o campo deve vir com 14 caracteres numéricos completados com zeros a esquerda
'a validação é feita com o formato xxx.xxx.xxx-xx
Dim a As Integer
Dim j As Integer
Dim d1 As Integer
Dim i As Integer
Dim d2 As Integer
Dim b As String
E_CNPJ = True
If ID = "" Then
E_CNPJ = False
Exit Function
End If
b = Limpa_CPF_CNPJ(ID)
While (Left(b, 1) = "0") And (Len(b) > 8)
b = Mid$(b, 2, 2000)
End While
If (Len(b) > 8) And (Len(b) < 14) Then
While Len(b) < 14
b = "0" + b
End While
End If
If Len(b) = 8 And Val(b) > 0 Then
a = 0
j = 0
d1 = 0
For i = 1 To 7
a = Val(Mid(b, 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(b, 9, 1)) Then
E_CNPJ = True
Else
E_CNPJ = False
End If
Else
If Len(b) = 14 And Val(b) > 0 Then
a = 0
i = 0
d1 = 0
d2 = 0
j = 5
For i = 1 To 12 Step 1
a = a + (Val(Mid(b, 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(b, 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(b, 13, 1)) And d2 = Val(Mid(b, 14, 1))) Then
E_CNPJ = True
Else
E_CNPJ = False
End If
Else
E_CNPJ = False
End If
End If
Return E_CNPJ
End Function
Função valida um CPF
Public Function E_CPF(ByVal ID As String) As Boolean' valida se cpf
Dim soma As Integer
Dim Resto As Integer
Dim i As Integer
Dim b As String
E_CPF = True
If ID = "" Then
E_CPF = False
Exit Function
End If
If Len(ID) < 5 Then
E_CPF = False
Exit Function
End If
b = Limpa_CPF_CNPJ(ID)
If Not IsNumeric(b) Then
E_CPF = False
Exit Function
End If
While (Strings.Left(b, 1) = "0") And (Len(b) > 11)
b = Mid$(b, 2, 2000)
End While
While Len(b) < 11
b = "0" + b
End While
'Valida argumento
If Len(b) <> 11 Then
E_CPF = False
Exit Function
End If
soma = 0
For i = 1 To 9
soma = soma + Val(Mid$(b, 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$(b, 10, 1)) Then
E_CPF = False
Exit Function
End If
soma = 0
For i = 1 To 10
soma = soma + Val(Mid$(b, 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$(b, 11, 1)) Then
E_CPF = False
Exit Function
End If
Return E_CPF
End Function
Função que valida um CEI
Public Function E_CEI(cei As String) As Boolean'CEI = Código Específico do INSS
'O CEI são 11 digitos mais 1 digito verificador
Try
Dim numcei As String
Dim Pesos = New Integer() {7, 4, 1, 8, 5, 2, 1, 6, 3, 7, 4}
Dim soma As Integer = 0
Dim SOMA_CEI(11) As Integer
Dim dv As String = ""
Dim Total As Integer = 0
Dim CEI1(11) As Integer
Dim i As Integer
Dim j As Integer
'retirando os zeros não significativos a esquerda
numcei = cei
While (Left(numcei, 1) = "0") And (Len(numcei) > 12)
numcei = Mid(numcei, 2, 100)
End While
If (numcei.Length < 12) Then
Return False
End If
'Convertendo os caracteres do CEI para inteiro e criando um array
For i = 0 To Len(numcei) - 2
CEI1(i) = CInt(Mid(numcei, i + 1, 1))
SOMA_CEI(i) = CEI1(i) * Pesos(i)
Next
soma = 0
For j = 0 To 10
soma = soma + SOMA_CEI(j)
Next
j = Int(soma / 10)
j = soma Mod 10 + j
j = (Math.Abs(10 - j) Mod 10)
dv = CStr(j)
If (numcei.Substring(11, 1) = dv) Then
Return True
Else
Return False
End If
Catch ex As Exception
MsgBox("Ocorreu um Erro : " + Err.Description, vbCritical, "Function E_CEI")
Return False
End Try
End Function
Função que retira acentuação de caracteres portugueses
Public Function RetiraAcentuacao(ByVal dado As String) As StringDim a As String
a = dado
'substutuição de acentuação - minúsculas
a = Replace(a, "á", "a")
a = Replace(a, "à", "a")
a = Replace(a, "ã", "a")
a = Replace(a, "â", "a")
a = Replace(a, "ä", "a")
a = Replace(a, "é", "e")
a = Replace(a, "è", "e")
a = Replace(a, "ê", "e")
a = Replace(a, "ë", "e")
a = Replace(a, "í", "i")
a = Replace(a, "ì", "i")
a = Replace(a, "î", "i")
a = Replace(a, "ï", "i")
a = Replace(a, "ó", "o")
a = Replace(a, "ò", "o")
a = Replace(a, "õ", "o")
a = Replace(a, "ô", "o")
a = Replace(a, "ö", "o")
a = Replace(a, "ú", "u")
a = Replace(a, "ù", "u")
a = Replace(a, "û", "u")
a = Replace(a, "ü", "u")
a = Replace(a, "ç", "c")
'substutuição de acentuação - maiúsculas
a = Replace(a, "Á", "A")
a = Replace(a, "À", "A")
a = Replace(a, "Ã", "A")
a = Replace(a, "Â", "A")
a = Replace(a, "Ä", "A")
a = Replace(a, "É", "E")
a = Replace(a, "È", "E")
a = Replace(a, "Ê", "E")
a = Replace(a, "Ë", "E")
a = Replace(a, "Í", "I")
a = Replace(a, "Ì", "I")
a = Replace(a, "Î", "I")
a = Replace(a, "Ï", "I")
a = Replace(a, "Ó", "O")
a = Replace(a, "Ò", "O")
a = Replace(a, "Õ", "O")
a = Replace(a, "Ô", "O")
a = Replace(a, "Ö", "O")
a = Replace(a, "Ú", "U")
a = Replace(a, "Ù", "U")
a = Replace(a, "Û", "U")
a = Replace(a, "Ü", "U")
a = Replace(a, "Ç", "C")
Return a
End Function
End Module