Para imprimir direto para a impressora, tarefa ideal no caso de emissão de notas fiscais, a impressora deverá ser inicializada através do comando Open e utilizar o Print para realizar a impressão: 

Open "Lpt1" For Output As #1

Desta forma, o programador para enviar os caracteres especias para imprimir condensado, saltar linhas, etc... veja os exemplos a seguir: 

Print #1, Chr(27) & "0" ' Muda o passo p/ 8 LPP
Print #1, Chr(15) ' Condensado
Print #1, "" ' Salta uma linha

O objeto Printer corresponde à impressora default, definida no sistema, porém a coleção Printers corresponde à todas as impressoras instaladas no sistema. Para selecionar uma impressora específica você deve usar a propriedade hDC do objeto Printer, conforme observamos a seguir: 

Private Sub cmdImprimir_Click()

Dim ImpressoraPadrão as Printer, Nova_Impressora as Printer

CommonDialog1.ShowPrinter
Set ImpressoraPadrão = Printer
For Each Nova_Impressora in Printers
If Nova_Impressora.hDC = CommonDialog1.hDC Then
Set Printer = Nova_Impressora
End If
Next

Printer.Print ""
' Define a impressora para o controle RichTextBox à ser impresso
rtbPrint.SelPrint Printer.hDC
Printer.EndDoc
Set Printer = ImpressoraPadrão

End Sub

O código acima recebe uma impressora selecionada no controle CommonDialog, define um objeto do tipo Printer com a impressora defualt do sistema, troca a impressora padrão pela impressora escolhida no CommonDilalog, imprime o texto escolhido e depois retorna a impressora padrão para a definição original.

A função FileCopy que permite a cópia de um arquivo. Segue abaixo o exemplo da instrução:

FileCopy "C:\Caminho1\ArqOrigem.ext", "C:\Caminho2\ArqDestino.ext"

Para tal procedimento, utilize a seguinte rotina

Private Sub Verifica_FormsAbertos()
Dim i As Form
For Each i In Forms
MsgBox "O formulário '" & i.Name & "' esta aberto"
Next i
End Sub

Crie uma automação OLE com o Excel, conforme mostra o código a seguir:

Dim Excel As Object
Set Excel = CreateObject("Excel.Application.8")
With Excel
.Workbooks.Open filename:="C:\caminho\arquivo.xls"
.Visible = True
.Sheets("Plan1").Select
.Range("A1").Select
MsgBox .activecell.Value
.activecell.Value = 20
End With

Acima, executamos os seguintes passos:

1. Selecionamos a planilha Plan1 e a célula A1;
2. Através de um MsgBox, mostramos o valor na tela da célula selecionada;
3. Em seguida, com a propriedade Value da célula,  alteramos o conteúdo da célula ativa (no caso Plan1, A1).

Isso deverá ser realizado através do evento KeyPress: 

Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Útil para quem deseja adicionar em uma base de dados, informações com apenas letras maiúsculas. 

Coloque o seguinte código em um módulo:

Sub Caixa_Alta(oForm As Form)
Screen.MousePointer = vbHourglass
Dim A As Integer
For A = 1 To oForm.Controls.Count - 1
If TypeOf oForm.Controls(A) Is TextBox Then
oForm.Controls(A).Text = UCase(oForm.Controls(A).Text)
ElseIf TypeOf oForm.Controls(A) Is ComboBox Then
oForm.Controls(A).Text = UCase(oForm.Controls(A).Text)
End If
Next A
Screen.MousePointer = vbArrow
End Sub

Para chamá-lo, digite:

Caixa_Alta frmInsert

Onde frmInsert é o nome do form onde você quer converter para maiúsculas.

Declara o seguinte em um Módulo:

Public Declare Function GetCurrentProcessId Lib _"kernel32" () As Long
Public Declare Function GetCurrentProcess Lib _"kernel32" () As Long
Public Declare Function RegisterServiceProcess _Lib "kernel32" (ByVal dwProcessID As Long, _ByVal dwType As Long) As Long
Public Const RSP_SIMPLE_SERVICE As Long = 1
Public Const RSP_UNREGISTER_SERVICE As Long = 0

