Projeto Bom Bril... 


Vamos mostrar a seguir os menus de um pequeno projeto feito em Visual Basic... Observe...

Ao clicar no link http://www.geocities.com/macoratti o sistema irá verificar se existe uma conexão Internet ativa e em caso positivo irá chamar o endereço da página.

Opções do Menu Utilitários Opções do Menu Serviços Opções do Menu Sair

Você deve estar imaginando que para fazer todo o serviço a que se propõe este projeto deverá ser necessário linhas e linhas de código.  Na verdade , pela versatilidade do VB ,  muitas das opções exibidas são executadas com apenas uma linha de código. 

Para criar o projeto siga as etapas:

Vejamos então o código que esta por trás das cortinas...:

1-) Código das Opções do Menu Arquivo:

-Novo - Abre o formulário Novo e mostra como Salvar texto em um arquivo txt.

frmnovo.Show  Exibe o formulário abaixo

On Error GoTo Erro

Dim FileName As String

CommonDialog1.filter = "Text Files (*.txt) |*.txt| All Files (*.*) |*.*|"
CommonDialog1.Action = 2

FileName = CommonDialog1.FileName
F = FreeFile
Open FileName For Output As #F
Print #F, "Salvando o texto..." & vbNewLine & Text1.Text
Close #F

frmmain.save = True
Exit Sub

Erro:
MsgBox "ocorreu um erro ", vbCritical

Código do botão Salvar do formulário Novo  

-Abrir - Usando uma controle CommonDialog exibe a janela padrão para Abrir um arquivo.

Dim filter As String
CommonDialog1.CancelError = True

On Error GoTo Erro

filter = "Todos os Arqs. (*.txt) | *.txt"
CommonDialog1.filter = filter
CommonDialog1.DefaultExt = "*.txt"

CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.ShowOpen

Exit Sub

Erro:
MsgBox " Ocorreu um erro durante a carga do arquivo !", vbCritical

-Salvar - Usando o controle CommonDialog exibe a janela padrão para salvar um arquivo

CommonDialog1.CancelError = True
On Error GoTo Erro
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.ShowSave

Erro:
MsgBox "Ocorreu um erro ! ", vbCritical

- Imprimir - Usando o controle CommonDialog , exibe a janela padrão para Imprimir.

Dim BeginPage, EndPage, NumCopies, i
CommonDialog1.CancelError = True
On Error GoTo Erro
CommonDialog1.ShowPrinter
BeginPage = CommonDialog1.FromPage
EndPage = CommonDialog1.ToPage
NumCopies = CommonDialog1.Copies
For i = 1 To NumCopies
   Me.PrintForm
   ' ponha o codigo para imprimir aqui
Next i
Exit Sub
Erro:
MsgBox "A impressora não esta pronta !", vbCritical

2-) Vejamos agora as opções do Menu Utilitários :

- Explorer - Abre a janela do Explorer

retval = Shell("c:\windows\explorer.exe", 3)   'EXECUTA Maximizado

- Paint - Abre o aplicativo Paint

retval = Shell("c:\windows\pbrush.exe", 3)

- Bloco de Notas - Abre o bloco de Notas

retval = Shell("c:\windows\notepad.exe", 3)

- Word Pad - Abre o aplicativo Word Pad

retval = Shell("c:\windows\write.exe", 3)

- Calculadora - Abre uma calculadora cujo código é exibido a seguir

Calculadora.Show vbModal
' --------------------------------------------------------------
' Copyright (C) 1994 Microsoft Corporation
'
Option Explicit
Dim op1, op2 ' Previously input operand.
Dim DecimalFlag As Integer ' Decimal point present yet?
Dim NumOps As Integer ' Number of operands.
Dim LastInput ' Indicate type of last keypress event.
Dim OpFlag ' Indicate pending operation.
Dim TempReadout

Private Sub Cancel_Click()
   Readout = Format(0, "0.")
   op1 = 0
   op2 = 0
   Form_Load
End Sub


Private Sub CancelEntry_Click()
  Readout = Format(0, "0.")
  DecimalFlag = False
  LastInput = "CE"
End Sub


Private Sub Decimal_Click()
  If LastInput = "NEG" Then
     Readout = Format(0, "-0.")
  ElseIf LastInput <> "NUMS" Then
     Readout = Format(0, "0.")
  End If
  DecimalFlag = True
  LastInput = "NUMS"
End Sub


Private Sub Form_Load()
  DecimalFlag = False
  NumOps = 0
  LastInput = "NONE"
  OpFlag = " "
  Readout = Format(0, "0.")
  'Decimal.Caption = Format(0, ".")
End Sub


Private Sub Number_Click(Index As Integer)
  If LastInput <> "NUMS" Then
     Readout = Format(0, ".")
     DecimalFlag = False
  End If
  If DecimalFlag Then
     Readout = Readout + Number(Index).Caption
  Else
     Readout = Left(Readout, InStr(Readout, Format(0, ".")) - 1) + Number(Index).Caption + Format(0, ".")
  End If
  If LastInput = "NEG" Then Readout = "-" & Readout
     LastInput = "NUMS"
