|
Exibindo Informações do Sistema |
Se você tem uma tela "Sobre" o seu sistema e deseja torná-la mais próxima àquelas do Windows/Office.
|
Se você tem uma tela "Sobre" o seu sistema e deseja torná-la mais próxima àquelas do Windows/Office, crie o form mostrando as suas informações e crie um botão "Sistema Operacional" e chame, a partir dele, "StartSysInfo" (sem as haspas, claro). Option Compare Database Option Explicit ' Opções de segurança da chave do Registry... Const KEY_ALL_ACCESS = &H2003F ' Tipos de chave ROOT... Const HKEY_LOCAL_MACHINE = &H80000002 Const ERROR_SUCCESS = 0 Const REG_SZ = 1 ' Unicode nul terminated string Const REG_DWORD = 4 ' 32-bit number Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location" Const gREGVALSYSINFOLOC = "MSINFO" Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO" Const gREGVALSYSINFO = "PATH" Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _ ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, _ ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long Public Sub StartSysInfo() On Error GoTo SysInfoErr Dim rc As Long Dim SysInfoPath As String ' Tenta obter o Caminho\Nome do programa System Info do Registry... If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then ' Tenta obter apenas o caminho do programa System Info do Registry... ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then ' Valida a existência de versão 32 bit do programa If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then SysInfoPath = SysInfoPath & "\MSINFO32.EXE" ' Erro - Arquivo não encontrado... Else GoTo SysInfoErr End If ' Erro - Entrada no Registry não encontrada... Else GoTo SysInfoErr End If Call Shell(SysInfoPath, vbNormalFocus) Exit Sub SysInfoErr: MsgBox "Informações do sistema não disponível", vbOKOnly End Sub Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean Dim i As Long ' Contador Dim rc As Long ' Código de retorno Dim hKey As Long ' Handle para uma chave aberta do registry Dim hDepth As Long ' Dim KeyValType As Long ' Tipo de dados de uma chave do registry Dim tmpVal As String ' Armazenagem temporária para um valor de chave do Registry Dim KeyValSize As Long ' Tamanho da variável da chave do registry '------------------------------------------------------------ ' Abre RegKey sob KeyRoot {HKEY_LOCAL_MACHINE...} '------------------------------------------------------------ rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Abre a chave do Registry If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Erro de Handle... tmpVal = String$(1024, 0) ' Aloca espaço variável KeyValSize = 1024 ' Marca o tamanho da variável '------------------------------------------------------------ ' Recupera o valor de chave do registry... '------------------------------------------------------------ rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Erros de Handle tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1) '------------------------------------------------------------ ' Determina o tipo de valor de chave para conversão '------------------------------------------------------------ Select Case KeyValType ' Procura o tipo de dados... Case REG_SZ ' Tipo de dados da chave do Registry KeyVal = tmpVal ' Copia o valor da string Case REG_DWORD ' Tipo de dados de chave Double Word For i = Len(tmpVal) To 1 Step -1 ' Converte cada Bit KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Monta o valor caracter a caracter Next KeyVal = Format$("&h" + KeyVal) ' Converte a palavra dupla para string End Select GetKeyValue = True ' Return Success rc = RegCloseKey(hKey) ' Fecha a chave do Registry Exit Function ' Exit GetKeyError: ' Limpeza após a ocorrencia de erro KeyVal = "" ' Deixa o valor de retorno como string vazia GetKeyValue = False ' Devolve a falha rc = RegCloseKey(hKey) ' Fecha a chave do registry End Function insira esta brincadeira toda em um módulo padrão e chame StartSysInfo a partir de um botão. Funciona no Access 97/2K/2K3.
|