Crie a seguinte Sub:

Public Sub MakeMeService()
Dim pid As Long
Dim reserv As Long
pid = GetCurrentProcessId()
reserv = RegisterServiceProcess(pid,RSP_SIMPLE_SERVICE)
End Sub

Depois coloque o seguinte no FORM_LOAD:

Private Form_Load()
MakeMeService
End Sub

Crie essa função em Módulo BAS

Public Function CheckCPF(CPF As String) As Boolean
Dim EVAR1 As Integer
Dim evar2 As Integer
Dim F As Integer
If Len(Trim(CPF)) <> 11 Then
CheckCPF = False
Exit Function
End If

EVAR1 = 0
For F = 1 To 9
EVAR1 = EVAR1 + Val(Mid(CPF, F, 1)) * (11 - F)
Next F
evar2 = 11 - (EVAR1 - (Int(EVAR1 / 11) * 11))
If evar2 = 10 Or evar2 = 11 Then evar2 = 0
If evar2 <> Val(Mid(CPF, 10, 1)) Then
CheckCPF = False
Exit Function
End If

EVAR1 = 0
For F = 1 To 10
EVAR1 = EVAR1 + Val(Mid(CPF, F, 1)) * (12 - F)
Next F
evar2 = 11 - (EVAR1 - (Int(EVAR1 / 11) * 11))
If evar2 = 10 Or evar2 = 11 Then evar2 = 0
If evar2 <> Val(Mid(CPF, 11, 1)) Then
CheckCPF = False
Exit Function

End If

CheckCPF = True

Para chamá-la no form:

Sub CPF_LostFocus()
If CheckCPF(CPF.Text) = False Then
MsgBox "CPF Inválido."
CPF.SetFocus
End IF

Esta função checa a validade de um numero de cartão de credito, retornando true caso este seja válido

Function CheckCard(CCNumber As String) As Boolean
Dim Counter As Integer, TmpInt As Integer
Dim Answer As Integer
Counter = 1
TmpInt = 0
While Counter <= Len(CCNumber)
If IsEven(Len(CCNumber)) Then
TmpInt = Val(Mid$(CCNumber, Counter, 1))
If Not IsEven(Counter) Then
TmpInt = TmpInt * 2
If TmpInt > 9 Then TmpInt = TmpInt - 9
End If

Answer = Answer + TmpInt
'Debug.Print Counter, TmpInt, Answer
Counter = Counter + 1
Else
TmpInt = Val(Mid$(CCNumber, Counter, 1))
If IsEven(Counter) Then
TmpInt = TmpInt * 2
If TmpInt > 9 Then TmpInt = TmpInt - 9
End If

Answer = Answer + TmpInt
'Debug.Print Counter, TmpInt, Answer
Counter = Counter + 1
End If

Wend

Answer = Answer Mod 10
If Answer = 0 Then CheckCard = True
End Function

Como fazer a tecla ENTER agir como um TAB para mudar de campo Form Mude a propriedade KeyPreview do formulário para true. Coloque o código a seguir para o evento KeyDown do form: If KeyCode = vbKeyReturn then Sendkeys "{Tab}"

Veja como utilizar a declaração SetAttr do Visual Basic:

SetAttr Caminho_do_Arquivo , Atributos

O Caminho_do_Arquivo é a expessão que especifica o arquivo a ter o atributo modificado, juntamente com o seu caminho.

O parâmetro Atributos é uma constante, ou expressão numérica ( a soma dos valores de cada atributo ) que especifica o valor do novo atributo do arquivo.

A tabela a seguir mostra as contantes, já definidas no Visual Basic, que podem ser usadas nesta operação:

Veja como alterar o atributo do arquivo AUTOEXEC.BAT no diretório raiz do disco C para: Somente leitura, escondido e sistema:

SetAttr "C:\autoexec.bat", vbReadOnly + vbHidden + vbSystem

Esta função arredonda números para uma quantidade especificada de casas decimais.

Public Function ArredondaNumero(NumeroInformado As Variant,_CasasDecimais As Integer) As Variant

