Important:

Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog podem ser tratados como consultoria freelance.

Views

VBA Error 3275 - Unexpected error from external database driver

Pois é, erros e mais erros...

Conforme já tive chance de escrever aqui antes, invariavelmente somos expostos a erros quando estamos desenvolvendo soluções através das nossas aplicações, não raramente acompanhadas de uma demanda alta e com pouco tempo.

Especialmente quando envolve o inter-relacionamento entre aplicações distintas, neste caso utilizo o
MS Office 2007.

As interações podem ocorrer entre o MS Access e o MS Excel, numa constante troca de dados, com a criação de diversas planilhas repletas de fórmulas, ou mesmo a exportação de diversos painéis de dados (como um Dashboard) para apresentações MS PowerPoint dentro de um ciclo contínuo.

No cenário descrito acima é muito provável que nos deparemos com o famoso, pouco conhecido, mas muiiitooo chato: Erro 3275.

Este erro, quando pesquisado na literatura Microsoftniana, está acompanhado da seguinte definição:
Unexpected error from external database driver <error number>, ou,
Erro inexperado causado pelo driver de banco de dados externo <número do erro>

Este erro torna-se ainda mais comum durante a execução repetitiva da seguinte linha de comando:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, nquery, PlanTarget

Pode percebê-lo melhor dentro da funcionalidade abaixo, a qual é evocada dentro de um ciclo constante.
Function Qualquer
    ' 1ª FASE - Copia a planilha enviada como referência.
    ' ----------------------------------------------------------------------------------------
    Set objExcel = CreateObject("Excel.Application")
    Set objWorkBook = objExcel.Workbooks.Open(PlanBase)

    ' Salva planilha com o nome temporário.
    objExcel.Workbooks(1).SaveAs (PlanTarget)
    objExcel.Quit
   
    ' Cria Query tmp, base da planilha.
    Set Cria_Query = CurrentDb.CreateQueryDef(nquery, strSQL)

    Call Sleep(2000)  ' Pausa para o sistema operacional não fundir...
    Debug.Print Right(Now(), 8), nquery, strSQL, PlanTarget

    ' Insere planilha com dados.
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, nquery, PlanTarget

    ' Delete a query temp
    DoCmd.DeleteObject acQuery, nquery

    ' Final - Limpa as variáveis.
    ' ----------------------------------------------------------------------------------------
    Set Cria_Query_PXBR = Nothing
    Set objWorkBook = Nothing
    Set objExcel = Nothing
End Function

Certamente percebeu a ocorrência da função Sleep() no trecho de código colado aí acima. Este foi
implementado com o único propósito de 'atrasar' a funcionalidade para que esta possa ter tempo de
exportar os dados para a planilha e em seguida dar continuidade ao processo.

Percebi, pelo menos neste meu problema, que a interação entre as aplicações necessita de um tempo para o processamento completo, o qual envolve:

- Busca dos dados dentro da base;
- Exportação destes dados para uma planilha, que tem como base um modelo;
- Adequação dos dados nesta planilha modelo.

Ao passo que o MS Access executava suas funcionalidade de uma forma rápida, o mesmo não ocorria com MS Excel que ficava 'agarrado' no seu processamento de forma mais lenta (letárgica diria). Para tanto, precisei dar um sossega leão no MS Access, utilizando a função Sleep().

Call Sleep(4000)  ' Pausa para o sistema operacional não fundir...
Pode ser que necessite dessa funcionalidade em outros aspectos, por isso te passo o modo como
resolvi aqui nesta Sleep(), mas poderá fazer de outro modo:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Seria muito legal, caso já tenha se deparado com este problema, que o comentasse, e como fez
para resolvê-lo. Desse modo criaremos um repositório para elucidar aqueles que forem atacados
pelo mesmo inconveniente Erro 3275.
 
Twitter: @officespecialis
             @brzexceldevelop
             @brzaccessdevel


Tome posse das INFORMAÇÕES da sua empresa!

Empresas em todo o mundo estão permeadas de dados oriundos de diversas origens distintas e apesar do acesso a este, têm dificuldades em obter as necessárias informações para tomar as suas mais relevantes decisões.
 
Não é menos verdade que em muitas reuniões todos estejam munidos de INFORMAÇÕES totalmente irrelevantes. Têm acesso a dados de A a Z, completamente desprovidos de conteúdo, pois estes não contém a abrangência e nem a diversificação, que lhes propiciem dinamicidade na análise.
 
Em alguns casos as corporações têm acesso a um grande amontoado de dados distribuidos nos seus servidores como BIs, Datawarehouse e cubos OLAP.
 
Informação é algo muito precioso e deve ser obtida de forma rápida e exata.

Reunir informações de diferentes países, traduzindo-os nas estratégias e targets pré-estabelecidos tem sido um desafio para a maioria dos executivos em todo o mundo.
Não raro seus KPIs (Indicadores de Performance) não estão alinhados com as estratégias da empresa.

A diversidade de bases de dados nas quais as informações podem estar são muito variáveis, quando necessita consolidar tais informações em
Dashboards e Scorecards, estes precisam estar reundos de modo coerente e sucinto.

Os
Balanced Scorecards oferecem aos executivos as ferramentas que necessitam para alcançar o sucesso na obtenção de suas informações. Esta importante ferramenta traduz a missão e a estratégia da sua empresa num conjunto abrangente de medidas de desempenho que serve como base para o sistema de medição e gestão estratégica. Perseguindo os objetivos financeiros, incluindo os vetores de desempenho desses objetivos.

O grande dilema é: Mesmo estando cercado por dados de todas as origens, como posso  obter INFORMAÇÕES relevantes para tomar minhas decisões?

?ui=2&view=att&th=1254a1f913f53170&attid=0.1&disp=attd&realattid=ii_1254a1f913f53170&zw
Os conceitos e as regras de negócio precisam ser aplicados aos dados de modo a atender a empresa como um TODO e não apenas a alguns departamentos e países.

Os resultados mais comuns são INFORMAÇÕES IMPRECISAS, números que não coicidem durante as reuniões, resultando no adiamento de decisões altamente relevantes, ou na tomada de decisões inseguras.

Para que a Direção da empresa possa tomar decisões abalizadas, torna-se imprescindível que o conteúdo seja coeso, sintético e direcionado para atender o foco das reuniões.

O
Management Information System é um Sistema de Informação Gerencial, que interliga todos os dados da organização. Consiste na rede de canais de comunicação da organização permeando todas as estruturas executivas. É composto por todos os componentes que recolhem, manipulam e disseminam as informações. Nele estão inclusos hardware, software, pessoas, sistemas de telecomunicação, e os dados propriamente ditos.
Essas soluções são facilmente implementadas sem que se necessite adquirir novos softwares ou sistemas. Permita-me norteá-lo.
 
