Dicas e Tutoriais - VB(5.0/6.0)

[DyogoJAA 0]

Esta será uma área onde os usuários de Visual Basic poderam postar as dicas e tutoriais , para ajudar os usuários iniciantes.

[DyogoJAA 0]

String´s de Conexão para Banco de Dados :

 

 

SQL SERVER

 

"Provider=SQLOLEDB.1;Persist Security Info=False;User ID=" & sUsuarioBd & ";Password=" & sSenhaBd & ";Initial Catalog=" & sBancoDados & ";Data Source=" & sServidorBd

PostgreSQL

"DRIVER={PostgreSQL};DATABASE=" & sBancoDados & ";SERVER=" & sServidorBd & ";PORT=5432;UID=" & sUsuarioBd & ";PWD=" & sSenhaBd & ";ReadOnly=0;"

[DyogoJAA 0]

Esse Código Criptografa/Descriptografa qualquer string passada na função .

 

Public Function Cript(St As String) As StringDim X As String, i As Integer, N As Integer, _P As Integer, j As Integer, n0 As Integer, Pw As String	  'dimensiona	   P = 0   Pw = "123456"   For i = 1 To Len(St$)							'para cada caracter	  P = P + 1									 'incrementa ponteiro	  If P > Len(Pw) Then P = 1					 'testa e reseta, se for o caso	  j = Asc(Mid$(Pw, P, 1)) Or 128				'pega char da senha evitando acima de 128	  N = Asc(Mid$(St$, i))						 'pega char da string a encriptarDeNovo:	  N = N Xor j								   'encripta...	  If N < 31 Then								'se char de controle		 N = (128 + N)							  'somar 128 e		 GoTo DeNovo								'ecripta novamente	  ElseIf N > 127 And N < 159 Then			   'se nesta faixa pode ser char de controle		 N = N - 128								'tira 128 e		 GoTo DeNovo								'encripta novamente	  End If	  X$ = X$ + Chr$(N)							 'concatena string encriptada   Next											 'próximo caracter a encriptar   Cript$ = X$									  'retorna a nova stringEnd Function

[Fabyo 66]

Conexao com o banco MSYQL e executando a query

 

link do mysql: http://dev.mysql.com/downloads/

 

Referencie o ADO 2.8

Dim cn As ADODB.Connection

Set cn = New ADODB.Connection

cn.Open "DRIVER={MySQL ODBC 3.51 Driver};SERVER=localhost;DATABASE=banco;USER=root;PASSWORD=;OPTION=3;"

[DyogoJAA 0]

Pega último dia do mês :

 

Public Function PegaUltDataMes(dtBaseMes As Date) As DateDim dtUltimoDia As StringOn Error GoTo PegaUltDataMes_Erro   dtUltimoDia = "31" & "/" & Month(dtBaseMes) & "/" & Year(dtBaseMes)   If IsDate(dtUltimoDia) = True Then      PegaUltDataMes = "31" & "/" & Month(dtBaseMes) & "/" & Year(dtBaseMes)   Else       dtUltimoDia = "30" & "/" & Month(dtBaseMes) & "/" & Year(dtBaseMes)       If IsDate(dtUltimoDia) = True Then           PegaUltDataMes = "30" & "/" & Month(dtBaseMes) & "/" & Year(dtBaseMes)       Else           dtUltimoDia = "29" & "/" & Month(dtBaseMes) & "/" & Year(dtBaseMes)           If IsDate(dtUltimoDia) = True Then               PegaUltDataMes = "29" & "/" & Month(dtBaseMes) & "/" & Year(dtBaseMes)           Else               PegaUltDataMes = "28" & "/" & Month(dtBaseMes) & "/" & Year(dtBaseMes)           End If       End If   End IfEnd Function

[EDITADO]

By Fabyo

Pegar o Ultimo dia do mes:

 

Format(DateSerial(Year(Now), Month(Now) + 1, 0), "dd/mm/yyyy")

[DyogoJAA 0]

Validação de CNPJ

 

