Projeto Bom-Bril , mil e uma utilidades

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:

Inicie um novo projeto no VB e insira um módulo
A seguir crie um menu como indicado nas imagens acima
Insira também uma etiqueta ( label1 ) onde você irá informar o link : http://www.geocities.com/macoratti
Insira uma imagem qualquer como exibida ( se quiser...)

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