Mia\u0142em problem z b\u0142\u0119dnie dzia\u0142aj\u0105cym kodem VBA. Problem niby nie wielki bo trzeba by\u0142o zlikwidowa\u0107 1 niepotrzebn\u0105 linijk\u0119 kodu. Jednak trzeba to zrobi\u0107 u kilkuset u\u017cytkownik\u00f3w w arkuszu kt\u00f3ry mia\u0142 ju\u017c powpisywane dane. Wys\u0142anie nowego nie bardzo wchodzi\u0142o w gr\u0119. Dodatkowo projekt by\u0142 zabezpieczony has\u0142em.<\/p>\n
Jednak przemy\u015blno\u015b\u0107 ludzka nie zna granic i dzi\u0119ki podpowiedziom z tej<\/a>, tej<\/a> i tej<\/a> strony uda\u0142o mi si\u0119 stworzy\u0107 arkusz kt\u00f3ry automatycznie zmienia\u0142 zawarto\u015b\u0107 kodu!<\/p>\n Kod jest do\u015b\u0107 „brudny” ale skutecznie dzia\u0142aj\u0105cy. Ca\u0142a zabawa zaoszcz\u0119dzi\u0142a mi mn\u00f3stwo problem\u00f3w.<\/p>\n","protected":false},"excerpt":{"rendered":" Mia\u0142em problem z b\u0142\u0119dnie dzia\u0142aj\u0105cym kodem VBA. Problem niby nie wielki bo trzeba by\u0142o zlikwidowa\u0107 1 niepotrzebn\u0105 linijk\u0119 kodu. Jednak trzeba to zrobi\u0107 u kilkuset u\u017cytkownik\u00f3w w arkuszu kt\u00f3ry mia\u0142 ju\u017c powpisywane dane. Wys\u0142anie nowego nie bardzo wchodzi\u0142o w gr\u0119. Dodatkowo projekt by\u0142 zabezpieczony has\u0142em. Jednak przemy\u015blno\u015b\u0107 ludzka nie zna granic i dzi\u0119ki podpowiedziom z … Czytaj dalej VBA zmieniaj\u0105cy VBA<\/span>
\nIstotne jest aby zabezpieczeniach makr zaznaczy\u0107 opcj\u0119
\n„Ufaj dost\u0119powi do programu Visual Basic Project” w zak\u0142adce „Zaufani wydawcy” (Excel 2003)
\ni w „Tools” > „References…”
\nDoda\u0107 „Microsoft Visual Basic For Applications Extensibility 5.3.”<\/p>\n
\nOption Explicit
\n'
\nPrivate Const vbext_ct_ActiveXDesigner = 11
\nPrivate Const vbext_ct_ClassModule = 2
\nPrivate Const vbext_ct_Document = 100 '(&H64)
\nPrivate Const vbext_ct_MSForm = 3
\nPrivate Const vbext_ct_StdModule = 1
\n'
\nSub start()
\nDim i As Integer 'counter of files
\nDim GarageFile As String
\nDim FDir, all As String
\n'
\n'wyb\u00f3r pliku
\nall=\"c:\\jakis katalog\\arkusz.xls\"
\nWorkbooks.Open Filename:=all
\nGarageFile = StripPathString(all, False)
\n'Ten wpis jest istotny je\u015bli wybieramy plik formatk\u0105
\nUnprotectVBProject Workbooks(GarageFile), \"test123\"
\nDoEvents
\n With Workbooks(GarageFile)
\n .VBProject.VBComponents.Add 1
\n End With
\n' Tu jest wywo\u0142anie zmiany linii
\nCall ModuleFindAndReplace(\"wynik = zapis(6, \"\"\"\")\", \"' zmiana lini !!!!\")
\n'I po problemie
\nActiveWorkbook.Close SaveChanges:=True
\n' tadam!
\nEnd Sub
\n'
\n' funkcja odblokowanie projektu nie trzeba go p\u00f3\u017aniej zabezpiecza\u0107
\nSub UnprotectVBProject(WB As Workbook, ByVal Password As String)
\nDim vbProj As Object
\n'
\n Set vbProj = WB.VBProject
\n'
\n 'can't do it if already unlocked!
\n If vbProj.Protection <> 1 Then Exit Sub
\n'
\n Set Application.VBE.ActiveVBProject = vbProj
\n'
\n ' now use lovely SendKeys to quote the project password
\n SendKeys Password & \"~~\"
\n Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
\nEnd Sub
\n'
\n'
\n'
\nPublic Function ModuleFindAndReplace(FindText As String, ReplaceText As String, Optional DeclarationsText As String) As Boolean
\n Dim objComponent As Object
\n Dim strTemp As String
\n Dim lngStartRow As Long, lngStartCol As Long, lngEndRow As Long, lngEndCol As Long
\n Dim i As Integer
\n 'tu jest istotna zmiana od przyk\u0142ad\u00f3w ze stron
\n 'wybieram drugi projekt (lub kolejny) by nie szuka\u0107 w samym sobie!!!!
\n With Application.VBE.VBProjects.Item(2)
\n For Each objComponent In .VBComponents
\n With objComponent.CodeModule
\n ' ilo\u015b\u0107 linii w kodzie i nazwa modu\u0142u lub formatki!
\n If .CountOfLines > 0 And .Name = \"podsumowanie\" Then
\n lngStartRow = 1: lngStartCol = 1
\n 'Setting to -1 signifies last row and column
\n lngEndRow = -1: lngEndCol = -1
\n Do While .Find(FindText, lngStartRow, lngStartCol, -lngEndRow, -lngEndCol, False, False)
\n strTemp = .Lines(lngStartRow, 1)
\n strTemp = Replace(strTemp, FindText, ReplaceText)
\n Debug.Print objComponent.Name & \" \" & objComponent.Type & \" start: \" & lngStartRow & \",\" & lngStartCol & \" End: \" & lngEndRow & \",\" & lngEndCol & vbCrLf & \" Before: \" & .Lines(lngStartRow, 1) & vbCrLf & \" After: \" & strTemp
\n .ReplaceLine lngStartRow, strTemp
\n lngStartRow = lngStartRow + 1
\n lngStartCol = 1
\n Loop
\n End If
\n End With
\n Next objComponent
\n End With
\n Set objComponent = Nothing
\nEnd Function
\n'
\n' Bonusowa funkcja kt\u00f3ra zwraca ze \u015bcie\u017cki sam\u0105 nazw\u0119 pliku
\n' Znaleziona gdzie\u015b w internecie
\n'
\nFunction StripPathString(ByVal Path As String, ByVal StripFileName As Boolean) As String
\nDim X As Integer, Ct As Integer, Y As Integer
\nStripPathString = Path
\nX = InStr(Path, \"\\\")
\nDo While X
\nCt = X
\nX = InStr(Ct + 1, Path, \"\\\")
\nLoop
\n' tu wprowadzi\u0142em zmiany
\nIf Ct > 0 Then
\nSelect Case StripFileName
\nCase False
\nStripPathString = Mid(Path, Ct + 1)
\nCase True
\nY = InStr(Path, Mid(Path, Ct + 1))
\nStripPathString = Mid(Path, 1, Y - 1)
\nEnd Select
\nElse
\nStripPathString = \"\"
\nEnd If
\nEnd Function
\n<\/code> <\/p>\n