Office Systems Developer : VBA Code

Sample Function to Translate a Access Database IDE (ADODB)

Joao Livio — Wed, 29 Oct 2008 19:11:41 GMT

Just an idea to support multilanguage IDE in a Access Database, what i do? i create a Table with the FORM NAME, CONTROL NAME and LANGUAGE, i am selectin the Language and comparing the Control Name with the Table Description, if you want you can ByVal the strLanguage = “pt-PT”, here it is my Function

Option Compare Database
 

Public Function yTranslaction(ByVal strFORM As String, _
                                               ByVal frmFORM As Form)

    Dim cnn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim strSQL As String
    Dim ctlCONTROL As Control

    On Error GoTo erro

    strLanguage = “pt-PT”

    strSQL = “SELECT * FROM y_TRANSLACTIONS ” & _
                   “WHERE LANGUAGE =’” & strLanguage & “‘” & ” AND FORM=’” & strFORM & “‘”
    cnn.ConnectionString = CurrentProject.Connection
    cnn.Open
    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic

    Set frmFORM = Forms(strFORM)

    With rs
        Debug.Print .RecordCount
        Do Until rs.EOF = True
            For Each ctlCONTROL In frmFORM.Controls
            If TypeOf ctlCONTROL Is Label Then
                If ctlCONTROL.Name = rs.Fields(”CONTROL”).Value Then
                    ctlCONTROL.Caption = rs.Fields(”CAPTION”).Value
                End If
            End If
            If TypeOf ctlCONTROL Is CommandButton Then
                If ctlCONTROL.Name = rs.Fields(”CONTROL”).Value Then
                    ctlCONTROL.Caption = rs.Fields(”CAPTION”).Value
                End If
            End If
        Next
        .MoveNext
        Loop
    End With

    cnn.Close
    Set rs = Nothing
    Exit Function

erro:

    MsgBox Err.Number & ” - ” & Err.Description, vbOKOnly + vbExclamation, "Erro na Rotina”
End Function

MDB Deleted Tables Recover

Joao Livio — Fri, 24 Oct 2008 08:08:00 GMT

MDBTableRecover (Version 1.0.0.2)

Feedback is welcome for erros and new features

I only support MDB (Office 11) Files in this Version, working and improving Utility

System Requirements

Windows 2000 SP4/XP (32/64 Bits)

Windows Vista (32/64 Bits)

Download

Download Utility (32/64 Bits): Here

This Utility is provided “AS-IS”. Was created by Joao Livio Microsoft MVP Office, i don’t work At or For Microsoft, please see http://mvp.support.microsoft.com/. Use it at your own Risk

VBA and Office 14, just to clarify

Joao Livio — Sat, 19 Jan 2008 22:42:00 GMT

According with Kevin Boske, Microsoft VSTA Program Manager, "there's been some discussion on this thread on Slashdot, (updated) which started from this article in The Register UK. To be clear, Microsoft is not replacing VBA with VSTA or VSTO in Office for Windows. (though VSTA and VSTO are still important developer tools for Office 14), VBA is here to stay, as was announced some time back by Steven Sinofsky. The Excel and Access Blogs both have posts covering this from the Office perspective."

TrackBack From:

http://blogs.msdn.com/kevinboske/archive/2008/01/18/vba-and-office-14.aspx

Recover tables deleted from a database in Access

Joao Livio — Wed, 12 Dec 2007 10:03:00 GMT

How to recover tables deleted from a database in Access 2000, Access 2002, or Access 2003

Applies only to a Microsoft Access database (.mdb).

The following sample function will try to recover all deleted tables in an Access database. To create the sample function, follow these steps.

Note These steps assume that you are creating the sample function for...

http://support.microsoft.com/kb/209874/en-us

Portuguese Functions for Access 2007 - Funções em Português para o Access 2007

Joao Livio — Sat, 07 Jul 2007 01:47:00 GMT

Funções Office 2007 VBA

Por razões de motor de busca de páginas e pela importância desta informação em Português resolvi incluir esta secção no site para ser mais fácil o acesso à sua monitorização.

Porque o autor deste Artigo não sou eu a página vai abrir como Same Frame (Mesma Página). Se resolver voltar atrás, basta clicar na seta voltar no seu Browser. Pode sempre utilizar o link original em baixo.

Alguns exemplos que irão encontrar para cada função estão em Inglês, basta apenas substituir a função em Inglês pela citada em Português, isto para quem tem o Office em Português obviamente.

Legal

Autor: Microsoft (MSFT)

Fonte: http://office.microsoft.com/pt-pt/access/HA101316762070.aspx

Training Kits Microsoft Powered in portuguese - PT Portugal Formacao Office Microsoft Powered

Joao Livio — Sun, 24 Sep 2006 15:56:00 GMT

Ajude a aumentar a segurança: Segurança no Office

Consultas II: Limitar os dados e calcular valores

Relatórios I: Apresentação dos dados

Apresentação dos controlos

Consultas I: obter respostas com consultas

Trabalhar com uma base de dados que não criou

Introdução às bases de dados

Criar um documento do Office acessível

Trabalhar com o teclado no Office

Consultas III: Criar consultas parametrizadas que solicitam a intervenção

Organizar os dados em tabelas

Os formulários são seleccionados consoante a função

Personalizar as barras de ferramentas e menus

Ajude a aumentar a segurança: Segurança no Office

Proteger documentos do Word

Criar um documento do Office acessível

Utilizar desenhos do Visio em apresentações, documentos e publicações

