'Função para abrir outro mdb via ADO

Dim db As Database
Dim rs As Recordset

Set db = DBEngine.Workspaces(0).OpenDatabase(Application.CurrentProject.path & "\mdb_externo.mdb")
Set rs = db.OpenRecordset("nome_da_tabela", dbOpenTable)

MsgBox rs!nome_da_coluna

Set rs = Nothing
Set db = Nothing

'Função para pegar número do HD
Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
'Função para pegar a máquina da rede
Public Declare Function GetMachineName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

'Função para pegar o Login da máquina
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function Justifica(lpzText, ControlText As Control, objReport As Report) As String
'Simula o alinhamento justificado de texto em campos em relatórios do Access
'Versão 1.0
'Autor: Larissa Redeker

On Error GoTo Err_Justifica

Dim Carac As String, Newtext As String
Dim Numspaces As Integer, WidthSpace As Integer
Dim WidthControl As Integer
Dim I As Integer, Inicio As Integer
Dim LastPos As Integer, PosSpace As Integer, PoscharBreak As Integer
Dim FinalText As String, SpacesInStr As Integer
Dim SizeText As Integer
Dim POSI As Variant, CI As Integer
Dim NextCarac As String
Dim n As Integer

'As próximas 4 linhas definem as propriedades de fontes do relatório com as
'definições da caixa de texto que irá receber o texto justificado, pois as
'dimensões do texto para cálculos são feitas através da propriedade TextWidth
'do relatório

objReport.FontName = ControlText.FontName
objReport.FontSize = ControlText.FontSize
objReport.FontBold = ControlText.FontBold
objReport.FontItalic = ControlText.FontItalic
'Obtém o tamanho da caixa de texto que irá receber o texto alinhado
WidthControl = ControlText.Width
'Obtém o tamanho de espaço na fonte atual
WidthSpace = objReport.TextWidth(" ")
'obtém o tamanho do texto a ser justificado
SizeText = Len(lpzText)

I = 1
Inicio = 1

Do While I <> WidthControl
'Se a nova seqüência for maior que o controle que irá receber o texto,
'refaz a nova seqüência para caber na caixa de texto
Newtext = Mid(lpzText, Inicio, LastPos - Inicio)
'obtém o número de espaços necessários, que deverão ser inseridos na nova
'seqüência de texto
Numspaces = Fix((WidthControl - objReport.TextWidth(Newtext)) / WidthSpace) - 1
For n = 1 To Len(Newtext)
'Calcula o número de espaços existentes na nova seqüência de texto
Carac = Mid(Newtext, n, 1)
If Carac = " " Then SpacesInStr = SpacesInStr + 1
Next n

POSI = 1
CI = 1
PoscharBreak = 0

Do While CI = ""
NextCarac = Mid(Newtext, POSI + 1, 1)
If NextCarac = " " Then
Newtext = Mid(Newtext, 1, POSI) + String(1, " ") + Mid(Newtext, POSI + 1)
POSI = POSI + 1
CI = CI + 1
End If
PoscharBreak = PoscharBreak + 1
If PoscharBreak = SpacesInStr Then
PoscharBreak = 0
POSI = 0
End If

POSI = POSI + 1
Loop

FinalText = FinalText + Newtext + Chr(13) + Chr(10)
Newtext = ""
I = LastPos
LastPos = 0
Inicio = I + 1

LastPos = I

I = I + 1
Loop
Justifica = FinalText & Newtext

Exit_Justifica:
Exit Function

Err_Justifica:
Resume Exit_Justifica

End Function

Function AlterarPropriedade(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer

Dim dbs As Database, prp As Property
Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo Change_Err
dbs.Properties(strPropName) = varPropValue
AlterarPropriedade = True

Change_Bye:
Exit Function

Change_Err:
If Err = conPropNotFoundError Then ' Propriedade não localizada.

Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)
dbs.Properties.Append prp
Resume Next
Else
' Erro desconhecido.
AlterarPropriedade = False
Resume Change_Bye
End If

End Function

Public Function DesativarShift()
AlterarPropriedade "AllowBypassKey", dbBoolean, False

End Function

Public Function AtivarShift()
AlterarPropriedade "AllowBypassKey", dbBoolean, True

End Function