Custom Ribbon controls lost Values

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
Greetings
I use this to change My custom Ribbon Controls variable Values By replacing VBA Function and it is OK edit happens , but when buttons call data gives 0, already I had used function to save Ribbon it OK with Faults restore Data but with changing and replacing Lines not Work.

VBA Code:
Sub Test()
        Fnd = "": Rplc = ""
        Fnd = "året = ": Rplc = 2024
       VBRplcr "RibKalendar", Fnd, Rplc

End Sub


Sub RibKalendar(ribbon As IRibbonUI)
 Dim lngRibPtr As Long
Set RibKalendarUI = ribbon
året = 2020
TglBtnPrss = True
Strtvckn = 2: SV = Strtvckn
Vckdg = 12
VD = Vckdg

Vckrd = 2
VR = Vckrd
StrtRd = 2
SR = StrtRd
StrtKlmnn = 2
SK = StrtKlmnn
saveGlobal RibKalendarUI, "RibbonPtr"
End Sub

this is to Edit Lines
'Microsoft Visual Basic for Applications Extensibility 5.3 Refrence is required
VBA Code:
    Sub VBRplcr(PrcName As String, Fnd As String, Rplc As String)
    
    
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim ThisLine As String
    Dim TbFnd As String, TBRplc As String
    Dim N As Long
    Dim ProcStrLn As Long, ProcAcStrLn As Long, ProcCntLn As Long, PrcCnountLine As Long
        Set VBProj = ThisWorkbook.VBProject
        For Each VBComp In VBProj.VBComponents
            With VBComp
                If .Type = vbext_ct_StdModule Then ' Withen Standr Module
                    With .CodeModule
                        If InStr(1, .Lines(1, .CountOfLines), PrcName) > 0 Then
                            On Error Resume Next
                            ProcStrLn = .ProcStartLine(PrcName, vbext_pk_Proc) ' Procedure Start Line
                            ProcAcStrLn = .ProcBodyLine(PrcName, vbext_pk_Proc) ' Actually Procedure Start Line
                            ProcCntLn = .ProcCountLines(PrcName, vbext_pk_Proc)
                            PrcCnountLine = ProcCntLn - (ProcAcStrLn - ProcStrLn)
                            If PrcName = .ProcOfLine(ProcAcStrLn, vbext_pk_Proc) Then 'Get Proce Name
                                For N = (ProcAcStrLn + 1) To (ProcAcStrLn + PrcCnountLine - 1) ' Add 1 to avoid chane Procedure Name and -1 to avoid replace Next Procedure
                                   ThisLine = .Lines(N, 1)
                                  
                                     If InStr(1, ThisLine, Trim(Fnd), vbTextCompare) <> 0 Then
                                     TbFnd = Left(ThisLine, Len(Split(ThisLine, Fnd)(0) & Fnd) + Len(Rplc))
                                     TBRplc = Split(ThisLine, Fnd)(0) & Fnd & Rplc
                                   ' MsgBox Split(ThisLine, Fnd)(0) & Fnd
                                       .ReplaceLine N, Replace(TbFnd, TbFnd, TBRplc)
                                      
                                    Exit For
                                    End If
                                Next N
                            
                            End If ''''  If PrcName = .ProcOfLine
                            Exit For ''''''''''''''''''''''''''''''''Job Completed
                            On Error GoTo 0
                        End If '''If InStr(1, .Lines(1, .CountOfLines), PrcName) > 0 Then
                    End With ' .CodeModule
                End If ' .Type
            End With ' VBComp
        Next ' In VBProj.VBComponents
        'Set VBProj = Nothing
        'Fnd = "": Rplc = ""
        
    End Sub

This to Save Ribbon Data
Code:
#If VBA7 Then
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (destination As Any, source As Any, ByVal length As LongPtr)''' '''or length as long
#Else
Public Declare Sub CopyMemory Lib "kernel32" Alias    "RtlMoveMemory" (destination As Any, source As Any,    ByVal length As Long)
#End If
Public Sub saveGlobal(Glbl As Object, GlblName As String)
    #If VBA7 Then
    Dim lngRibPtr As LongPtr
    #Else
    Dim lngRibPtr As Long
    #End If
    lngRibPtr = ObjPtr(Glbl)
    With ThisWorkbook
    On Error Resume Next
    .Names(GlblName).Delete
    On Error GoTo 0
    .Names.Add GlblName, lngRibPtr
    .Saved = True
       End With
    End Sub

Function GetGlobal(GlblName As String) As Object
    #If VBA7 Then
    Dim X As LongPtr
    X = CLngPtr(Mid(ThisWorkbook.Names(GlblName).RefersTo, 2))
    #Else
    Dim X As Long
    X = CLng(Mid(ThisWorkbook.Names(GlblName).RefersTo, 2))
    #End If
    Dim objRibbon As Object
    CopyMemory objRibbon, X, Len(X)
    Set GetGlobal = objRibbon
    End Function
 

Some videos you may like

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Watch MrExcel Video

Forum statistics

Threads
1,123,230
Messages
5,600,424
Members
414,383
Latest member
kevinlarey

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top