Preparar as férias: Escrever e enviar um boletim com o Word

Adicionar gráficos e mantê-los no local pretendido

Índice I: Criar um índice básico

Criar um destaque de documento

Utilizar impressão em série para mensagens de correio em massa e muito mais

Então é esse o segredo! Grandes funcionalidades do Word

Cabeçalhos e rodapés, simples de elaborar

Personalizar atalhos de teclado no Word

Decorar documentos com fundos, limites e efeitos de texto

Introdução ao XML no Word

Criar notas de rodapé e de fim

Formatar o documento com estilos

Apresentar o projecto no Word, PowerPoint ou Visio

Personalizar as barras de ferramentas e menus

Organizar o ClipArt e outros conteúdos multimédia

Descobrir uma calculadora mais eficiente

Então é esse o segredo! Grandes funcionalidades do Excel

Gráficos I: Como criar gráficos

Criar um documento do Office acessível

Gráficos II: Escolher o tipo de gráfico adequado

Então é esse o segredo! Trabalhar com folhas de cálculo realmente grandes

Trabalhar com o teclado no Office

Gráficos III: Criar gráficos com um aspecto profissional

Listas I: Como utilizar listas no Excel 2003

XML: De que se trata?

Listas II: Publicar listas do Excel 2003 num site do SharePoint

Utilizar fórmulas para editar, corrigir e verificar texto

Tabela Dinâmica I: O que têm os relatórios de Tabela Dinâmica de tão especial?

Tabela Dinâmica II: Entrar em acção com relatórios de Tabela Dinâmica

Criar assinaturas apelativas para as mensagens de correio electrónico

Partilhar um calendário utilizando o Outlook e o Windows SharePoint Services

Ver e partilhar vários calendários

Organizar o ClipArt e outros conteúdos multimédia

Conhecer o Visio

Formas I: Princípios básicos introdutórios sem os quais não consegue viver

O melhor modo de ligar formas em desenhos do Visio

Introdução rápida aos traçados de escritório

Uma rápida introdução a diagramas de blocos

Uma rápida introdução a organogramas

Imprimir desenhos grandes e obter os resultados pretendidos

Criar um documento do Office acessível

Utilizar desenhos do Visio em apresentações, documentos e publicações

Apresentar o projecto no Word, PowerPoint ou Visio

Personalizar as barras de ferramentas e menus

Dialog Box in Microsoft Access (Find File)

Joao Livio — Sun, 20 Nov 2005 17:32:00 GMT

'(c) 2002 João Tito Lívio
'This code can only be use as a part of an Application and could not be sell

'To REQUEST a full functional sample please > Click

1. Insert a DialogBox ActiveX in your Form.

In Design View go INSERT - ActiveX CONTROL

2. Rename the control to "cdlg"

3. Paste the Code to a CLICK event of a Commad Button

CODE

    Dim strCaminho As String
    With Me.cdlg
            'Initial Directory
            .InitDir = "C:\"
            'Dialog Title
            .DialogTitle = "Localizar Arquivo"
            'Filter File Types
            .Filter = "Arquivos(*.txt)|*.txt|All Files (*.*)|*.*"
            .ShowOpen
            'Return File and Path to a Variable
            strCaminho = .FileName
    End With
    MsgBox "Path: " & strCaminho

SAMPLE

How to automate with Office Assistance?

Joao Livio — Mon, 18 Apr 2005 05:31:00 GMT

'(c) 2002 João Tito Lívio
'This code can only be use as a part of an Application and could not be sell

'This method can not be USER FRENDLY, use with caution

'To REQUEST a full functional sample please > Click

modAssistancePropreties

Option Compare Database

' This class saves the Assistant's property settings when
' the class is initialized and restores those properties
' when the class is destroyed.
'
' PUBLIC PROPERTIES (all properties are read-only):
' AssistWithAlerts
' AssistWithHelp
' AssistWithWizards
' FeatureTips
' FileName
' GuessHelp
' HighPriorityTips
' KeyboardShortcutTips
' MouseTips
' MoveWhenInTheWay
' On
' SearchWhenProgramming
' Sounds
' TipOfDay
' Visible
'
' NOTE The Assistant's Reduced property can be set and changed but will have
'       no visible effect on the character.
'
' SAMPLE USAGE (from a standard module):
' Function DoSomethingWithAsst()
'   Dim objAsst As clsAssistantProperties
'
'   Set objAsst = New clsAssistantProperties
'   With Application.Assistant
'       ' Insert code here to change Assistant property settings.
'   End With
'   Set objAsst = Nothing
' End Function
'
' EXAMPLE:
' You can see an example that uses this class to save and restore
' Assistant properties in the TestSaveAssistProperties procedure in
' the modAssistantProperties module.

Option Explicit
' Private class properties used to save initial Assistant
' property settings.
Private p_blnAssistWithAlerts      As Boolean
Private p_blnAssistWithHelp        As Boolean
Private p_blnAssistWithWizards     As Boolean
Private p_blnFeatureTips           As Boolean
Private p_strFileName              As String
Private p_blnGuessHelp             As Boolean
Private p_blnHighPriorityTips      As Boolean
Private p_blnKeyboardShortcutTips As Boolean
Private p_blnMouseTips             As Boolean
Private p_blnMoveWhenInTheWay      As Boolean
Private p_blnAssistantOn           As Boolean
Private p_blnSearchWhenProgramming As Boolean
Private p_blnSounds                As Boolean
Private p_blnTipOfDay              As Boolean
Private p_blnVisible               As Boolean

