Miałem problem z błędnie działającym kodem VBA. Problem niby nie wielki bo trzeba było zlikwidować 1 niepotrzebną linijkę kodu. Jednak trzeba to zrobić u kilkuset użytkowników w arkuszu który miał już powpisywane dane. Wysłanie nowego nie bardzo wchodziło w grę. Dodatkowo projekt był zabezpieczony hasłem.
Jednak przemyślność ludzka nie zna granic i dzięki podpowiedziom z tej, tej i tej strony udało mi się stworzyć arkusz który automatycznie zmieniał zawartość kodu!
Kod jest dość „brudny” ale skutecznie działający.
Istotne jest aby zabezpieczeniach makr zaznaczyć opcję
„Ufaj dostępowi do programu Visual Basic Project” w zakładce „Zaufani wydawcy” (Excel 2003)
i w „Tools” > „References…”
Dodać „Microsoft Visual Basic For Applications Extensibility 5.3.”
Option Explicit
'
Private Const vbext_ct_ActiveXDesigner = 11
Private Const vbext_ct_ClassModule = 2
Private Const vbext_ct_Document = 100 '(&H64)
Private Const vbext_ct_MSForm = 3
Private Const vbext_ct_StdModule = 1
'
Sub start()
Dim i As Integer 'counter of files
Dim GarageFile As String
Dim FDir, all As String
'
'wybór pliku
all="c:\jakis katalog\arkusz.xls"
Workbooks.Open Filename:=all
GarageFile = StripPathString(all, False)
'Ten wpis jest istotny jeśli wybieramy plik formatką
UnprotectVBProject Workbooks(GarageFile), "test123"
DoEvents
With Workbooks(GarageFile)
.VBProject.VBComponents.Add 1
End With
' Tu jest wywołanie zmiany linii
Call ModuleFindAndReplace("wynik = zapis(6, """")", "' zmiana lini !!!!")
'I po problemie
ActiveWorkbook.Close SaveChanges:=True
' tadam!
End Sub
'
' funkcja odblokowanie projektu nie trzeba go później zabezpieczać
Sub UnprotectVBProject(WB As Workbook, ByVal Password As String)
Dim vbProj As Object
'
Set vbProj = WB.VBProject
'
'can't do it if already unlocked!
If vbProj.Protection <> 1 Then Exit Sub
'
Set Application.VBE.ActiveVBProject = vbProj
'
' now use lovely SendKeys to quote the project password
SendKeys Password & "~~"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
End Sub
'
'
'
Public Function ModuleFindAndReplace(FindText As String, ReplaceText As String, Optional DeclarationsText As String) As Boolean
Dim objComponent As Object
Dim strTemp As String
Dim lngStartRow As Long, lngStartCol As Long, lngEndRow As Long, lngEndCol As Long
Dim i As Integer
'tu jest istotna zmiana od przykładów ze stron
'wybieram drugi projekt (lub kolejny) by nie szukać w samym sobie!!!!
With Application.VBE.VBProjects.Item(2)
For Each objComponent In .VBComponents
With objComponent.CodeModule
' ilość linii w kodzie i nazwa modułu lub formatki!
If .CountOfLines > 0 And .Name = "podsumowanie" Then
lngStartRow = 1: lngStartCol = 1
'Setting to -1 signifies last row and column
lngEndRow = -1: lngEndCol = -1
Do While .Find(FindText, lngStartRow, lngStartCol, -lngEndRow, -lngEndCol, False, False)
strTemp = .Lines(lngStartRow, 1)
strTemp = Replace(strTemp, FindText, ReplaceText)
Debug.Print objComponent.Name & " " & objComponent.Type & " start: " & lngStartRow & "," & lngStartCol & " End: " & lngEndRow & "," & lngEndCol & vbCrLf & " Before: " & .Lines(lngStartRow, 1) & vbCrLf & " After: " & strTemp
.ReplaceLine lngStartRow, strTemp
lngStartRow = lngStartRow + 1
lngStartCol = 1
Loop
End If
End With
Next objComponent
End With
Set objComponent = Nothing
End Function
'
' Bonusowa funkcja która zwraca ze ścieżki samą nazwę pliku
' Znaleziona gdzieś w internecie
'
Function StripPathString(ByVal Path As String, ByVal StripFileName As Boolean) As String
Dim X As Integer, Ct As Integer, Y As Integer
StripPathString = Path
X = InStr(Path, "\")
Do While X
Ct = X
X = InStr(Ct + 1, Path, "\")
Loop
' tu wprowadziłem zmiany
If Ct > 0 Then
Select Case StripFileName
Case False
StripPathString = Mid(Path, Ct + 1)
Case True
Y = InStr(Path, Mid(Path, Ct + 1))
StripPathString = Mid(Path, 1, Y - 1)
End Select
Else
StripPathString = ""
End If
End Function
Cała zabawa zaoszczędziła mi mnóstwo problemów.