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