Property Get AssistWithAlerts() As Boolean
AssistWithAlerts = p_blnAssistWithAlerts
End Property

Property Get AssistWithHelp() As Boolean
AssistWithHelp = p_blnAssistWithHelp
End Property

Property Get AssistWithWizards() As Boolean
AssistWithWizards = p_blnAssistWithWizards
End Property

Property Get FeatureTips() As Boolean
FeatureTips = p_blnFeatureTips
End Property

Property Get FileName() As String
FileName = p_strFileName
End Property

Property Get GuessHelp() As Boolean
GuessHelp = p_blnGuessHelp
End Property

Property Get HighPriorityTips() As Boolean
HighPriorityTips = p_blnHighPriorityTips
End Property

Property Get KeyboardShortcutTips() As Boolean
KeyboardShortcutTips = p_blnKeyboardShortcutTips
End Property

Property Get MouseTips() As Boolean
MouseTips = p_blnMouseTips
End Property

Property Get MoveWhenInTheWay() As Boolean
MoveWhenInTheWay = p_blnMoveWhenInTheWay
End Property

Property Get AssistantOn() As Boolean
AssistantOn = p_blnAssistantOn
End Property

Property Get SearchWhenProgramming() As Boolean
SearchWhenProgramming = p_blnSearchWhenProgramming
End Property

Property Get Sounds() As Boolean
Sounds = p_blnSounds
End Property

Property Get TipOfDay() As Boolean
TipOfDay = p_blnTipOfDay
End Property

Property Get Visible() As Boolean
Visible = p_blnVisible
End Property

Private Sub Class_Initialize()
    ' Save the Assistant properties in effect
    ' when this class was created.
    With Application.Assistant
        p_blnAssistWithAlerts = .AssistWithAlerts
        p_blnAssistWithHelp = .AssistWithHelp
        p_blnAssistWithWizards = .AssistWithWizards
        p_blnFeatureTips = .FeatureTips
        p_strFileName = .FileName
        p_blnGuessHelp = .GuessHelp
        p_blnHighPriorityTips = .HighPriorityTips
        p_blnKeyboardShortcutTips = .KeyboardShortcutTips
        p_blnMouseTips = .MouseTips
        p_blnMoveWhenInTheWay = .MoveWhenInTheWay
        p_blnAssistantOn = .On
        p_blnSearchWhenProgramming = .SearchWhenProgramming
        p_blnSounds = .Sounds
        p_blnTipOfDay = .TipOfDay
        p_blnVisible = .Visible
    End With
End Sub

Private Sub Class_Terminate()
    ' Restore the Assistant properties to
    ' those that were set when this class
    ' was initialized.
    With Application.Assistant
        .AssistWithAlerts = p_blnAssistWithAlerts
        .AssistWithHelp = p_blnAssistWithHelp
        .AssistWithWizards = p_blnAssistWithWizards
        .FeatureTips = p_blnFeatureTips
        .FileName = p_strFileName
        .GuessHelp = p_blnGuessHelp
        .HighPriorityTips = p_blnHighPriorityTips
        .KeyboardShortcutTips = p_blnKeyboardShortcutTips
        .MouseTips = p_blnMouseTips
        .MoveWhenInTheWay = p_blnMoveWhenInTheWay
        .On = p_blnAssistantOn
        .SearchWhenProgramming = p_blnSearchWhenProgramming
        .Sounds = p_blnSounds
        .TipOfDay = p_blnTipOfDay
        .Visible = p_blnVisible
    End With
End Sub

TimerClass

Option Explicit

Private Declare Function GetTickCount& Lib "kernel32" ()
Private p_blnTimerDone      As Boolean
Private p_lngElapsedTime    As Long
Private p_lngStartTime      As Long

Property Get TimerDone() As Boolean
TimerDone = p_blnTimerDone
End Property

Property Get ElapsedTime() As Long
ElapsedTime = p_lngElapsedTime
End Property

Public Sub StartTimer(lngInterval As Long)
    Dim lngEndTime As Long

    p_blnTimerDone = False
    p_lngStartTime = GetTickCount()
    lngEndTime = p_lngStartTime + lngInterval
    Do While GetTickCount() < lngEndTime
        DoEvents
    Loop
    p_blnTimerDone = True
    p_lngElapsedTime = p_lngStartTime + GetTickCount()
End Sub

Private Sub Class_Initialize()
p_blnTimerDone = False
p_lngElapsedTime = 0
End Sub

modAssistantTour

Option Compare Database
Option Explicit

Sub ShowAssistant()
' This procedure will show the Assistant.

    With Application.Assistant
        If Not .On Then
            .On = True
        ElseIf Not .Visible Then
            .Visible = True
        End If
    End With
End Sub

Sub BalloonLabelControls()
    ' This procedure illustrates how to work
    ' with Balloon object properties and methods
    ' and how to use label controls. The procedure
    ' also shows how to use the return value of the
    ' show method to determine the value selected
    ' by the user.
    Dim balBalloon As Balloon
    Dim intRetVal   As Integer
    Dim strChoice   As String

    Set balBalloon = Assistant.NewBalloon
    Assistant.Visible = True
    With balBalloon
        .Button = msoButtonSetNone
        .Heading = "Balloon Object Example One"
        .Labels(1).Text = "VBA is a powerful programming language."
        .Labels(2).Text = "Office is a great development environment."
        .Labels(3).Text = "The Assistant is cool!"
        .Labels(4).Text = "Balloon objects are easy to use."
        .Text = "Select one of the following " _
            & .Labels.Count & " options:"
        ' Show the balloon.
        intRetVal = .Show

        ' Save the selection made by the user.
        If intRetVal > 0 Then
            strChoice = "{cf 4}" & .Labels(intRetVal).Text & "{cf 0}"
        Else
            strChoice = ""
        End If
    End With

    Set balBalloon = Assistant.NewBalloon
    With balBalloon
        .Text = "You selected option " & CStr(intRetVal) & ": '" _
            & strChoice & "'"
        .Show
    End With

