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.
this is to Edit Lines
'Microsoft Visual Basic for Applications Extensibility 5.3 Refrence is required
This to Save Ribbon Data
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