Public Function ValidaCGC(CGC As String) As Boolean  Dim retorno, a, j, i, d1, d2  TiraMascara CGC    CGC = TiraMascaraCnpjCpf    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		ValidaCGC = True	 Else		ValidaCGC = False		MsgBox "CNPJ inválido!,Verifique", vbCritical, "Valida CGC"	 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		   ValidaCGC = True		Else		   ValidaCGC = False		   MsgBox "CNPJ inválido!, Verifique", vbCritical, "Aviso do Sistema"		End If	 Else		ValidaCGC = False		MsgBox "CNPJ inválido!,Verifique", vbCritical, "Aviso do Sistema"	 End If  End IfEnd Function

[DyogoJAA 0]

Validação de CPF

 

Public Function ValidaCPF(CPF As String) As BooleanDim soma As DoubleDim Resto As DoubleDim i As Double    TiraMascara CPF    CPF = TiraMascaraCnpjCpf    'Valida argumento  If Len(CPF) <> 11 Then	 ValidaCPF = False	 MsgBox "CPF inválido!,Verifique", vbCritical	 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		MsgBox "CPF inválido!,Verifique", vbCritical		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		MsgBox "CPF inválido!,Verifique", vbCritical		ValidaCPF = False		Exit Function	End If		ValidaCPF = True	End FunctionFunction PegaNumero(ByVal strTabela As String, ByVal ProximoNumero As Boolean, ByRef CodigoID As Double, Optional ByRef CodigoNaoInterno As String)Dim rslocal As ADODB.RecordsetDim strSQL As String  If CodigoNaoInterno = "" Then	 'StrSQL = "SELECT MAX(cint(CodigoId)) as MaxOrdem FROM " & strTabela	 strSQL = "SELECT MAX(CodigoId) as MaxOrdem FROM " & strTabela  Else	 'StrSQL = "SELECT MAX(cint(" & CodigoNaoInterno & ")) as MaxOrdem FROM " & strTabela	 strSQL = "SELECT MAX(" & CodigoNaoInterno & ") as MaxOrdem FROM " & strTabela  End If	     If Consulta(strSQL, strConexao, rslocal) Then	 If Not rslocal.EOF Then		If Trim(rslocal!MaxOrdem & "") = "" Then		   CodigoID = Val(Format(1, "000000"))		Else		   If ProximoNumero = True Then			  CodigoID = Val(Format((rslocal!MaxOrdem), "000000")) + 1		   ElseIf ProximoNumero = False Then			  CodigoID = Val(Format((rslocal!MaxOrdem), "000000"))		   End If		End If	 End If	 rslocal.Close	 Set rslocal = Nothing  End IfEnd Function

[DyogoJAA 0]

Operações com Arquivos

 

'Gravando um Arquivo de TextoDim nArquivo As IntegernArquivo = FreeFile'Abre o ArquivoOpen "C:\Temp.txt" For Output As #nArquivo      'Grava a Linha no Arquivo Expecificado          Write #nArquivo, Linha_A_ser_Gravada'Fecha o ArquivoClose #strArquivo'Recuperando Informações em um Arquivo TextoDim nArquivo As IntegerDim sTexto as string      nArquivo = FreeFile   Open "C:\Temp.txt" For Input As #nArquivo         'Lê o Arquivo Texto e joga para a variavel sTexto o Conteudo da Linha  'Aqui ele só lê uma linha  Line Input #nArquivo, sTexto 'Nome do Banco de Dados   Close #nArquivo   ou    Open "C:\Temp.txt" For Input As #nArquivo	Do Until EOF(nArquivo) = True           'Semelhante ao primeiro com a diferença de ele percorer o arquivo inteiro              'E não ler Somemente a Linha Acima	           Line Input #nArquivo, sTexto 'Nome do Banco de Dados	Loop   Close #nArquivo       'Apagando o ArquivoKill "C:\Temp.txt"'Copiando o ArquivoFileCopy Path_Origen,Path_Destino'Tamanho do ArquivoFileLen Path'Data e Hora da Gravação do ArquivoFileDateTime Path

[luiz humberto 0]

Função que verifica se a data está correta, verifando até se o ano é Bissexto.

 