End Sub

Sub BalloonCheckboxControls()
    ' This procedure illustrates how to work
    ' with Balloon object properties and methods
    ' and how to use checkbox controls. The procedure
    ' also shows how to use the return value of the
    ' show method to determine the value selected
    ' by the user.
    Dim balBalloon As Balloon
    Dim intRetVal   As Integer
    Dim strChoice   As String
    Dim chkBox      As BalloonCheckbox

    Set balBalloon = Assistant.NewBalloon
    Assistant.Visible = True
    With balBalloon
        .Button = msoButtonSetOK
        .Heading = "Balloon Object Example Two"
        .Text = "How many of the following " _
            & .Checkboxes.Count & " statements do you agree with?"
        .Checkboxes(1).Text = "VBA is a powerful programming language."
        .Checkboxes(2).Text = "Office is a great development environment."
        .Checkboxes(3).Text = "The Assistant is cool!"
        .Checkboxes(4).Text = "Balloon objects are easy to use."
        ' Save the selection made by the user.
        intRetVal = .Show
        ' Construct the string to display to the user based on the
        ' user's selections.
        For Each chkBox In .Checkboxes
            If chkBox.Checked = True Then
                strChoice = strChoice & "{cf 4}" & chkBox.Text & "{cf 0}" & "' and '"
            End If
        Next chkBox
        ' Remove the trailing "' and '" from strChoice.
        If Len(strChoice) <> 0 Then
            strChoice = Left(strChoice, Len(strChoice) - 7)
        End If
    End With

    ' Create new Balloon object and display the user's choices.
    Set balBalloon = Assistant.NewBalloon
    With balBalloon
        If intRetVal > 0 Or Len(strChoice) > 0 Then
            .Text = "You selected '" & strChoice & "'."
        Else
            .Text = "You didn't make a selection."
        End If
        .Show
    End With
End Sub

Form Code

Option Compare Database

Option Explicit

' Create a global object variable used to store the original
' Office Assistant's properties when the form opens.
Public gclsAsstProps As clsAssistantProperties

' Location of Assistant files.
Const ASSISTANT_PATH As String = "c:\program files\microsoft office\office\"

Private Sub cboAnimations_AfterUpdate()
    If Assistant.Visible = False Then
        Call ShowAssistant
    End If
    Assistant.Animation = Me!cboAnimations.Value
End Sub

Private Sub cboCharacter_AfterUpdate()
    With Assistant
        If InStr(.FileName, cboCharacter.Value) = 0 Then
            .Animation = msoAnimationDisappear
            ' Call the Wait procedure to give the
            ' animation 1 second to finish.
            Wait
            .FileName = ASSISTANT_PATH & Me.cboCharacter.Value
        End If
    End With
    UpdateCaption Me!lblFileName
    ShowAssistant
End Sub

Private Sub cmdShowBalloon_Click()
    ' This procedure is called from the Show Balloon
    ' button on the View Balloon tab of the Assistant form.
    Dim balBalloon      As Balloon
    Dim intRetVal       As Integer
    Dim intI            As Integer
    Dim strChoice       As String
    Dim blnAsstVisible As Boolean

    On Error GoTo ShowBalloon_Err

    ' Set Balloon object variable.
    Set balBalloon = Assistant.NewBalloon

    ' Make sure the Assistant is visible.
    If Assistant.Visible = False Then
        Call ShowAssistant
    End If

    ' Determine the button style selected by the user.
    Select Case Me!ctlOptionStyle
        Case 1      ' Label button style.
            With balBalloon
                .Button = msoButtonSetNone
                .Heading = Me!txtBalloonHeading
                .Labels(1).Text = Me!txtOption1
                .Labels(2).Text = Me!txtOption2
                .Labels(3).Text = Me!txtOption3
                .Labels(4).Text = Me!txtOption4
                .Text = "Which of the following " _
                    & .Labels.Count & " choices apply to you?"
                ' Save the selection made by the user.
                intRetVal = .Show
                If intRetVal > 0 Then
                    strChoice = "{cf 4}" & .Labels(intRetVal).Text & "{cf 0}"
                Else
                    strChoice = ""
                End If
            End With
        Case 2      ' Check box button style.
            With balBalloon
                .Button = msoButtonSetOK
                .Heading = Me!txtBalloonHeading
                .Checkboxes(1).Text = Me!txtOption1
                .Checkboxes(2).Text = Me!txtOption2
                .Checkboxes(3).Text = Me!txtOption3
                .Checkboxes(4).Text = Me!txtOption4
                .Text = "Which of the following " _
                    & .Checkboxes.Count & " choices apply to you?"
                ' Save the selection made by the user.
                intRetVal = .Show
                ' Construct the string to display to the user based on the
                ' user's selections.
                For intI = 1 To .Checkboxes.Count
                    If .Checkboxes(intI).Checked = True Then
                        strChoice = strChoice & "{cf 4}" & .Checkboxes(intI).Text & "{cf 0}" & "' and '"
                    End If
                Next intI
                ' Remove the trailing "' and '" from strChoice.
                If Len(strChoice) <> 0 Then
                    strChoice = Left(strChoice, Len(strChoice) - 7)
                End If
            End With
    End Select

    ' Create new Balloon object and display the user's choices.
    Set balBalloon = Assistant.NewBalloon
        With balBalloon
            If intRetVal > 0 Or Len(strChoice) > 0 Then
                .Text = "You selected '" & strChoice & "'"
            Else
                .Text = "You didn't make a selection."
            End If
        .Show
        End With

