none
Ribbon personalizada não carrega RRS feed

  • Pergunta

  • Caros,

    possuo funções que carregam Ribbon personalisada (ver abaixo) e funcionam muito bem em Access de 32bits e quando é 64bits eles não carregam e retornam a mensagem: "Não pode executar a macro ou função de retorno de chamada 'fncRibbon'."

    Não imagino por onde posso começar a resolver essa questão, pesquisando mas sem encontrar algo semelhante para ajudar a resolver.

    Conto com a ajuda do grupo.

    Grato,
    Raimundo
    Attribute VB_Name = "basribbon"
    Option Compare Database
    Public objRibbon As IRibbonUI
    Public tipoFeedback As String
    Public strFeedback As String
    
    Public Sub fncRibbon(ribbon As IRibbonUI)
    On Error Resume Next
    '-------------------------------------------------------------
    'objRibbon servirá para realizarmos alterações
    'na ribbon em tempo de execução
    '------------------------------------------------------------
    Set objRibbon = ribbon
    End Sub
    
    Public Function fncCarregaRibbon()
    Dim rsRib As DAO.Recordset
    On Error GoTo TrataErro
    '--------------------------------------------------------------------------------
    'Esta função carrega as ribbons armazenadas na tabela tblRibbons,
    'que deve ser chamada pela macro autoexec
    '
    'Crie a macro autoexec, selecione a açõa EXECUTARCÓDIGO
    'e escreva o nome da função no argumento: fncCarregaRibbon()
    '---------------------------------------------------------------------------------
    Set rsRib = CurrentDb.OpenRecordset("tblRibbons", dbOpenDynaset)
    Do While Not rsRib.EOF
        Application.LoadCustomUI rsRib!RibbonName, rsRib!RibbonXml
        rsRib.MoveNext
    Loop
    rsRib.Close
    Set rsRib = Nothing
    sair:
        Exit Function
    TrataErro:
        Select Case Err.Number
            Case 3078
                MsgBox "Tabela não encontrada...", vbInformation, "Aviso"
            Case Else
                MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", _
                Err.HelpFile, Err.HelpContext
        End Select
        Resume sair:
    End Function
    
    Public Function fncCarregaRibbonXml()
    Dim F           As Long
    Dim strText     As String
    Dim strOut      As String
    Dim rsXml As DAO.Recordset
    On Error GoTo TrataErro
    
    '-------------------------------------------------------------------------------------
    'Esta função carrega as ribbons de arquivos XML,
    'que deve ser chamada pela macro autoexec
    '
    'Crie a macro AutoExec, selecione a açõa EXECUTARCÓDIGO
    'e escreva o nome da função no argumento: fncCarregaRibbonXml()
    '
    'Crie uma tabela de nome tblRibbonsXml com os campos:
    'RibbonName - Este campo você armazena o nome que deseja dar a ribbon
    'RibbonXml - Este campo você informa o nome do arquivo Xml
    '
    'fncOrigem informa o caminho do seu banco de dados
    'Este exemplo pressupõe que você esteja com os arquivos XML no mesmo local do seu BD
    '--------------------------------------------------------------------------------------
    F = FreeFile
    Set rsXml = CurrentDb.OpenRecordset("tblRibbonsXml")
    Do While Not rsXml.EOF
        Open CurrentProject.Path & "\" & rsXml!RibbonXml For Input As F
    
        Do While Not EOF(F)
            Line Input #F, strText
            strOut = strOut & strText & vbCrLf
        Loop
    
        Application.LoadCustomUI rsXml!RibbonName, strOut
        strOut = ""
        strText = ""
        F = FreeFile
        rsXml.MoveNext
    Loop
    
    sair:
        Exit Function
    TrataErro:
        Select Case Err.Number
            Case 3078
                MsgBox "Tabela não encontrada...", vbInformation, "Aviso"
            Case Else
                MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", _
                Err.HelpFile, Err.HelpContext
        End Select
        Resume sair:
    End Function
    
    Public Sub fncOnAction(control As IRibbonControl)
    On Error GoTo TrataErro
    Select Case control.ID
    
        Case "cmdCadastroTermos"
            DoCmd.OpenForm "frmCadastroTermos"
        
        Case "cmdTxtNomes"
            Importatxts
        
        Case "cmdGeraTermos"
            DoCmd.OpenForm "frmTermosPorCarteira"
        
        Case "cmdMenuCadastroAtividadesFechamentoDiarias"
            DoCmd.OpenForm "frmAtividadesFechamento"
        
        Case "cmdFechaMovto"
            DoCmd.OpenForm "frmFechamento"
        
        Case "cmdMenuCadastroAtividadesDiarias"
            DoCmd.OpenForm "frmRotinasDiarias"
        
        Case "cmdMenuAtividades"
            DoCmd.OpenForm "frmAtividades"
        
        Case "cmdMenuCadastroUser"
            DoCmd.OpenForm "frmCadastro"
        
        Case "cmdMenuCadastroAtividadesClientes"
            DoCmd.OpenForm "frmClienteseAtividades"
        
        Case "cmdMenuLogoffs"
            DoCmd.Close acForm, "frmPrincipal"
            DoCmd.OpenForm "frmLogin"
            Eventos = "Efetuou logoff"
            Log
        
        Case "cmdPeSair"
        Eventos = "Saiu do sistema"
        Log
        DoCmd.Quit acExit
        
        Case "cmdMenuArquivoLog"
         DoCmd.OpenForm "frmArquivoDeLog"
        
        Case "cmdPeSairFl"
        Eventos = "Saiu do sistema"
        Log
        DoCmd.Quit acExit
        
        Case "cmdMenuLogoffsFl"
            DoCmd.Close acForm, "frmPrincipal"
            DoCmd.OpenForm "frmLogin"
            Eventos = "Efetuou logoff"
            Log
         
         Case "cmdEnviaFeedback"
         ID = DCount("*", "tblFeedback") + 1
         DoCmd.SetWarnings False
         If IsNull(tipoFeedback) Or tipoFeedback = "" Then
         tipoFeedback = "Comentários"
         End If
         DoCmd.RunSQL "INSERT INTO tblFeedback ( ID, [User], Tipo, Menssagem, Data, Para ) SELECT " & ID & " AS ID, '" & User & "' AS [User], '" & tipoFeedback & "' AS Tipo, '" & strFeedback & "' AS Menssagem, Now() AS Data, 'Ricardo Correa' AS Para;"
         DoCmd.SetWarnings True
         MsgBox "Enviado feedback " & tipoFeedback & " que é o seguinte: " & strFeedback, vbInformation, "Feedback enviado com sucoesso."
         
         Case "cmdMenuAtividadesFl"
         DoCmd.OpenForm "frmAtividadesFallowUp"
         
         Case "cmdRelatorios"
         DoCmd.OpenForm "frmRelatoriosAtual"
         
         Case "cmdPermissao"
         DoCmd.SetWarnings False
         DoCmd.RunSQL "INSERT INTO tblUsersLocal ( [User], Senha, Perfil, Gestao, [Fallow Up], Area, Email, SAlmoco, Ralmoco, [Data Cadastro], [Data Alteracao], GEAtividades, GETermos, GEMovimento, GERelatorios, GEEmails, GECadastro, GEAquivoDeLog, GEAtualizacao, ROBO ) SELECT tblUsers.User, tblUsers.Senha, tblUsers.Perfil, tblUsers.Gestao, tblUsers.[Fallow Up], tblUsers.Area, tblUsers.Email, tblUsers.SAlmoco, tblUsers.Ralmoco, tblUsers.[Data Cadastro], tblUsers.[Data Alteracao], tblUsers.GEAtividades, tblUsers.GETermos, tblUsers.GEMovimento, tblUsers.GERelatorios, tblUsers.GEEmails, tblUsers.GECadastro, tblUsers.GEAquivoDeLog, tblUsers.GEAtualizacao, tblUsers.ROBO FROM tblUsers;"
         DoCmd.SetWarnings True
         DoCmd.OpenForm "frmAcessosUsuario"
         
         Case "cmdMenuCadastroClientes"
         DoCmd.OpenForm "frmClientesCadastro"
         
         Case "cmdParametrosEEnvios"
         DoCmd.OpenForm "frmAssuntoECorpo"
         
         Case "cmdTxtNomesEEmails"
         DoCmd.OpenForm "frmEnvio"
        
         Case "cmdRemessa"
         DoCmd.OpenForm "frmRemessa"
         
         Case "cmdExclusaoTermos"
         DoCmd.OpenForm "frmExclusaoTermos"
         
         Case "cmdAlternaFase"
         DoCmd.OpenForm "frmMudaFaseTermos"
         
         Case "cmdParametrosAtual"
         DoCmd.OpenForm "frmParametros"
         
         Case "cmdAlteraBases"
         AtualizaBase
         Form_frmPrincipal.txtMovimento = DLookup("Movimento", "tblMovimento", "[FlagFechamento] = false")
         AtivPendentes
         
         Case "cmdPendencias"
         DoCmd.OpenForm "frmSlaAtividades"
             
         Case "cmdAtividadesPorPessoa"
         DoCmd.OpenForm "frmResumoDoDia"
         
         Case "cmdArrecadacao"
         DoCmd.OpenForm "frmArrecadacao"
         
         Case Else
         MsgBox "Esta parte do sistema ainda esta em construção.", vbInformation, "Aviso"
    End Select
    sair:
        Exit Sub
    TrataErro:
        MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
        Resume sair:
    End Sub
    
    Public Function fncAbrirObjeto(nomeObjeto As String, Optional tipoObjeto As Byte = 4)
    On Error GoTo TrataErro
    Select Case tipoObjeto
        Case 1  'formulário
            DoCmd.OpenForm nomeObjeto
        Case 2 'relatório
            DoCmd.OpenReport nomeObjeto, acViewPreview
        Case 3 ' consulta
            DoCmd.OpenQuery nomeObjeto
        Case Else
            MsgBox "selecione o tipo de objeto correto." & vbCrLf & vbCrLf & "1 - Formulário" & vbCrLf & "2 - Relatório" & vbCrLf & "3 - Consulta", vbInformation, "Aviso"
    End Select
    sair:
        Exit Function
    TrataErro:
        MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
        Resume sair:
    End Function
    
    Public Sub fncLoadImage(imageId As String, ByRef Image)
    On Error GoTo TrataErro
    Dim Caminho As String
    Caminho = CurrentProject.Path & "\imagens\"
    If InStr(imageId, ".png") > 0 Or InStr(imageId, ".ico") > 0 Then
        If Len(Dir(Caminho & imageId)) = 0 Then
            MsgBox "Imagem " & imageId & " não encontrada no caminho indicado...", vbInformation, "Aviso"
            Exit Sub
        Else
            Set Image = LoadImage(Caminho & imageId)
        End If
    Else
        Set Image = LoadPicture(Caminho & imageId)
    End If
    sair:
        Exit Sub
    TrataErro:
        Select Case Err.Number
            Case 2220
                MsgBox "Imagem " & imageId & " não encontrada no caminho indicado...", vbInformation, "Aviso"
            Case Else
                MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", _
                Err.HelpFile, Err.HelpContext
        End Select
        Resume sair:
    End Sub
    
    Sub fncOnChange(control As IRibbonControl, strText As String)
    On Error GoTo TrataErro
        Select Case control.ID
            Case "txtFeedback10"
                strFeedback = strText
            Case Else
                MsgBox "Valor do campo:  " & strText, vbInformation, "Aviso"
        End Select
    sair:
        Exit Sub
    TrataErro:
        MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
        Resume sair:
    End Sub
    
    Public Sub fncOnShowBackstage(contextObject As Object)
    objRibbon.Invalidate
    End Sub
    
    Public Sub fncTipoFeedback(control As IRibbonControl, strItemID, lngIndex)
    Select Case lngIndex
        Case 0: tipoFeedback = "Comentários"
        Case 1: tipoFeedback = "Sugestões"
        Case 2: tipoFeedback = "Problemas"
    End Select
    End Sub
    
    

    quarta-feira, 13 de novembro de 2013 10:23

Todas as Respostas