Dim Temp As Double, Decimais As Long
Temp = CDbl(NumeroInformado)
Decimais = 10 ^ CasasDecimais
ArredondaNumero = (Fix((Temp + 0.5 / Decimais) * _
Decimais)) / Decimais
End Function

Se você quiser converter o texto que está sendo digitado no TextBox para maísculas, basta criar uma função e faça chamada à mesma no evento KeyPress do TextBox, como mostrado abaixo, sendo a necessidade de conversão posterior:

Private Sub Texto_KeyPress(KeyAscii As Integer)
KeyAscii = Maiuscula(KeyAscii)
End Sub

Function Maiuscula(KeyAscii As Integer)
If KeyAscii > 96 And KeyAscii < 123 Then 
KeyAscii = KeyAscii - 32
End If
Maiuscula = KeyAscii
End Function

O código a seguir exibe a forma de manipular o Caption do form para que o mesmo tenha um efeito de Marquee. Coloque o código a seguir  em um form:

Private Const Dif = 2000 'corresponde ao ícone e ao ControlBox do form
Dim Encerrado As Boolean 'indica que o form foi fechado e pára o código

Private Sub Form_Activate()
Dim N#, Decrescente As Boolean
Dim Cnt%, Larg#, LargT#, Texto$, Lim%
N = Timer
Do While Not Encerrado
If Timer > N + 0.01 Then
N = Timer
Select Case Decrescente
Case False
Cnt = Cnt + 1
Texto = String(Cnt, " ") + "Mensagem do Marquee"
LargT = TextWidth(Texto)
Larg = ScaleWidth - 1110
If LargT >= Larg Then
Cnt = Cnt - 2
Decrescente = True
Texto = String(Cnt, " ") + "Mensagem do Marquee"
End If
Caption = Texto
Case Else
Cnt = Cnt - 1
If Cnt < 1 Then
Cnt = 1
Texto = "Mensagem do Marquee"
Decrescente = False
Else
Texto = String(Cnt, " ") + "Mensagem do Marquee"
End If
Caption = Texto
End Select
End If
DoEvents
Loop
End Sub

Private Sub Form_Unload(Cancel As Integer)
Encerrado = True
End Sub

Em comparações de expressões de ponto flutuante não podemos usar com precisão o operador = pelo fato de que as variáveis do tipo Single ou Double têm precisão finita. Para tal use o código a seguir:


Dim i As Integer, d as Double

For i = 1 to 10
d = d + CDbl(0.1)
Next

MsgBox (d=1) ' Mostrará "FALSE"

Para comparar mais facilmente dois números de ponto flutuante, use a nova função Round do
VB 6.0 que arredonda um número até as casas decimais desejadas. Podemos reescrever o teste
acima conforme segue:

MsgBox (Round(d,12) = 1) 'Mostrará "TRUE"

Você também pode usar este método para comparar se duas variáveis A e B contém valores
que são iguais até a décima segunda casa decimal:

If Round(A - B, 12) = 0 Then Print "Valores Igauis"

Para obter o número de série do HD, use o código que segue:


Dim ns As New Scripting.FileSystemObject
Dim numero As Scripting.Drive

' Get a reference to the Drive object
Set numero = ns.GetDrive("C")
Print Hex$(numero.SerialNumber)

O código a seguir, cria um caixa de entrada de text (input box) inteligente.

Toda vez que você digita alguma coisa numa caixa de texto, as primeiras letras do texto sendo
digitado, são comparadas com uma lista invisível de textos. O código "advinha" que texto
estaria sendo digitado de uma forma similar ao comportamento da nova versão do Internet Explorer.

Para usar esta técnica, adicione uma lista de texto (list box) no seu formulário e mude a propriedade Visible para False. Neste exemplo, usei uma lista fictícia de informações que é preenchida no evento Load do form. Numa aplicação real, você deve ir adicionando um novo elemento à lista de texto após o usuário completar a digitação na caixa de texto.

Escreva o código abaixo no formulário que contém a lista de textos e a caixa texto para digitação:

Option Explicit
Private Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib _
"User32" Alias "SendMessageA" (ByVal _
hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) _
As Long

Private Sub Form_Load()

List1.AddItem "Laranja"
List1.AddItem "Banana"
List1.AddItem "Maça"
List1.AddItem "Pera"

End Sub

Private Sub Text1_Change()

Dim pos As Long
List1.ListIndex = SendMessage( _
List1.hWnd, LB_FINDSTRING, -1, ByVal _
CStr(Text1.Text))

If List1.ListIndex = -1 Then
pos = Text1.SelStart
Else
pos = Text1.SelStart
Text1.Text = List1
Text1.SelStart = pos
Text1.SelLength = Len(Text1.Text) - pos
End If

End Sub



Private Sub Text1_KeyDown(KeyCode As _
Integer, Shift As Integer)

On Error Resume Next

If KeyCode = 8 Then 'Backspace

If Text1.SelLength <> 0 Then
Text1.Text = Mid$(Text1, 1, _
Text1.SelStart - 1)
KeyCode = 0
End If

ElseIf KeyCode = 46 Then 'Del

If Text1.SelLength <> 0 And Text1.SelStart <> 0 Then
Text1.Text = ""
KeyCode = 0
End If

End If

End Sub

Função para retornar o último dia da semana:

Function ÚltimoDiaDaSemana(D As Variant, Optional FirstWeekday As Integer) As Variant 
If IsMissing(FirstWeekday) Then  
ÚltimoDiaDaSemana = D - WeekDay(D) + 7 
Else 
ÚltimoDiaDaSemana = D - WeekDay(D, FirstWeekday) + 7 
End If 
End Function 

Function ÚltimoDiaDoMês(D As Variant) As Variant 
ÚltimoDiaDoMês = DateSerial(Year(D), Mês(D) + 1, 0) 
End Function 

Function DiasNoMês(D As Variant) As Variant 
If VarType(D) <> 7 Then 
DiasNoMês = Null 
Else 
Select Case Mês(D) 
Case 2 
If PuloAno(Ano(D)) Then 
DiasNoMês = 29 
Else 
DiasNoMês = 28 
End If 
Case 4, 6, 9, 11 
DiasNoMês = 30 
Case 1, 3, 5, 7, 8, 10, 12 
DiasNoMês = 31 
End Select 
End If 
End Function 

Function PrimeiroDiaDaSemana(D As Variant, Optional FirstWeekday As Integer) As Variant 
If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week. 
PrimeiroDiaDaSemana = D - WeekDay(D) + 1 
Else 
PrimeiroDiaDaSemana = D - WeekDay(D, FirstWeekday) + 1 
End If 
End Function 

Private Sub Dir1_Change()
'Informa que os arquivos que irão aparecer no FileListBox serão os do diretório selecionado
'no DirListBox
File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
'O tratamento abaixo, é para o caso de não existir disco na unidade selecionada
On Error GoTo ErrorDRV
'Caso não tenha ocorrido erros, ordena que os diretórios que irão aparecer no
'DriveListBox devem ser o da unidade selecionada
Dir1.Path = Drive1.Drive
Exit Sub
'Trata o erro citado acima
ErrorDRV:
MsgBox "Não há disco nesta unidade !", vbCritical
End Sub

Private Sub Command1_Click()
On Error GoTo AlgoErrado

If Me("Label1").Name <> vbNullString Then
MsgBox "Positivo"
End If
Exit Sub
AlgoErrado:
MsgBox "Negativo"
End Sub

Crie no formulário que você deseja abrir e executar o botão uma Public Sub e chame evento click do botão de comando. Segue abaixo um exemplo onde vou executar o evento click do botão Command1 do Form2. Segue abaixo o exemplo:

----Form2-----

Public Sub ExecutaBotao()
Call Command1_Click
End Sub

Private Sub Command1_Click()
Msgbox "Teste"
End Sub

----Form1-----

'Abra e execute o botão utilizando o seguinte código

Form2.Show
Form2.ExecutaBotao

Private Sub Form_MouseMove(Button As Integer,
Label1.ForeColor = &H80000012
End Sub

Private Sub Label1_MouseMove(Button As Integer,
Label1.ForeColor = &HFF&
End Sub

If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If