ShowBalloon_End:
    Exit Sub
ShowBalloon_Err:
    MsgBox Err.Description
    Resume ShowBalloon_End
End Sub

Private Sub Form_Open(Cancel As Integer)
    ' This procedure locates Assistant files and
    ' fills a combo box with the names of the
    ' Assistant files on this system.
    Dim strCharacterFiles   As String
    Dim intCurrFile         As Integer
    Dim intDirPath          As Integer

    Set gclsAsstProps = New clsAssistantProperties

    ' Use FileSearch Object to load Assistant combo box.
    With Application.FileSearch
        .NewSearch
        .FileName = "*.acs"
        .LookIn = ASSISTANT_PATH
        intDirPath = Len(ASSISTANT_PATH)
        .SearchSubFolders = False
        If .Execute > 0 Then
            For intCurrFile = 1 To .FoundFiles.Count
                strCharacterFiles = strCharacterFiles & Mid$(.FoundFiles(intCurrFile), intDirPath + 1) & ";"
            Next intCurrFile
            strCharacterFiles = Left(strCharacterFiles, Len(strCharacterFiles) - 1)
        Else
            MsgBox "No Assistant files (*.acs) located in the '" & .LookIn & "' directory."
        End If
        With Me!cboCharacter
            .RowSource = strCharacterFiles
            .Value = Mid$(Assistant.FileName, intDirPath + 1)
        End With
        UpdateCaption Me!lblFileName
    End With

    ShowAssistant

    With Assistant
        .Left = 500
        .Top = 200
    End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' Restore the Assistant properties to those
    ' that were in effect when this form was
    ' loaded.
    Set gclsAsstProps = Nothing
End Sub
Sub UpdateCaption(ctl As Control)
    ' Update the label caption using the selected assistant name.
    ctl.Caption = "Animation for: '" & Assistant.Item & "'"
End Sub
Sub Wait(Optional lngDuration As Long = 1000)
    ' This procedure is called after an Assistant Animation
    ' property setting is specified and is designed to give the
    ' animation time to complete. The procedure waits the number
    ' of milliseconds sepecified in the lngDuration argument.
    ' The default is 1 second.
    Dim clsTimer As TimerClass

    Set clsTimer = New TimerClass

    With clsTimer
        .StartTimer lngDuration
        Do Until .TimerDone = True
            DoEvents
        Loop
    End With

    Set clsTimer = Nothing
End Sub

How to Spell Months by VBA Code and SQL?

Joao Livio — Sun, 17 Apr 2005 07:21:00 GMT

'(c) 2005 João Tito Lívio
'This code can only be use as a part of an Application and could not be sell

 'To REQUEST a full functional sample please > Click

VBA