End Sub


Private Sub Operator_Click(Index As Integer)
  TempReadout = Readout
  If LastInput = "NUMS" Then
     NumOps = NumOps + 1
  End If
  Select Case NumOps
  Case 0
     If Operator(Index).Caption = "-" And LastInput <> "NEG" Then
         Readout = "-" & Readout
         LastInput = "NEG"
     End If
  Case 1
     op1 = Readout
     If Operator(Index).Caption = "-" And LastInput <> "NUMS" And OpFlag <> "=" Then
        Readout = "-"
        LastInput = "NEG"
     End If
  Case 2
     op2 = TempReadout
     Select Case OpFlag
   Case "+"
      op1 = CDbl(op1) + CDbl(op2)
   Case "-"
     op1 = CDbl(op1) - CDbl(op2)
   Case "X"
     op1 = CDbl(op1) * CDbl(op2)
   Case "/"
     If op2 = 0 Then
        MsgBox "Não existe divisão por zero", 48, "Calculadora"
     Else
        op1 = CDbl(op1) / CDbl(op2)
     End If
  Case "="
     op1 = CDbl(op2)
  Case "%"
     op1 = CDbl(op1) * CDbl(op2)
 End Select
  Readout = op1
  NumOps = 1
End Select
If LastInput <> "NEG" Then
   LastInput = "OPS"
  OpFlag = Operator(Index).Caption
End If
End Sub


Private Sub Percent_Click()
  Readout = Readout / 100
  LastInput = "Ops"
  OpFlag = "%"
  NumOps = NumOps + 1
  DecimalFlag = True
End Sub

3-) Agora o código das opções do Menu Serviços

As opções do Menu são definidas e identificadas pelos nomes mnu_1 até mnu_10. 

Private Sub mnu1_Click()                   ' chama o painel de controle
Call Shell("rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus)
End Sub
Private Sub mnu2_Click()                   ' chama o painel adicionar/remover programas
Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl", vbNormalFocus)
End Sub
Private Sub mnu3_Click()                   ' chama o painel de propriedades da internet
Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl", vbNormalFocus)
End Sub
Private Sub mnu4_Click()                   ' chama o janela de fontes
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @3", vbNormalFocus)
End Sub
Private Sub mnu5_Click()                   ' chama o painel do telcado
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", vbNormalFocus)
End Sub
Private Sub mnu6_Click()                   ' chama o painel do modem
Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", vbNormalFocus)
End Sub
Private Sub mnu7_Click()                   ' chama o painel de propriedade da data/hora
Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", vbNormalFocus)
End Sub
Private Sub mnu8_Click()                   ' chama o painel de multimidia
Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl", vbNormalFocus)
End Sub
Private Sub mnu9_Click()                   ' chama o painel de propriedades do sistema 
Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl", vbNormalFocus)
End Sub
Private Sub mnu10_Click()                 ' chama o assistente para adicionar um hardware
Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", vbNormalFocus)
End Sub

4-) Sair para o DOS  - exibe uma janela DOS

retval = Shell("c:\command.com", 3)   

Agora o código associado a evento click da label que exibe o link :http://www.geocities.com/macoratti

If ActiveConnection = True Then
   retval = Shell("Start.exe http://www.geocities.com/macoratti", vbHide)
Else
    MsgBox "Voce nao esta conectado meu amigo !!!"
End If

E, agora o código da função ActiveConnection que verifica se existe uma conexão ativa:

' verifica se ha uma conexao ativa
Public Function ActiveConnection() As Boolean
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
lpSubKey = "System\CurrentControlSet\Services\RemoteAccess"
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, phkResult)
If ReturnCode = ERROR_SUCCESS Then
  hKey = phkResult
  lpValueName = "Remote Connection"
  lpReserved = APINULL
  lpType = APINULL
  lpData = APINULL
  lpcbData = APINULL
  ReturnCode = RegQueryValueEx(hKey, lpValueName, _
  lpReserved, lpType, ByVal lpData, lpcbData)
  lpcbData = Len(lpData)
  ReturnCode = RegQueryValueEx(hKey, lpValueName, _
  lpReserved, lpType, lpData, lpcbData)
  If ReturnCode = ERROR_SUCCESS Then
     If lpData = 0 Then
        ActiveConnection = False
     Else
     ActiveConnection = True
  End If
End If
RegCloseKey (hKey)
End If
End Function

Para terminar de vez o código do módulo  com as declarações API :

'-----------api usada para verificar se a conexao esta ativa----
Public Const ERROR_SUCCESS = 0&
Public Const APINULL = 0&
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public ReturnCode As Long

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey _
As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long

Você duvida que todas as opções funcionam ?  então rode o projeto... e confira...

Só para relaxar...   


 José Carlos Macoratti