Utilize o que há de melhor em técnicas de análise!

:: Consulte seus dados concentrados em Scorecards.
:: Utilize layouts funcionais que destaquem as informações mais relevantes.
:: Envie ou arraste tabelas e gráficos para suas apresentações eletrônicas.
:: Compartilhe as informações através de Dashboards funcionais.

Cause um impacto positivo em todos os níveis executivos da sua gestão.

Entre em contato, presto consultoria pontual.

:: Avalie diferentes cenários
:: Reúna as informações mais importante para sua análise.
:: Efetue simulações com os dados reais ou com estimativas.
:: Compare suas informações com dados do seu Marketshare.
:: Tenha relatórios atualizados com informações oriundas da Internet.


Não é necessário a aquisição de nenhum produto!

Implemente soluções com os produtos já disponíveis na sua Empresa ou Departamento.

Reunir informações de diferentes países, traduzindo-os nas estratégias e targets pré-estabelecidos tem sido um desafio para a maioria dos executivos em todo o mundo.

- Torne a informação clara e compreensível nos seus relatórios
- Complete suas planilhas com mais funcionalidades.
- Melhore a apresentação das suas informações.
- Aplique layouts modernos.
- Envie dados diretamente para as apresentações do Powerpoint.
- Envie análises consolidadas diretamente para os seus clientes.
- Capte informações do marketshare diretamente da Web
.

Implemento soluções com os produtos já instalados na sua Empresa e Departamento.

Organizo os dados disponíveis, deixando seus novos relatórios com layouts funcionais.

Amplie a visão:
       Demonstração 1
       Demonstração 2
 
 

VBA Access - Criando uma planilha (MS Excel com gráfico) a partir de uma aplicação MS Access.

Vez por outra recebo pedidos sobre como criar planilhas através do Access, ou seja, a partir de uma aplicação MS Access que alguém já tem desenvolvida.

Na verdade isso é muito simples, por isso estou ampliando alguns passos nesta criação. Além de demonstrar como criar a planilha, estou populando-a com dados e inserindo um gráfico, tudo programaticamente (ou de modo automatizado, como preferem alguns).

Espero que gostem, ampliem o exemplo e me retornem opiniões e acréscimos...Ahhh e o mais importante para toda a comunidade de desenvolvedores, compartilhe com o máximo de pessoas que conhecer!

Boa diversão!

 
Private Sub cmdMakeChart_Click()
    '  Author:                           Date:                     Contact:                           URL:
    '  André Bernardes             23/11/2009 10:40   
bernardess@gmail.com     http://al-bernardes.sites.uol.com.br/
    '  Cria uma planilha, popula-a com uma periodicidade e dados, cria um gráfico.
 
    Dim AppMSExcel As Excel.Application
    Dim the_date As Date
    Dim stop_date As Date
    Dim r As Integer
    Dim new_chart As Chart
    Dim new_book As Workbook
    Dim active_sheet As Worksheet
 
    ' Abre a aplicação MS Excel.
    Set AppMSExcel = CreateObject("Excel.Application")
 
    ' Mantém aplicação escondida.
    Let AppMSExcel.Visible = True
 
    ' Cria uma nova planilha (spreadsheet).
    Set new_book = AppMSExcel.Workbooks.Add()
 
    ' Gera valores randômicos dentro de um período.
    Set active_sheet = new_book.Sheets(1)
   
    Let the_date = CDate("01/11/09")
    Let stop_date = CDate("23/11/09")
    Let r = 1
   
    Do While the_date < stop_date
        Let active_sheet.Cells(r, 1) = the_date
        Let active_sheet.Cells(r, 2) = Int(Rnd * 90) + 10
        Let the_date = DateAdd("d", 1, the_date)
        Let r = r + 1
    Loop
 
    ' Cria um gráfico (chart) conectado a estes dados.
    Set new_chart = Charts.Add()
   
    With new_chart
        Let .ChartType = xlLineMarkers
       
        .SetSourceData Source:=active_sheet.Range("A1:B" & Format$(r - 1)), PlotBy:=xlColumns
        .Location Where:=xlLocationAsObject, Name:=active_sheet.Name
    End With
 
    Let active_sheet.Shapes(active_sheet.Shapes.Count).Top = 10
    Let active_sheet.Shapes(active_sheet.Shapes.Count).Left = 100
    Let active_sheet.Shapes(active_sheet.Shapes.Count).Width = 600
    Let active_sheet.Shapes(active_sheet.Shapes.Count).Height = 400
 
    ActiveChart.ChartArea.Select
 
    ' Acerta primeira fase de detalhes.
    With ActiveChart
        Let .HasTitle = True
        Let .ChartTitle.Characters.Text = "Valores de Fevereiro"
        Let .Axes(xlCategory, xlPrimary).HasTitle = True
        Let .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Data"
        Let .Axes(xlValue, xlPrimary).HasTitle = True
        Let .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Valores"
    End With
 
    ' Fecha a pasta (workbook) salvando.
    AppMSExcel.ActiveWorkbook.Close True
 
    ' Fecha o MS Excel.
    AppMSExcel.Quit
    Set AppMSExcel = Nothing
 
    MsgBox "Planilha Gerada!"
End Sub
 


André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com
 
Twitter: @officespecialis
                 @brzexceldevelop
                 @brzaccessdevel
 

 

VBA Access - Removendo campos programaticamente

Remove Fields From MDB programmatically

O código VBA abaixo será usado para remover um campo de uma tabela do MS Access através da codificação VBA.

Sobre a função: Aceitará três parâmetros

1. Database Path - O caminho completo da base de dados MS Access

2. TableName - O nome correto da tabela do MS Access de onde o
campo será removido.

3. FieldName - O nome do campo a ser removido.

Function RemoveFieldFromMSACCESSTable (ByVal AccessDBPath, _
                                       ByVal AccessTableName As String, _
                                       AccessFieldName As String _
                                      ) As Boolean

  ' Declaração das variáveis.
  Dim AccessDB As Database
  Dim AccessDBPath As Variant
  Dim Td As TableDef

  On Error Resume Next


  ' Informa o Path do MS Access DB, baseado na TableName.

  ' Abre a base de dados.
  Set AccessDB = OpenDatabase(AccessDBPath) 'if linked table       

  If Err <> 0 Then           
    ' Caso falhe, retorna a base de dados.

    Exit Function       
  End If   


  ' Retorna a tabela.   
  Set Td = AccessDB.TableDefs(AccessTableName)   

  If Err <> 0 Then       
    ' caso falhe obtém a tabela.       

    GoTo End   
  End IF

  ' Deletando o campo.
  With Td       
    ' Deleta o campo.       
    .Fields.Delete AccessFieldName       

    If Err <> 0 Then           
      ' Caso falhe a deleção do campo - possivelmente não existe.           

      GoTo End       
    End If   
  End With   

  Let RemoveFieldFromMSACCESSTable = True ' O Default é False caso tenha falhado.


  ' Limpa.