MsgBox (Format(Now(), "mmmm"))
MsgBox ("Month: " & Format(Now(), "mmmm"))
MsgBox ("Month: " & Format(#1/1/2005#, "mmmm"))

SQL

SELECT Table1.Data, "This is month: " & Format([Data];"mmmm") AS strConvertion
FROM Table1;

How to Disable (F11 key) Shortcut to database Window?

Joao Livio — Sun, 17 Apr 2005 07:13:00 GMT

'(c) 2005 João Tito Lívio 
'This code can only be use as a part of an Application and could not be sell

'TIP: Use code in the Autoexec Macro

'USAGE: If DisableSpecialKeys = True then MsgBox"OK"

 'To REQUEST a full functional sample please > Click

Option Compare Database

Public Function DisableSpecialKeys() As Boolean
On Error GoTo Err_DisableSpecialKeys

Dim db As Database
Dim Prop As Property
Const conPropNotFound = 3270

Set db = CurrentDb()
db.Properties("AllowSpecialKeys") = False
Set db = Nothing

DisableSpecialKeys = True

Exit_DisableSpecialKeys:
    Exit Function

Err_DisableSpecialKeys:
    If Err = conPropNotFound Then
        'If the property doesn't exist, create it
        Set Prop = db.CreateProperty("AllowSpecialKeys", dbBoolean, True)
        db.Properties.Append Prop
        Resume Next
    Else
        MsgBox "Disable did not Work!!"
        DisableSpecialKeys = False
        Resume Exit_DisableSpecialKeys
    End If

End Function

How to Spell numbers to Euros using API?

Joao Livio — Sun, 17 Apr 2005 01:41:00 GMT

'(c) 2003 João Tito Lívio 
'This code can only be use as a part of an Application and could not be sell

 'To REQUEST a full functional sample please > Click

   This function originally was developed as the name indicates to convert numbers for extensive, 
even so it can be adapted for currency but with some limitations, or either, the used text for number 1.000.000.000, will have to be modified 
for ("A thousand million euros") And 1.000.000.000.000= ("1 million of millions Euros") Since we are in Europe and not in the United States.

Option Compare Database
 

Private Declare Function GetLocaleInfo& _
Lib "kernel32" Alias "GetLocaleInfoA" ( _
  ByVal Locale As Long, _
  ByVal LCType As Long, _
  ByVal lpLCData As String, _
  ByVal cchData As Long)


Private Const LOCALE_USER_DEFAULT& = &H400
Private Const LOCALE_SDECIMAL& = &HE
Private Const LOCALE_SCURRENCY& = &H14
Private Const LOCALE_SMONDECIMALSEP& = &H16

Public Enum enmFormat
  Maiusculas
  Minusculas
  PrimeiraMaiuscula
End Enum

Private arrGrupo() As String
'2 Dimensions
'1º -> [0]=Numeric value from group; [1]=extenso
'2ª -> Counter

Private Const e = "e "
Private Const Virgula = ", "

Private Const ZERO = "Zero "
Private Const um = "Um "
Private Const DOIS = "Dois "
Private Const TRES = "Três "
Private Const QUATRO = "Quatro "
Private Const CINCO = "Cinco "
Private Const SEIS = "Seis "
Private Const SETE = "Sete "
Private Const OITO = "Oito "
Private Const NOVE = "Nove "
Private Const DEZ = "Dez "

Private Const ONZE = "Onze "
Private Const DOZE = "Doze "
Private Const TREZE = "Treze "
Private Const CATORZE = "Catorze "
Private Const QUINZE = "Quinze "
Private Const DEZASSEIS = "Dezasseis "
Private Const DEZASSETE = "Dezassete "
Private Const DEZOITO = "Dezoito "
Private Const DEZANOVE = "Dezanove "

Private Const VINTE = "Vinte "
Private Const TRINTA = "Trinta "
Private Const QUARENTA = "Quarenta "
Private Const CINQUENTA = "Cinquenta "
Private Const SESSENTA = "Sessenta "
Private Const SETENTA = "Setenta "
Private Const OITENTA = "Oitenta "
Private Const NOVENTA = "Noventa "
Private Const CEM = "Cem "
Private Const CENTO = "Cento "
Private Const DUZENTOS = "Duzentos "
Private Const TREZENTOS = "Trezentos "
Private Const QUATROCENTOS = "Quatrocentos "
Private Const QUINHENTOS = "Quinhentos "
Private Const SEISCENTOS = "Seiscentos "
Private Const SETECENTOS = "Setecentos "
Private Const OITOCENTOS = "Oitocentos "
Private Const NOVECENTOS = "Novecentos "
Private Const MIL = "Mil "

Private Const MILHAO = "Milhão "
Private Const MILHOES = "Milhões "
Private Const BILIAO = "Bilião "
Private Const BILIOES = "Biliões "

Private strUnidades(9) As String
Private strTeens(99) As String
Private strDezenas(9) As String
Private strCentenas(9) As String
Private strMilhares(9) As String

Private mstrDecSep As String * 1
Private mstrDefaultErrorMsgOverflow As String
Private Const ERR_OVERF = "Overflow"

'Singular
Private mstrDefaultSufixoInteiro1 As String
Private Const SUF_INT1 = "Euro "
Private mstrDefaultSufixoDecimal1 As String
Private Const SUF_DEC1 = "Centimo "

'Plural
Private mstrDefaultSufixoInteiro2 As String
Private Const SUF_INT2 = "Euros "
Private mstrDefaultSufixoDecimal2 As String
Private Const SUF_DEC2 = "Centimos "

Private Const MAX_NUMBER As Double = 999999999999.99

Private Sub msEncher()

'strUnidades(0) = ZERO ' Must be an empty string
strUnidades(1) = um
strUnidades(2) = DOIS
strUnidades(3) = TRES
strUnidades(4) = QUATRO
strUnidades(5) = CINCO
strUnidades(6) = SEIS
strUnidades(7) = SETE
strUnidades(8) = OITO
strUnidades(9) = NOVE

'strTeens(0) = ZERO ' Must be an empty string
strTeens(1) = um
strTeens(2) = DOIS
strTeens(3) = TRES
strTeens(4) = QUATRO
strTeens(5) = CINCO
strTeens(6) = SEIS
strTeens(7) = SETE
strTeens(8) = OITO
strTeens(9) = NOVE
strTeens(10) = DEZ
strTeens(11) = ONZE
strTeens(12) = DOZE
strTeens(13) = TREZE
strTeens(14) = CATORZE
strTeens(15) = QUINZE
strTeens(16) = DEZASSEIS
strTeens(17) = DEZASSETE
strTeens(18) = DEZOITO
strTeens(19) = DEZANOVE

strDezenas(0) = ""
strDezenas(1) = "-"
strDezenas(2) = VINTE
strDezenas(3) = TRINTA
strDezenas(4) = QUARENTA
strDezenas(5) = CINQUENTA
strDezenas(6) = SESSENTA
strDezenas(7) = SETENTA
strDezenas(8) = OITENTA
strDezenas(9) = NOVENTA

strCentenas(0) = ""
strCentenas(1) = CEM
strCentenas(2) = DUZENTOS
strCentenas(3) = TREZENTOS
strCentenas(4) = QUATROCENTOS
strCentenas(5) = QUINHENTOS
strCentenas(6) = SEISCENTOS
strCentenas(7) = SETECENTOS
strCentenas(8) = OITOCENTOS
strCentenas(9) = NOVECENTOS


End Sub

Private Function mfTraduzir(xGrupo%, xstr$) As String
'Traslate 3 numbers group
'(right pad)
On Error GoTo erro
Dim blnAnteriorRedondo As Boolean   'quando grupo anterior = '*00'
Dim ret$, xlen%
xlen = Len(xstr$)
Dim Unid As Byte, strUnid$
Dim Teen As Byte, strTeen$
Dim Dezena As Byte, strDezn$
Dim Centena As Byte, strCent$

mstrDefaultSufixoInteiro1 = SUF_INT1
mstrDefaultSufixoDecimal1 = SUF_DEC1
mstrDefaultSufixoInteiro2 = SUF_INT2
mstrDefaultSufixoDecimal2 = SUF_DEC2


  Unid = CByte(Right(xstr$, 1))
  Teen = CByte(Right(xstr$, 2))
  Dezena = CByte(Mid(xstr$, xlen - 1, 1))
  Centena = CByte(Mid(xstr$, xlen - 2, 1))
If Centena Then
strCent = IIf(Teen = 0, strCentenas(Centena), _
  IIf(Centena = 1, CENTO, strCentenas(Centena)) & _
  IIf(Teen = 0, "", e)) & " "
End If

strDezn = IIf(Teen > 19, strDezenas(Dezena), strTeens(Teen)) & _
  IIf(Unid And Teen > 19, e, "")

strUnid = IIf(Teen > 19, strUnidades(Unid), "")

ret = strCent & strDezn & strUnid

  Dim strNumAnterior$, strExtAnterior$
  
  On Error Resume Next
  strNumAnterior = arrGrupo(0, xGrupo - 1) 'grupo anterior
  strExtAnterior = arrGrupo(1, xGrupo - 1)
  blnAnteriorRedondo = Val(Right(strNumAnterior, 2)) = 0
  On Error GoTo erro
  
  Select Case xGrupo
    Case 0                '   000
    
    Case 1 '000xxx
      
      arrGrupo(1, xGrupo - 1) = _
      IIf(blnAnteriorRedondo, _
      IIf(Val(strNumAnterior) = 0, "", e) & strExtAnterior, _
      e & strExtAnterior)
      
    ret = IIf(Val(xstr) = 0, "", _
      IIf(Val(xstr) = 1, MIL, ret & MIL))
      
    Case 2 '000xxxxxx
      arrGrupo(1, xGrupo - 1) = _
      IIf(Val(strNumAnterior) = 0 And Val(arrGrupo(0, xGrupo - 2)) = 0, _
        "", IIf(Val(strNumAnterior) > 0, IIf(Val(arrGrupo(0, xGrupo - 2)) = 0, _
        e, Virgula), "") & strExtAnterior)

    ret = IIf(Val(xstr) = 0, "", _
      IIf(Val(xstr) = 1, ret & MILHAO, ret & MILHOES))

    Case 3 ' 000xxxxxxxxx
      arrGrupo(1, xGrupo - 1) = _
      IIf(Val(strNumAnterior) = 0 And Val(arrGrupo(0, xGrupo - 2)) = 0 _
      And Val(arrGrupo(0, xGrupo - 3)) = 0, _
        "", IIf(Val(strNumAnterior) = 0, "", _
        IIf(Val(arrGrupo(0, xGrupo - 2)) = 0, e, Virgula)) & strExtAnterior)
      
    ret = IIf(Val(xstr) = 0, "", _
      IIf(Val(xstr) = 1, ret & BILIAO, ret & BILIOES))
  End Select

mfTraduzir = Trim(ret) & " "
Exit Function
erro:
  If Err = 5 Then
  Resume Next
  Else
  MsgBox Err & vbCrLf & Err.Description
  Resume Next
  End If
End Function
Private Sub Class_Initialize()
    msEncher
    mstrDecSep = mfstrGetDecimalSep
    mstrDefaultErrorMsgOverflow = ERR_OVERF
End Sub


Public Function gfGet( _
  ByVal dblX As Double, _
  Optional xmoeda As String, _
  Optional ByVal lngFormat As Long = PrimeiraMaiuscula) As String
On Error GoTo erro

Static mblnInitialized As Boolean

If Not mblnInitialized Then
    msEncher
    mstrDecSep = mfstrGetDecimalSep
    mstrDefaultErrorMsgOverflow = ERR_OVERF
    mblnInitialized = True
End If


If dblX > MAX_NUMBER Then
  gfGet = mstrDefaultErrorMsgOverflow
  Exit Function
End If

Dim strNeg$

If dblX < 0 Then
  dblX = dblX * -1
  strNeg = "Menos "
End If

'Por defeito fica em escudos
If xmoeda = "" Then
    xmoeda = "PTE"
End If
'

dblX = Format(dblX, ".00")
Dim strInteiro$, strDecimal$

  msGetParts CStr(dblX), strInteiro, strDecimal

  Dim ret$, retInt$, retDec$
    If strInteiro <> "" Then
      If CDbl(strInteiro) > 0 Then
        retInt = mfstrProcessar(strInteiro)
      Else
        retInt = ZERO
      End If
      retInt = retInt & IIf(CDbl(strInteiro) = 1, mstrDefaultSufixoInteiro1, mstrDefaultSufixoInteiro2)
    End If
       
    If strDecimal <> "" Then
      If CDbl(strInteiro) = 0 Then
        retInt = ""
      Else
        retInt = retInt & e
      End If
      retDec = mfstrProcessar(strDecimal)
      retDec = retDec & IIf(CDbl(strDecimal) = 1, mstrDefaultSufixoDecimal1, mstrDefaultSufixoDecimal2)
    End If
    
    
    ret = retInt & retDec
  
  gfGet = strNeg & IIf(lngFormat = Minusculas, LCase(ret), _
                    IIf(lngFormat = Maiusculas, UCase(ret), _
                    ret))
  
Exit Function
erro:
  gfGet = Err.Number & "; " & Err.Description
End Function

Private Sub msGetParts(ByVal strAll$, ByRef strInt$, ByRef strDec$)
  Dim intVirgLoc%
  intVirgLoc = InStr(1, strAll, mstrDecSep)
    
    If intVirgLoc > 0 Then
      strInt = Mid(strAll, 1, intVirgLoc% - 1)
      strDec = Mid(strAll, intVirgLoc% + 1)
        If Len(strDec) = 1 Then strDec = strDec & "0"
    Else
      strInt = strAll$
      strDec = ""
    End If
    
End Sub

Private Function mfstrProcessar(strPart$) As String
Dim lp%, xlen%, cnt%, ret$, buf$
Dim xstart%
xlen = Len(strPart$)
  For lp = 1 To xlen Step 3
  
  'Send numbers in 3 didit groups
  xstart = xlen - (3 * cnt)
  xstart = IIf(xstart <= 0, 1, xstart)
  buf = Right(Left(strPart$, xstart), 3)
  ReDim Preserve arrGrupo(1, cnt)
  arrGrupo(0, cnt) = CDbl(buf)
  arrGrupo(1, cnt) = mfTraduzir(cnt, Format(buf, "000"))
    cnt = cnt + 1
  Next
  
  'Spell joining the translated numbers
  Dim xtemp As String
  For lp = UBound(arrGrupo, 2) To 0 Step -1
    xtemp = xtemp & arrGrupo(1, lp)
  Next
  
  'Cut Fake spaces
  Dim red1$, inred1%, red2$, inred2%
  Dim tempA$, tempB$
  inred1 = 999: inred2 = 999

  red1 = "  ": red2 = " ,"


  Do Until inred1 + inred2 = 0

    inred1 = InStr(1, xtemp, red1)
    inred2 = InStr(1, xtemp, red2)

    If inred1 > 0 Then
      xtemp = Trim(Left(xtemp, inred1) & Right(xtemp, Len(xtemp) - (inred1 + 1)))
    End If

    If inred2 > 0 Then Mid(xtemp, inred2, 2) = ", "

  Loop
  ret = xtemp & IIf(Right(xtemp, 1) <> " ", " ", "")
  mfstrProcessar = ret

End Function

Private Function mfstrGetDecimalSep() As String
Dim ret&
Dim buf As String * 10
ret = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SDECIMAL, buf, Len(buf))
mfstrGetDecimalSep = Left(buf, InStr(1, buf, vbNullChar) - 1)
End Function


'      //////////////     PROPS     /////////////////////

Public Property Get DecimalSep() As String
  DecimalSep = mstrDecSep
End Property
Public Property Let DecimalSep(x As String)
  mstrDecSep = x
End Property
Public Property Get OverflowMsg() As String
  OverflowMsg = mstrDefaultErrorMsgOverflow
End Property
Public Property Let OverflowMsg(x As String)
  mstrDefaultErrorMsgOverflow = x
End Property
Public Property Get MaxNumber() As Double
  MaxNumber = MAX_NUMBER
End Property
Public Property Get SufixoInteiroSingular() As String
  SufixoInteiroSingular = mstrDefaultSufixoInteiro1
End Property
Public Property Let SufixoInteiroSingular(x As String)
  mstrDefaultSufixoInteiro1 = x & IIf(Right(x, 1) = "", "", " ")
End Property
Public Property Get SufixoInteiroPlural() As String
  SufixoInteiroPlural = mstrDefaultSufixoInteiro2
End Property
Public Property Let SufixoInteiroPlural(x As String)
  mstrDefaultSufixoInteiro2 = x & IIf(Right(x, 1) = "", "", " ")
End Property
Public Property Get SufixoDecimalSingular() As String
  SufixoDecimalSingular = mstrDefaultSufixoDecimal1
End Property
Public Property Let SufixoDecimalSingular(x As String)
  mstrDefaultSufixoDecimal1 = x & IIf(Right(x, 1) = "", "", " ")
End Property
Public Property Get SufixoDecimalPlural() As String
  SufixoDecimalPlural = mstrDefaultSufixoDecimal2
End Property
Public Property Let SufixoDecimalPlural(x As String)
  mstrDefaultSufixoDecimal2 = x & IIf(Right(x, 1) = "", "", " ")
End Property

Office Systems Developer : VBA Code

Sample Function to Translate a Access Database IDE (ADODB)

MDB Deleted Tables Recover

MDBTableRecover (Version 1.0.0.2)

VBA and Office 14, just to clarify

Recover tables deleted from a database in Access

Portuguese Functions for Access 2007 - Funções em Português para o Access 2007

Funções Office 2007 VBA

Legal

ActiveX

Aplicação

Matrizes

Conversão

Base de Dados

Data/Hora

Agregado de Domínio

Gestão de Erros

Entrada/Saída de Ficheiros

Gestão de Ficheiros

Financeira

Monitorização

Matemática

Mensagens

Diversos

Fluxo do Programa

Texto

Training Kits Microsoft Powered in portuguese - PT Portugal Formacao Office Microsoft Powered

Dialog Box in Microsoft Access (Find File)

How to automate with Office Assistance?

How to Spell Months by VBA Code and SQL?

How to Disable (F11 key) Shortcut to database Window?

How to Spell numbers to Euros using API?