Public Function VerificaData(Maskara As MaskEdBox)  Dim Data      As String Dim Dia       As String Dim Mes       As String Dim Ano       As String Dim Fevereiro As Integer  Data = Maskara.FormattedText Dia = Mid(Data, 1, 2) Mes = Mid(Data, 4, 2) Ano = Mid(Data, 7, 4)'Verificando os meses que podem ter até o dia 31If (Mes = 1) Or (Mes = 3) Or (Mes = 5) Or (Mes = 7) Or (Mes = 8) Or (Mes = 10) Or (Mes = 12) Then    If (Dia < 1) Or (Dia > 31) Then       MsgBox ("DIA INVÁLIDO"), vbCritical, "Verifica Data"       Maskara.SetFocus       Exit Function    End IfEnd If 'Verificando o mes de fevereiroIf (Mes = 2) Then   If (Dia > 30) Then       MsgBox ("O MÊS DE FEVEREIO VAI ATE DIA 29"), vbCritical, "Verifica Data"       Maskara.SetFocus       Exit Function   End If     Fevereiro = Ano Mod 4  If (Fevereiro <> 0) And (Dia = 29) Then      MsgBox ("DIA INVÁLIDO O MES É FEVEREIRO O ANO NÃO É BISSEXTO"), vbCritical, "Verifica Data"      Maskara.SetFocus      Exit Function  End IfEnd If'Verificar os meses que não podem ter dia até 31 e sim até 30If (Mes = 2) Or (Mes = 4) Or (Mes = 6) Or (Mes = 9) Or (Mes = 11) Then   If (Dia < 1) Or (Dia > 30) Then      MsgBox ("DIA INVÁLIDO O MES É SO ATÉ O DIA 30"), vbCritical, "Verifica Data"      Maskara.SetFocus      Exit Function   End IfEnd If'Verificar os meses 1 A 12If (Mes < 1) Or (Mes > 12) Then  MsgBox ("MÊS INVÁLIDO"), vbCritical, "Verifica Data"  Maskara.SetFocus  Exit FunctionEnd IfMsgBox ("DATA CORRETA"), vbExclamation, "Verifica Data"End Function

Para chamar a função faça da seguinte forma:

Call VerificaData(Data)

[luiz humberto 0]

Abrir um combo, sem precisar clicar nele, no evento GotoFocus coloque este código.

 

SENDKEYS "{F4}"

[luiz humberto 0]

Outro tipos de condições.

 

Se o conteúdo da variável Idade for maior que 21, então a variável Idade recebe maior, se não recebe menor.

Idade= IIf(TesteIdade > 21, "Maior", "Menor")

Se o conteúdo da variável Cor for Branca então a variável Teste recebe Aceita, agora caso seja Preto irá receber NãoAceita, este tem um diferencial do IIF, pois o mesmo só aceita uma condição, já no Switch não tem limitações.

Teste= Switch(Cor= "Branca", "Aceita", Cor="Preto", "NaoAceita")

[cassitos 2]

--- Programa utilizando o estilo do Windows XP ---

Incluir em um módulo do projeto o código:

'deixar o sistema com estilo XP

Public Type tagInitCommonControlsEx

lngSize As Long

lngICC As Long

End Type

Public Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean

Public Const ICC_USEREX_CLASSES = &H200

 

Public Sub Main()

' we need to call InitCommonControls before we

' can use XP visual styles. Here I'm using

' InitCommonControlsEx, which is the extended

' version provided in v4.72 upwards (you need

' v6.00 or higher to get XP styles)

On Error Resume Next

' this will fail if Comctl not available

' - unlikely now though!

Dim iccex As tagInitCommonControlsEx

With iccex

.lngSize = LenB(iccex)

.lngICC = ICC_USEREX_CLASSES

End With

InitCommonControlsEx iccex

 

' now start the application

On Error GoTo 0

NomeDoFormInicial.Show 'aqui você digita o nome do formulário inicial do seu projeto

End Sub

Agora abra as propriedades do projeto e defina "Startup Objetct" para "Sub Main".

Inicialmente estas são as alterações a serem feitas, daí você deve por um arquivo Mainfest

no mesmo diretório do executável gerado, não lembro de onde copiei então por enquanto podem

baixar o arquivo aqui. Está zipado, então descompacte-o e renomeie para o mesmo nome do seu programa, ex:

Cadastro.exe.mainfest.

Lembrando que só funciona caso o windows XP esteja com algum estilo definido.

 

ps: acho q já teve um post com essa dica. :P

 

flws

[Fabyo 66]

Site com o codigo fonte de uma dll para conectar o vb com o MySQL

e um projeto de exemplo, muito bom

 

http://www.icarz.com/mysql/

[Fabyo 66]

Uma dica muito boa, quem ja nao deve ter xingado o vb por nao funcionar o scrool do mouse nele?, entao seus problemas acabaram, descobri uma dll que faz o scrool funcionar

 

é só baixar:

 

http://support.microsoft.com/?id=837910

 

a explicação toda esta no site mesmo

 

espero que gostem pois eu gostei :)

[Anderson Roberto 0]

Não sei se alguém já indicou, mas um site que é muito bom sobre Visual Basic em português é o http://www.macoratti.net.

[scorpio 7]

Site que contém diversas API's com exemplos e explicações.(em ingles, mas é simples e fácil de acha o que precisa)

http://allapi.mentalis.org/index2.shtml

 

Flw Vlw

[evilwata 0]

Alterar a propriedade de vários objetos ao mesmo tempo

 

Imagine que você tenha uns 30 TextBoxes no form, e queira limpar a propriedade de todos, para isto existe uma maneira simples, bastando dentro do próprio módulo de código (do form), digitar o seguinte código:

 

Private Sub LimparTexts()

  Dim ctlLimpaTextos As Control
  For Each ctlLimpaTextos In Controls
	If TypeOF ctlLimpaTextos Is TextBox Then
	  ctlLimpaTextos.Text = ""
	End If
  Next

End Sub

Depois de feito isto é só fazer chamada a esta Sub-Rotina dentro de algum outro bloco de códigos, por exemplo:

 

Private Sub Form_Load()

  LimparTexts

End Sub

OBS: ctlLimpaTextos é um nome que você pode alterar para qualquer um que você queira, e para cada propriedade em comum que você queira mudar, basta acrescentá-la no código...

Espero que gostem da dica... fui!!!

[afalves 0]

Alterar a propriedade de vários objetos ao mesmo tempo

 

Imagine que você tenha uns 30 TextBoxes no form, e queira limpar a propriedade de todos, para isto existe uma maneira simples, bastando dentro do próprio módulo de código (do form), digitar o seguinte código:

 

Private Sub LimparTexts()
 
   Dim ctlLimpaTextos As Control
   For Each ctlLimpaTextos In Controls
	 If TypeOF ctlLimpaTextos Is TextBox Then
	   ctlLimpaTextos.Text = ""
	 End If
   Next
 
 End Sub

Depois de feito isto é só fazer chamada a esta Sub-Rotina dentro de algum outro bloco de códigos, por exemplo:

 

Private Sub Form_Load()
 
   LimparTexts
 
 End Sub

OBS: ctlLimpaTextos é um nome que você pode alterar para qualquer um que você queira, e para cada propriedade em comum que você queira mudar, basta acrescentá-la no código...

Espero que gostem da dica... fui!!!

Para limpar COMBOXBOX, acrescente à função:

 

If TypeOf ctlLimpaTextos Is ComboBox Then
			ctlLimpaTextos.ListIndex = -1
		End If

[gabrieldb 5]

Curso de VB 6.0 muito bom.

 

http://www.josevalter.com.br/visual_basic/index1.htm

 

Site contendo diversas stings de conexão com BD e alguns tutoriais.

 

http://stringdeconexao.com/

[GabrielFerrari 41]

Conexão simples com banco de dados:

 

Dim c As New ADODB.Connection
Dim r As New ADODB.Recordset
Dim SQL As String

Private Sub Command1_Click()
c.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source = Caminho do seu Banco.MDB"
c.Open
If Text1.Text <> "" Then
    SQL = "SELECT * FROM bvs WHERE campo = '" & Text1 & "';"
End If

r.Open SQL, c
    If Not r.EOF Then
        Text1.Text = r![campo] & ""
    End If

Referencia a Microsoft ActiveX Data Objects 2.8 Library

Eu usei o 2.8 mas funciona do 2.6 pra frente se nao me engano