End:   
  Set Td = Nothing   

  ' Close the Database   
  If Not AccessDB Is Nothing Then AccessDB.Close   

  Set AccessDb = Nothing
End Function

Exemplo do uso:
Public Sub RemoveField ()

' Exemplo da chamada:
If (RemoveFieldFromMSACCESSTable ( "C:\Bernardes\A&A.mdb", "Clientes", "TimeStamp") Then

MsgBox "Campo removido com sucesso!"

End If

End Sub
 

A chamada acima é utilizada para excluir de "C:\Bernardes\A&A.mdb", o nome da tabela é Clientes, e o nome do campo é "TimeStamp"
 
 
Twitter: @officespecialis
             @brzexceldevelop
             @brzaccessdevel


Veja também:
Blog Office VBA

VBA Access - Função para saber se existe um arquivo.

Tudo bem que seja uma função básica, mas com sua utilidade.

Esta função retorna True se não houver um arquivo com o nome que você passar, mesmo que esteja escondido ou seja um arquivo de sistema.

Assume o diretório atual, se você não incluir um caminho.

Retorna False se o nome do arquivo for uma pasta, a menos que você passe True para o segundo argumento.

Retorna False para qualquer erro, por exemplo: nome de arquivo inválido, a permissão foi negada, o servidor não foi encontrado.

Procura um arquivo chamado nFile.accdb na pasta de dados:
ExisteArquivo ("C: \ Data \ nFile.accdb")

Procura um arquivo chamado nFile.txt em um servidor de rede:
ExisteArquivo ("\ \ MyServer \ MyPath \ nFile.txt")

Verifique se há um arquivo ou pasta no servidor com o nome Bernardes:
ExisteArquivo ("\ \ MyServer \ Bernardes", True)

Verifica a pasta do banco de dados atual para um arquivo chamado A&A-InAnyPlace.xlsx:
ExisteArquivo (TrailingSlash (CurrentProject.path) & "A&A-InAnyPlace.xlsx")

Function ExisteArquivo (ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
    Dim lngAttributes As Long

    'Inclui arquivos read-only (somente leitura), hidden (escondidos), e system (de sistema).
    Let lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)

    If bFindFolders Then
        Let lngAttributes = (lngAttributes Or vbDirectory) 'Inclui pastas.
    Else
        Do While Right$(strFile, 1) = "\"
            Let strFile = Left$(strFile, Len(strFile) - 1)
        Loop
    End If

    ' Se Dir() retornar alguma coisa, é porque existem arquivos.
    On Error Resume Next
    Let FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function

Function TrailingSlash (varIn As Variant) As String
    If Len(varIn) > 0 Then
        If Right(varIn, 1) = "\" Then
            Let TrailingSlash = varIn
        Else
            Let TrailingSlash = varIn & "\"
        End If
    End If
End Function
 
Twitter: @officespecialis
             @brzexceldevelop
             @brzaccessdevel



André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com

Access VBA - API: Alterando as propriedades ForeColor e Bold num nó selecionado de um Treeview







API: Alterando as propriedades ForeColor e Bold no NÓ selecionado de um Treeview:

Bem, para ser sincero com vocês o controle TreeView da Microsoft não suporta nenhum realce no texto de um NÓ que esteja selecionado.

Embora você possa destacar (highlight) um NÓ através da execução de um código no evento Click, o NÓ previamente destacado (highlighted) perderá tal destaque.

Para que possa testar este exemplo, coloque um Treeview (refiro-me a versão 6), sobre um formulário e, com o nome tvwTest-lo. Copie o seguinte código abaixo no módulo de classe do formulário.

Usando a API SendMessage, será possível recuperar as configurações atuais de um NÓ, e para repetir todos os NÓS, se a propriedade Bold for definida como verdadeira para um NÓ, pode forçar o NÓ para ser redefinido,  redesenhando-o normalmente.

Private Type TV_ITEM
    mask As Long
    hItem As Long
    state As Long
    stateMask As Long
    pszText As String
    cchTextMax As Long
    iImage As Long
    iSelectedImage As Long
    cChildren As Long
    lParam As Long
End Type
 
Private Declare Function apiSendMessage _
    Lib "user32" Alias "SendMessageA" _
  (ByVal hWnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  lParam As Any) _
  As Long
 
Private Const TVIS_BOLD  As Long = &H10
Private Const TV_FIRST As Long = &H1100
Private Const TVM_GETITEM As Long = (TV_FIRST + 12)
Private Const TVIF_HANDLE = &H10
Private Const TVGN_ROOT = &H0

Private Const TVIF_CHILDREN = &H40
Private Const TVM_GETNEXTITEM = (TV_FIRST + 10)
Private Const TVGN_CHILD = &H4
Private Const TVIF_STATE = &H8
Private Const TVM_SETITEM = (TV_FIRST + 13)
Private Const TVGN_NEXT = &H1

Private Const TVGN_CARET = &H9
Private mobjLastNode As Node
Private mlngBackColor As Long
 
Private Sub Form_Load()
    Dim objNode As Node
    Dim i As Integer

    For i = 1 To 10
        Set objNode = tvwTest.Nodes.Add(, , "r" & i, "ANode" & i)
    Next
End Sub
 
Private Sub sResetItems _
(hWnd As Long, hItem As Long)

Dim tvi As TV_ITEM
Dim hItemChild As Long
Dim objNode As Node
 
    If hItem = 0 Then
        Let hItem = apiSendMessage(hWnd, _
                            TVM_GETNEXTITEM, _
                            TVGN_ROOT, _
                            ByVal 0&)
    End If

    If Not mobjLastNode Is Nothing Then
        With mobjLastNode
            Let .ForeColor = vbBlack
            Let .BackColor = mlngBackColor
        End With
    End If

    Do While Not hItem = 0
        Let tvi.hItem = hItem
        Let tvi.mask = TVIF_CHILDREN Or TVIF_STATE
        Let tvi.stateMask = TVIS_BOLD

        Call apiSendMessage(hWnd, _
                    TVM_GETITEM, _
                    0, _
                    tvi)
        If tvi.state And TVIS_BOLD = TVIS_BOLD Then
            Let tvi.state = tvi.state And Not TVIS_BOLD
            Call apiSendMessage( _
                hWnd, _
                TVM_SETITEM, _
                0, _
                tvi)
        End If

        If (tvi.cChildren) Then
            Let hItemChild = apiSendMessage( _
                        hWnd, _
                        TVM_GETNEXTITEM, _
                        TVGN_CHILD, _
                        ByVal hItem)

            Call sResetItems(hWnd, hItemChild)
        End If

        Let hItem = apiSendMessage (hWnd, _
                                    TVM_GETNEXTITEM, _
                                    TVGN_NEXT, _
                                    ByVal hItem)
    Loop
End Sub

Private Sub tvwTest_NodeClick _
(ByVal Node As Object)

   Call sResetItems(Me.tvwTest.hWnd, 0)

    With Node
        Let .Bold = True
        Let .ForeColor = vbBlue
        Let mlngBackColor = .BackColor
        Let .BackColor = vbYellow
    End With

    Set mobjLastNode = Node
End Sub

Developed by Dev Ashish

Veja também:
Tudo em VBA
VBA Excel
VBA Access

André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com

VBA - Retornando a versão corrente de qualquer aplicação Office.

Recurso rápido, simples e oportuno em épocas de troca de versão. Pode ser usado inclusive dentro do código para adaptar chamadas, abrir bases de dados, etc...

Tags: Bernardes, MS, Microsoft VBA, Scripting Languages, Microsoft Office, Office, Software/Web Development, Web Development, Office Suites, Software

Muitos de nós desenvolvedores desenvolvemos em ambientes onde estão diversas versões do MS Office. Em tal ambiente saber identificar qual versão rodará nossa aplicação é imprescindível. Não necessariamente teremos a mesma solução (código) em versões distintas.

Felizmente temos como, através do próprio VBA, identificar qual a versão de software que está sendo executada. A SUB abaixo retorna o número da versão num message box:

Sub LetVersion()
  MsgBox "O número da versão corrente é: " & Application.Version, _

    vbOKOnly, "Version"
End Sub

Você pode adequar a SUB para retornar o número da versão:

Function LetVersion() As Long
  Let LetVersion = Application.Version
End Function


André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com

Twitter: @officespecialis
            @brzexceldevelop
            @brzaccessdevel

VBA Access - Função para transpor a tabela.

Access 2002

Às vezes, talvez seja necessário transpor os dados em uma tabela ou consulta de modo que os nomes dos campos sejam listados verticalmente na coluna à esquerda e que os dados sejam distribuídos pela página horizontalmente. Por exemplo, talvez seja necessário transpor os dados de um relatório ou antes exportá-los para um arquivo de texto.

O Método a seguir mostra como é possível usar um procedimento VBA (Visual Basic for Applications) para cumprir a tarefa.

OBSERVAÇÃO: Esse método não funcionará se você tiver mais de 255 registros, pois o número máximo de campos em uma tabela do Microsoft Access é 255.

Crie um novo módulo no banco de dados e digite ou cole o seguinte procedimento:
Function Transposer(strSource As String, strTarget As String)

   Dim db As DAO.Database
   Dim tdfNewDef As DAO.TableDef
   Dim fldNewField As DAO.Field
   Dim rstSource As DAO.Recordset, rstTarget As DAO.Recordset
   Dim i As Integer, j As Integer

   On Error GoTo Transposer_Err

   Set db = CurrentDb()
   Set rstSource = db.OpenRecordset(strSource)
   rstSource.MoveLast

   ' Create a new table to hold the transposed data.
   ' Create a field for each record in the original table.
   Set tdfNewDef = db.CreateTableDef(strTarget)
   For i = 0 To rstSource.RecordCount
      Set fldNewField = tdfNewDef.CreateField(CStr(i + 1), dbText)
      tdfNewDef.Fields.Append fldNewField
   Next i
   db.TableDefs.Append tdfNewDef


   ' Open the new table and fill the first field with
   ' field names from the original table.
   Set rstTarget = db.OpenRecordset(strTarget)
   For i = 0 To rstSource.Fields.Count - 1
      With rstTarget
        .AddNew
        .Fields(0) = rstSource.Fields(i).Name
        .Update
      End With
   Next i

   rstSource.MoveFirst
   rstTarget.MoveFirst
   ' Fill each column of the new table
   ' with a record from the original table.
   For j = 0 To rstSource.Fields.Count - 1
      ' Begin with the second field, because the first field
      ' already contains the field names.
      For i = 1 To rstTarget.Fields.Count - 1
         With rstTarget
            .Edit
            .Fields(i) = rstSource.Fields(j)
            rstSource.MoveNext
            .Update
         End With

      Next i
      rstSource.MoveFirst
      rstTarget.MoveNext
   Next j

   db.Close

   Exit Function

Transposer_Err:

   Select Case Err
      Case 3010
         MsgBox "The table " & strTarget & " already exists."
      Case 3078
         MsgBox "The table " & strSource & " doesn't exist."
      Case Else
         MsgBox CStr(Err) & " " & Err.Description
   End Select

   Exit Function

End Function


Para testar a função, pressione CTRL+G. Na janela Imediato, digite a seguinte linha e pressione ENTER:

? Transposer("Suppliers","SuppliersTrans")

André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com

+55 (13) 9152-2565

Twitter: @officespecialis
              @brzexceldevelop
              @brzaccessdevel


Esta mensagem pode conter informação confidencial e/ou privilegiada. Se você não for o destinatário ou a pessoa autorizada a receber esta mensagem, não pode usar, copiar ou divulgar as informações nela contidas ou tomar qualquer ação baseada nessas informações. Se você recebeu esta mensagem por engano, por favor avise imediatamente o remetente, respondendo o e-mail e em seguida apague-o. Agradecemos sua cooperação.
del.icio.us

VBA - Torne maiúsculas as primeiras letras de todas as palavras (Capitalize)

Eu sei que já temos uma função específica, mas o exercício do desenvolvimento é arrebatador. Na versão do Access 97, por exemplo, pode-se utilizar:     StrConv("andré bernardes", vbProperCase)

Agora, se quiser aprenser a fazer e utilizar em qualquer aplicação do Office...

Function Captalize(X)
       ' Torna maiúscula a primeira letra de uma palavra em um campo.
       ' Use-a num evento, procedure ou após a atualização de um objeto;
       ' Por exemplo, [Last Name] = Captalize([Last Name]).
       ' Nomes como O'Brien e Wilson-Smythe serão propriamente "capitalizados",
       ' mas MacDonald será mudado para Macdonald, e van Buren para Van Buren.
       ' Note: Para que esta função funcione corretamente, você precisa especificar:
       ' Option Compare Database na declaração da sessão do módulo.

       Dim Temp$, C$, OldC$, i As Integer

       If IsNull(X) Then
              Exit Function
       Else
              Let Temp$ = CStr(LCase(X))

              '  Inicialize OldC$ com um espaço simples porque a primeira
              '  letra precisa ser aumentada, mas não as precedidas por letra.

              Let OldC$ = " "

              For i = 1 To Len(Temp$)
                     Let C$ = Mid$(Temp$, i, 1)

                     If C$ >= "a" And C$ <= "z" And (OldC$ < "a" Or OldC$ > "z") Then
                            Mid$(Temp$, i, 1) = UCase$(C$)
                     End If

                     Let OldC$ = C$
              Next i

              Let Proper = Temp$
       End If
End Function



André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com


VBA Access/Excel - LINK do Excel no Access - Solucionando problemas de #Num!

Solucionar problemas de #Num! e outros valores incorretos em uma tabela vinculada

Mesmo que visualize a mensagem Vinculação da tabela concluída, você deve abrir a tabela no modo Folha de Dados para certificar-se de que as linhas e colunas mostrem os dados corretos.

Se visualizar erros ou dados incorretos em qualquer local na tabela, execute a ação conforme descrito na tabela a seguir e, em seguida, tente vincular novamente. Lembre-se de que não é possível adicionar valores diretamente à tabela vinculada, porque a tabela é somente leitura.


Problema e Soluções
Elementos gráficos Os elementos gráficos em uma planilha do Excel, como logotipos, gráficos e imagens não podem ser vinculados no Access.
Formato de exibição Pode ser necessário definir a propriedade Formato de determinados campos no modo Design para garantir que os valores sejam exibidos corretamente no modo Folha de Dados.
Valores calculados Os resultados de uma coluna ou de células calculadas são exibidos no campo correspondente, mas não é possível visualizar a fórmula (ou expressão) no Access.
Valores de texto truncados Aumente a largura da coluna no modo Folha de Dados. Se ainda assim, não for possível visualizar o valor inteiro, isso significa que o valor tem mais de 255 caracteres. O Access pode vincular apenas aos primeiros 255 caracteres, portanto, é necessário importar os dados, em vez de vinculá-los.
Mensagem de erro de estouro de campo numérico A tabela vinculada pode parecer estar correta, mas posteriormente, ao executar uma consulta em relação à tabela, você poderá visualizar uma mensagem de erro Estouro de Campo Numérico. Isso pode acontecer em razão de um conflito entre o tipo de dados de um campo na tabela vinculada e o tipo de dados armazenado nesse campo.
VERDADEIRO ou FALSO e valores -1 ou 0 Se a planilha ou o intervalo de origem incluir uma coluna que contenha apenas valores VERDADEIRO ou FALSO, o Access cria um campo Sim/Não para a coluna na tabela vinculada. No entanto, se a planilha ou o intervalo de origem incluir uma coluna que contenha apenas valores -1 ou 0, o Access, por padrão, criará um campo numérico para a coluna, e não será possível alterar o tipo de dados do campo correspondente na tabela. Se quiser um campo Sim/Não na tabela vinculada, certifique-se de que a coluna de origem inclua valores VERDADEIRO e FALSO.
Campos com múltiplos valores O Access não oferece suporte para múltiplos valores em um campo, mesmo que a coluna de origem contenha uma lista de valores separados por ponto-e-vírgula (;). A lista de valores será tratada como um único valor, e será colocada em um campo de texto.
#Num! O Access exibe o valor de erro #Num!, em vez dos dados reais em um campo, nas seguintes situações: 

:: Se uma coluna de origem contiver alguns valores de data ou numéricos em uma coluna que contenha, principalmente, valores de texto, os valores de data e numéricos não serão importados.

:: Se uma coluna de origem contiver alguns valores de texto em uma coluna que contém, principalmente, valores numéricos, os valores de texto não serão importados.

:: Se uma coluna de origem contiver alguns valores de texto em uma coluna que contém, principalmente, valores de data, os valores de texto não serão importados.
Siga os procedimentos abaixo para minimizar as ocorrências de valores nulos na tabela:


:-: Certifique-se de que a coluna de origem não contenha valores de tipos de dados diferentes. :-: Formate as colunas no arquivo do Excel.:-: Durante a operação de vinculação, selecione o tipo de dados correto para cada campo. Se o tipo de dados for incorreto, a coluna resultante poderá conter apenas valores #Num! para todas as linhas de dados.

:-: Valores numéricos, em vez de valores de data Caso visualize um número de cinco dígitos aparentemente aleatório em um campo, verifique se a coluna de origem contém, principalmente, valores numéricos, mas também, alguns valores de data. Os valores de data que aparecem em colunas numéricas são convertidos incorretamente em um número. Substitua os valores de data por valores numéricos, e tente vincular novamente.

:-: Valores de data, em vez de valores numéricos Caso visualize um valor de data aparentemente aleatório em um campo, verifique se a coluna de origem contém, principalmente, valores de data, mas também, alguns valores numéricos. Os valores numéricos que aparecem em colunas de data são convertidos incorretamente em uma data. Substitua os valores numéricos por valores de data, e tente vincular novamente.

 
André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com

VBA Access - Convertendo o conteúdo de um TextBox em Data (Convert TextBox values to Dates)

Conversões são tão comuns que chegam a ser monótonas...

...Mas entendo que são fundamentais para quem está começando...Freqüentemente utilizo textboxes como campo para o dataentry de Datas (Date). O problemas é que apesar de formatá-los para se parecerem com uma data, continuam contendo um valor text. A função CDate() é uma boa solução para este trabalho. Escrevo uma function e mando todo o trabalho para essa função interna. Minha function captura o tipo texto (Text) e o converte para data (Date).





Function Vert2Dt(dtStr As String) As Date
                ' Converte o conteúdo do textbox formatado como data em uma data "real".
 

                Let Vert2Dt = CDate(Left$(dateString, 2) & "/" & Mid$(dateString, 3, 2) & "/" & Right$(dateString, 4))
End Function


André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/

bernardess@gmail.com
inanyplace
bernardess@gmail.com



VBA Access - Verificando sua Listbox (Check your listbox)

Quando utilizamos uma Listbox...

... Por exemplo, talvez queiramos habilitar um botão na nossa interface quando um determinado item da lista for selecionado, ou talvez queiramos executar uma rotina para retirar a seleção, mas somente se alguns dos itens já estiverem selecionados (caso contrário poderemos estipular outras ações).

A função abaixo tem como alvo um objeto ListBox e retornará True caso qualquer valor estiver selecionado.













Function HaALgoSelecionado (nLista As Access.ListBox) As Boolean
               ' Retorna true se algum item estiver selecionado no listbox.

  Dim nOccur As Long
 
  For nOccur = 0 To lst.ListCount - 1
    If nLista.Selected(nOccur) Then
      Let HaALgoSelecionado = True
      Exit For
    End If
  Next i
 
End Function


André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/

bernardess@gmail.com
inanyplace
bernardess@gmail.com

VBA - Deletando linhas duplicadas

Vez por outra colamos bases de dados no MS Excel para análise e manipulação. Nem sempre tais dados foram previamente depurados, possibilitando que linhas duplicadas estejam no range que manipulamos sem que nos apercebamos disso.

Como efetuar uma depuração que retire as ocorrências duplicadas deixando somente uma versão de cada registro?

A solução abaixo ajuda nesta necessidade. Implementem e mantenham o autor, ok?


Public Sub DelDupliRows(rng As Range)
            '  Author:                      Date:                        Contact:
            '  André Bernardes      29/01/2009 12:18     bernardess@gmail.com
            '  Esta SUB deletará registros (linhas) duplicadas, será baseada no Range passado
            '  como parâmetro. Quando a SUB encontrar a mesma ocorrência no Range,
            '  deletará as seguintes.

            Dim r As Long
            Dim n As Long
            Dim v As Variant

            On Error GoTo EndMacro

            Let Application.ScreenUpdating = False
            Let Application.Calculation = xlCalculationManual
            Let Application.StatusBar = "Linha sendo processada: " & Format(rng.Row, "#,##0")
            Let n = 0

            For r = rng.Rows.Count To 2 Step -1
                        If r Mod 500 = 0 Then
                                    Let Application.StatusBar = "Processing Row: " & Format(r, "#,##0")
                        End If

                        Let v = rng.Cells(r, 1).Value

                        If v = vbNullString Then
                                    If _
                                                Application.WorksheetFunction.CountIf(rng.Columns(1), _
                                                vbNullString) > 1 Then

                                                rng.Rows(r).EntireRow.Delete

                                                Let n = n + 1
                                    End If
                        Else
                                    If Application.WorksheetFunction.CountIf(rng.Columns(1), v) > 1 Then
                                                rng.Rows(r).EntireRow.Delete

                                                Let n = n + 1
                                    End If
                        End If
            Next r

EndMacro:
            Let Application.StatusBar = False
            Let Application.ScreenUpdating = True
            Let Application.Calculation = xlCalculationAutomatic

            MsgBox CStr(n) & "Linha(s) Duplicada(s) Deleta(s) "
End Sub


Vejam outras várias sugestões...
Blog Excel
Blog Access
Blog Office




VBA - Samples, Examples, Tips, Tricks, Code, Download, Office, etc...

Usem e divulguem


VBA Office    -  VBA para MS Office - Todos os aplicativos da Suíte Office.


VBA Access -  VBA para MS Access - Códigos, exemplos, Definições.


VBA Excel     -  VBA para MS Excel - Códigos, exemplos, Definições.


E aguardem, outros virão...


VBA Access - Saiba qual é a sua versão de Access

Certifique-se de qual versão do MS Access está sendo utilizada

É simples, mas pode salvá-lo quando estiver rodando sua aplicação num
ambiente com várias versões do MS Access...
  • Você poderá restrigir o accesso a sua base de dados caso o usuário final tenha uma versão incompatível do Access.
  • Poderá adicionar ou excluir certas funcionalidades da sua aplicação de acordo com a versão do MS Access presente.
1
2
3
4
5
6
Function GetAccessVersion() As Long
' returns application version

  Let GetVersion = Application.SysCmd(acSysCmdAccessVer)

End Function

Para que retorne a versão do Access na sua aplicação, apenas evoque GetAccessVersion(). abaixo estão os números correspondentes às versões mais recentes:

  • MS Access 97 — Versão 8
  • MS Access 2000 — Versão 9
  • MS Access 2002 — Versão 10
  • MS Access 2003 — Versão 11
  • MS Access 2007 — Versão 12


André Luiz Bernardes

VBA Access - Onde este CAMPO é usado?

Esta é uma funcionalidade que lhe quebrará um "galhão". Sua utilidade? Vascular todas as suas tabelas, formulários, relatórios e identificar onde o seu campo é particularmente usado. São não faz as buscas no código VBA (o que o Access lhe propicia facilmente).

Poderá utilizar essa funcionalidade sob os seguintes cenários:

  • Um relatório requer um parâmetro, mas você não consegue ver onde o nome do campo foi usado.
  • Antes que renomeie um campo, você quer saber quais objetos na sua aplicação dependem deste campo.

Para adicionar esta funcionalidade à sua aplicação, basta que:

  1. Crie um novo módulo
  2. Copie o código abaixo, e cole-o dentro do seu novo módulo.
  3. Certifique-se de que o MS Access entende o código colado: Compile o código.
  4. Salve o código com o nome que achar melhor, algo como basSearchField.

Para usá-lot, basta que abra a janela "Immediate Windo" (Ctrl+G) e digite:
    ? FindField()

The utility does more than just search for the field's Name:

  • In tables and queries, it searches searches the Caption. The user knows the field by this name, and sometimes Access misidentifies a field based on its caption (if Name AutoCorrect is turned on.)
  • In queries, it checks the SourceName (i.e. the original name of the field in a table) since the field may be aliased.
  • In forms and reports, it searches the Name, ControlSource, and Caption of controls.
  • For reports, it searches the GroupLevels (the Sorting and Grouping pane.)
  • For subforms and subreports, it checks the LinkMasterFields and LinkChildFields.
  • For all object types, it searches the Filter and OrderBy properties, as these cause Access to ask for a parameter.

If you want something more, there are commercial utilities such as Find And Replace (Ricks World), Speed Ferret (Black Moshannon), or Total Access Analyzer (FMS Inc.)



Option Compare Database
Option Explicit

'Purpose: Search your database (tables, queries, forms, reports)
' to find where a particular field name is used.
'Release: April 2007 (a work in progress.)
'Documentation: http://allenbrowne.com/ser-73.html
'Author: Allen Browne (allen@allenbrowne.com)
'Versions: Requires Access 2000 and later.
' For Access 2000, you will need to remove this from the end of several lines:
' , WindowMode:=acHidden

'Usage examples
'==============
' To find where InvoiceID is used in Report1:
' ? FindField("InvoiceID", "Report1")
' To find where ClientID is used in all forms and reports:
' ? FindField("ClientID",,ffoForm + ffoReport)
' To find anywhere EventDate is used:
' ? FindField("EntryDate")

'Summary
'=======
' Tables Searches the Name and Caption of the fields, and the Filter and OrderBy of the table.
' Queries: Searches the Name, SourceName, and Caption of fields; Filter and OrderBy of query.
' Forms: Searches Name, ControlSource, Caption of controls,
' and LinkMasterFields/LinkChildFields of subform controls
' Reports: Searches Name, ControlSoruce, Caption of controls, Control Source of Group Levels,
' and LinkMasterFields/LinkChildFields of subreport controls

'Notes
'=====
' When you type a SQL statement into the RecordSource of a form/report, or the RowSource
' of a combo/listbox, Access creates a saved query with a name prefixed with ~sq_.
' With reports, click Ok if notified the report was set up for another printer.
'Does not search RecordSource of form/report, nor RowSource of combo/list box.
'Does not handle renamed fields that might be under the control of Name AutoCorrect.
'Does not handle query parameters (which are not fields.)

'Bitfield constants: their sum indicates which types of object to search.
Public Enum FindFieldObject
ffoTable = 1 'Search table fields.
ffoQuery = 2 'Search query fields.
ffoForm = 4 'Search form controls and properties.
ffoReport = 8 'Search report controls, properties, and group levels.
ffoAll = 15 'Search all (tables, queries, forms, and reports.)
End Enum

Public Function FindField(strFieldName As String, _
Optional strObjectName As String, _
Optional iObjectTypes As FindFieldObject = ffoAll, _
Optional bExactMatchOnly As Boolean) As Long
On Error GoTo Err_Handler
'Purpose: Search the current database for where a field name is used. MAIN FUNCTION.
'Arguments: strFieldName: the field name to find (or part of field name.)
' strObjectName: Leave blank to search all objects. Only named object if entered.
' iObjectTypes: determines what objects to search for. Sum of the types you want.
' bExactMatchOnly: not matched with wildcards if this is True.
'Return: Number of matches found.
' List of items in the Immediate Window (Ctrl+G.)
'Usage: To search tables and queries for a field named Inactive:
' Call FindField("Inactive", ffoTable + ffoQuery)
Dim db As DAO.Database 'This database
Dim tdf As DAO.TableDef 'Each table
Dim qdf As DAO.QueryDef 'Each query
Dim accObj As AccessObject 'Each form/report.
Dim strDoc As String 'Name of form/report.
Dim strText2Match As String 'strFieldName with wildcards.
Dim bLeaveOpen As Boolean 'Flag to leave the form/report open if it was already open.
Dim lngKt As Long 'Count of matches.

'Initialize
Set db = CurrentDb()
If bExactMatchOnly Then
strText2Match = strFieldName
Else
strText2Match = "*" & strFieldName & "*"
End If

'Search Tables
If (iObjectTypes And ffoTable) <> 0 Then
If strObjectName <> vbNullString Then
'Just one table (if it exists)
If ObjectExists(db.TableDefs, strObjectName) Then
Set tdf = db.TableDefs(strObjectName)
lngKt = lngKt + FindInTableQuery(tdf, strText2Match)
End If
Else
'All tables
For Each tdf In db.TableDefs
lngKt = lngKt + FindInTableQuery(tdf, strText2Match)
Next
End If
End If

'Search Queries
If (iObjectTypes And ffoQuery) <> 0 Then
If strObjectName <> vbNullString Then
'Just one query (if it exists)
If ObjectExists(db.QueryDefs, strObjectName) Then
Set qdf = db.QueryDefs(strObjectName)
lngKt = lngKt + FindInTableQuery(qdf, strText2Match)
End If
Else
'All queries
For Each qdf In db.QueryDefs
lngKt = lngKt + FindInTableQuery(qdf, strText2Match)
Next
End If
End If

'Search Forms.
If (iObjectTypes And ffoForm) <> 0 Then
If strObjectName <> vbNullString Then
'Just one form (if it exists)
If ObjectExists(CurrentProject.AllForms, strObjectName) Then
Set accObj = CurrentProject.AllForms(strObjectName)
strDoc = accObj.Name
bLeaveOpen = accObj.IsLoaded
DoCmd.OpenForm strDoc, acDesign, WindowMode:=acHidden
'Search
lngKt = lngKt + FindInFormReport(Forms(strDoc), strText2Match)
'Close unless already open.
If Not bLeaveOpen Then
DoCmd.Close acForm, strDoc, acSaveNo
End If
End If
Else
'All forms
For Each accObj In CurrentProject.AllForms
strDoc = accObj.Name
bLeaveOpen = accObj.IsLoaded
DoCmd.OpenForm strDoc, acDesign, WindowMode:=acHidden
'Search
lngKt = lngKt + FindInFormReport(Forms(strDoc), strText2Match)
'Close unless already open.
If Not bLeaveOpen Then
DoCmd.Close acForm, strDoc, acSaveNo
End If
Next
End If
End If

'Search Reports.
If (iObjectTypes And ffoReport) <> 0 Then
If strObjectName <> vbNullString Then
'Just one report (if it exists)
If ObjectExists(CurrentProject.AllReports, strObjectName) Then
Set accObj = CurrentProject.AllReports(strObjectName)
strDoc = accObj.Name
bLeaveOpen = accObj.IsLoaded
DoCmd.OpenReport strDoc, acDesign, WindowMode:=acHidden
'Search
lngKt = lngKt + FindInFormReport(Reports(strDoc), strText2Match)
'Check the Group Levels as well.
lngKt = lngKt + FindInGroupLevel(Reports(strDoc), strText2Match)
'Close unless already open.
If Not bLeaveOpen Then
DoCmd.Close acReport, strDoc, acSaveNo
End If
End If
Else
'All reports
For Each accObj In CurrentProject.AllReports
strDoc = accObj.Name
bLeaveOpen = accObj.IsLoaded
DoCmd.OpenReport strDoc, acDesign, WindowMode:=acHidden
'Search
lngKt = lngKt + FindInFormReport(Reports(strDoc), strText2Match)
'Check the Group Levels as well.
lngKt = lngKt + FindInGroupLevel(Reports(strDoc), strText2Match)
'Close unless already open.
If Not bLeaveOpen Then
DoCmd.Close acReport, strDoc, acSaveNo
End If
Next
End If
End If

Exit_Handler:
FindField = lngKt
'Clean up
Set accObj = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set db = Nothing
Exit Function

Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "FindField"
Resume Exit_Handler
End Function

Private Function FindInTableQuery(obj As Object, strText2Match As String) As Long
On Error GoTo Err_Handler
'Purpose: Find fields where the Name, SourceField, or Caption matches the string.
'Arguments: obj = the TableDef or QueryDef to search.
' strText2Match is the text to search for, including any wildcards.
'Return: Count of matches listed.
Dim fld As DAO.Field
Dim lngKt As Long

For Each fld In obj.Fields
'Search the name
If fld.Name Like strText2Match Then
Debug.Print obj.Name & "." & fld.Name
lngKt = lngKt + 1&
'Search the SourceField (for aliased query fields.)
ElseIf fld.SourceField Like strText2Match Then
Debug.Print obj.Name & "." & fld.Name & ".SourceField: " & fld.SourceField
lngKt = lngKt + 1&
'Search the Caption.
ElseIf HasProperty(fld, "Caption") Then
If fld.Properties("Caption") Like strText2Match Then
Debug.Print obj.Name & "." & fld.Name
lngKt = lngKt + 1&
End If
End If
Next
Set fld = Nothing

'Search the Filter and OrderBy properties too.
lngKt = lngKt + FindInProperty(obj, "Filter", strText2Match)
lngKt = lngKt + FindInProperty(obj, "OrderBy", strText2Match)

Exit_Handler:
FindInTableQuery = lngKt
Exit Function

Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "FindInTableQuery"
Resume Exit_Handler
End Function

Private Function FindInFormReport(obj As Object, strText2Match As String) As Long
On Error GoTo Err_Handler
'Purpose: Search for controls where the Name, Control Source, or Caption matches the string.
'Arguments: obj = a reference to the form or report.
' strText2Match is the text to search for, including any wildcards.
'Return: Count of matches listed.
Dim ctl As Control 'Each control on the form/report.
Dim lngKt As Long 'Count of matches.

For Each ctl In obj.Controls
'Search the name
If ctl.Name Like strText2Match Then
Debug.Print obj.Name & "." & ctl.Name & " (" & ControlTypeName(ctl.ControlType) & ")"
lngKt = lngKt + 1&
'LinkMasterFields/LinkChildFields for subform/subreport.
ElseIf ctl.ControlType = acSubform Then
If ctl.LinkMasterFields Like strText2Match Then
Debug.Print obj.Name & "." & ctl.Name & ".LinkMasterFields: " & ctl.LinkMasterFields
lngKt = lngKt + 1&
End If
If ctl.LinkChildFields Like strText2Match Then
Debug.Print obj.Name & "." & ctl.Name & ".LinkChildFields: " & ctl.LinkChildFields
lngKt = lngKt + 1&
End If
'Search the Control Source
ElseIf HasProperty(ctl, "ControlSource") Then
If ctl.ControlSource Like strText2Match Then
Debug.Print obj.Name & "." & ctl.Name & ".ControlSource: " & ctl.ControlSource
lngKt = lngKt + 1&
End If
'Search the caption (less any hotkey.)
ElseIf HasProperty(ctl, "Caption") Then
If ctl.Caption Like Replace(strText2Match, "&", vbNullString) Then
Debug.Print obj.Name & "." & ctl.Name & ".Caption: " & ctl.Caption
lngKt = lngKt + 1&
End If
End If
Next

'Search the Filter and OrderBy properties too.
lngKt = lngKt + FindInProperty(obj, "Filter", strText2Match)
lngKt = lngKt + FindInProperty(obj, "OrderBy", strText2Match)

Exit_Handler:
FindInFormReport = lngKt
Set ctl = Nothing
Exit Function

Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "FindInFormReport"
Resume Exit_Handler
End Function

Private Function FindInProperty(obj As Object, strPropName As String, strText2Match As String) As Long
On Error GoTo Err_Handler
'Purpose: Search the Filter an OrderBy properties of the object for the string.
'Arguments: obj = a reference to TableDef, QueryDef, Form, or Report.
' strPropName = name of property to search, e.g. "Filter" or "OrderBy".
' strText2Match = the text to search for, including any wildcards.
'Return: 1 if found; 0 if not.

If obj.Properties(strPropName) Like strText2Match Then
Debug.Print obj.Name & "." & strPropName & ": " & obj.Properties(strPropName)
FindInProperty = 1&
End If

Exit_Handler:
Exit Function

Err_Handler:
Select Case Err.Number
Case 438&, 3270& 'Property doesn't apply; Property not found.
'do nothing
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, ".FindInProperty"
End Select
Resume Exit_Handler
End Function

Private Function FindInGroupLevel(rpt As Report, strText2Match As String) As Long
On Error GoTo Err_Handler
'Purpose: Search the Control Source of each Group Level of a report.
'Arguments: rpt = a reference to the report.
' strText2Match is the text to search for, including any wildcards.
'Return: Count of matches listed.
'Note: Assumes the report is open.
Dim i As Integer 'Loop controller (group levels.)
Dim lngKt As Long 'Count of matches

Do 'Loop will terminate by error when there are no more group levels.
If rpt.GroupLevel(i).ControlSource Like strText2Match Then
Debug.Print rpt.Name & ".GroupLevel(" & i & "): " & rpt.GroupLevel(i).ControlSource
lngKt = lngKt + 1&
End If
i = i + 1
Loop

Exit_Handler:
FindInGroupLevel = lngKt
Exit Function

Err_Handler:
If Err.Number <> 2464& Then 'No more group levels.
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "FindInGroupLevel()"
End If
Resume Exit_Handler
End Function

Public Function ObjectExists(obj As Object, strObjectName As String) As Boolean
'Purpose: Return True if the named object exists.
'Examples: If ObjectExists(CurrentDb.TableDefs, "Table1") Then
' If ObjectExists(CurrentProject.AllForms, "Form1") Then
Dim varDummy As Variant
On Error Resume Next
varDummy = obj.Item(strObjectName).Name
ObjectExists = (Err.Number = 0&)
End Function

Public Function ControlTypeName(lngControlType As AcControlType) As String
On Error GoTo Err_Handler
'Purpose: Return the name of the ControlType.
'Argument: A Long Integer that is one of the acControlType constants.
'Return: A string describing the type of control.
'Note: The ControlType is a Byte, but the constants are Long.
Dim strReturn As String

Select Case lngControlType
Case acBoundObjectFrame: strReturn = "Bound Object Frame"
Case acCheckBox: strReturn = "Check Box"
Case acComboBox: strReturn = "Combo Box"
Case acCommandButton: strReturn = "Command Button"
Case acCustomControl: strReturn = "Custom Control"
Case acImage: strReturn = "Image"
Case acLabel: strReturn = "Label"
Case acLine: strReturn = "Line"
Case acListBox: strReturn = "List Box"
Case acObjectFrame: strReturn = "Object Frame"
Case acOptionButton: strReturn = "Object Button"
Case acOptionGroup: strReturn = "Option Group"
Case acPage: strReturn = "Page (of Tab)"
Case acPageBreak: strReturn = "Page Break"
Case acRectangle: strReturn = "Rectangle"
Case acSubform: strReturn = "Subform/Subrport"
Case acTabCtl: strReturn = "Tab Control"
Case acTextBox: strReturn = "Text Box"
Case acToggleButton: strReturn = "Toggle Button"
Case Else: strReturn = "Unknown: type" & lngControlType
End Select

ControlTypeName = strReturn

Exit_Handler:
Exit Function

Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ControlTypeName()"
Resume Exit_Handler
End Function

Public Function HasProperty(obj As Object, strPropName As String) As Boolean
'Purpose: Return true if the object has the property.
Dim varDummy As Variant

On Error Resume Next
varDummy = obj.Properties(strPropName)
HasProperty = (Err.Number = 0)
End Function




André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/


LinkWithinBrazilVBAAccessSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine