InsertLines and AddFromString crash excel

[Chip R.]

I am trying to update ~1500 old workbooks with new code. I have a
spreadsheet, ImportExport, with 13 vbext_ct_StdModule that I want to
import into the old files. It also has another standard module that
contains all of the code for the importexport routine. There are also
two text files that contain code to import into a userform and the
thisworkbook module.

Basically, the program loops through all files in a directory and all
of its subdirectories. If a spreadsheet is of the type that needs
updating, the string "version:" is in a particular cell. If the
version number next to that cell is too old, I simply pastespecial as
values the whole sheet. If it is new enough to be updated, I delete
most of the VBA code in the book, then import the vbext_ct_StdModules,
and insert the code from the two text files to the two places they
have to go. I save the workbooks and close them. Many thanks to Chip
Pearson (great name, Chip <g>) for his excellent website, where I've
got a good portion of my code here from. I run the code from
Tools->Macro->Macros.

However, everytime I use InserLines for the userform or for the
Thisworkbook module, it crashes excel. A GPF or something with the
"send error to microsoft?" window pops up. Addfromstring seems to do
similarly. I've read some other posts related to this, but I haven't
seen any good definitive answer. And this code (not exactly, I forgot
what I had done to make it work, but only because I really didn't do
anything) was working and had gotten through 1000 or so workbooks the
other day. All of a sudden it started working, and working well.
Then, all of a sudden it stopped. It works on single workbooks, but I
don't want to run this 1500 times. And it crashes on the 1st or 2nd
or 3rd spreadsheet, when I run the whole thing.

Lastly, I'm sorry for the really long post, but again, this error
seems so flaky that I figured I'd give you everything I could, rather
than give you less that what you need to solve the problem. ANY help
would be hugely appreciated. I seem to be at quite the impasse here.

-Chip


My code:


Option Compare Text
Public strTHISWORKBOOK As String
Public strFRMTAKEOFFCREATE As String


Sub DoEverything(WB As Workbook)
DeleteVBACodeModules WB
CopyAllModules WB
AddCodeModule WB, strTHISWORKBOOK, "ThisWorkbook"
AddCodeModule WB, strFRMTAKEOFFCREATE, "frmTakeoffCreate"
End Sub


Sub DeleteVBACodeModules(WB As Workbook)
Dim VBComp As VBIDE.VBComponent
Dim VBComps As VBIDE.VBComponents
Set VBComps = WB.VBProject.VBComponents
For Each VBComp In VBComps
If VBComp.Type = vbext_ct_StdModule Then
VBComps.Remove VBComp
ElseIf VBComp.Name = "ThisWorkbook" Or VBComp.Name =
"frmTakeoffCreate" Then
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
End If
Next VBComp
End Sub



Sub CopyAllModules(WB As Workbook)
Dim FName As String
Dim VBComp As VBIDE.VBComponent
With ThisWorkbook
FName = .Path & "\code.txt"
If Dir(FName) <> "" Then
Kill FName
End If
For Each VBComp In .VBProject.VBComponents
If VBComp.Type = vbext_ct_StdModule And Left(VBComp.Name, 3) =
"mod" Then
VBComp.Export FName
WB.VBProject.VBComponents.Import FName
Kill FName
End If
Next VBComp
End With
End Sub



Sub AddCodeModule(WB As Workbook, CodeToInsert As String, sCodeMod As
String)
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Set VBCodeMod = WB.VBProject.VBComponents(sCodeMod).CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, CodeToInsert
End With
End Sub



Function textFile(FName As String) As String
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim sep As String
Dim sBigstring As String
sBigstring = ""
sep = Chr(13)
Open FName For Input Access Read As #1
While Not EOF(1)
Line Input #1, WholeLine
If Right(WholeLine, 1) <> sep Then
WholeLine = WholeLine & sep
End If
sBigstring = sBigstring & WholeLine
Wend
Application.ScreenUpdating = True
Close #1
textFile = sBigstring
End Function



Sub selectFolders(sPath)
Dim intNum As Integer
Dim intCheckNum As Integer
Dim fso As FileSystemObject
Dim fldr As Folder
Dim fls As Object
Dim fl As File
Dim subfldr
Dim WB As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder(sPath)
For Each subfldr In fldr.SubFolders
selectFolders subfldr.Path
Next
Set fc = fldr.Files
For Each fl In fc
If Right(fl.Name, 4) = ".xls" Then
Set WB = Workbooks.Open(Filename:=(fldr.Path & "\" & fl.Name),
UpdateLinks:=False)
If WB.Worksheets(1).Range("G1").Value = "Version:" Then
If StringToNumber(WB.Worksheets(1).Range("H1").Value) >=
1.11 And StringToNumber(WB.Worksheets(1).Range("H1").Value) < 1.3 Then
DoEverything WB
WB.Worksheets(1).Range("H1").Value =
StringToNumber(WB.Worksheets(1).Range("H1").Value) & "revB"
WB.Save
ElseIf StringToNumber(WB.Worksheets(1).Range("H1").Value)
< 1.11 Then
PasteValues WB
DeleteVBACodeModules WB
WB.Worksheets(1).Range("H1").Value = "carbon copy"
WB.Save
End If
End If
WB.Close savechanges:=False
End If
Next

End Sub



Sub testme()
Application.EnableEvents = False
strTHISWORKBOOK = textFile("C:\Chip\thisworkbook.txt")
strFRMTAKEOFFCREATE = textFile("C:\Chip\frmTakeoffCreate.txt")
selectFolders "C:\Chip\quotes\"
Application.EnableEvents = True
End Sub



Function StringToNumber(strNum As String) As Double
If strNum = "" Then GoTo Blank
If IsNumeric(strNum) Then
StringToNumber = strNum
Exit Function
End If
Dim ii As Integer, intEndOfString As Integer
ii = 1
intEndOfString = Len(strNum)
Do While ii <= intEndOfString
Select Case Mid(strNum, ii, 1)
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", "."
ii = ii + 1
Case Else
If ii = intEndOfString Then
strNum = Left(strNum, ii - 1)
intEndOfString = intEndOfString - 1
Else
strNum = Left(strNum, ii - 1) & Right(strNum,
Len(strNum) - ii)
intEndOfString = intEndOfString - 1
End If
End Select
Loop
StringToNumber = strNum
Exit Function
Blank:
StringToNumber = 0
End Function



Sub PasteValues(WB As Workbook)
For Each ws In WB.Worksheets
ws.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Next
End Sub

 

[Chip R.]

Just wanted to say that I got it working long enough to finish my
project. I got it to work by starting with a blank workbook and
pasting the code for the update routine into it. It seemed to run for
a few times before it would experience the same crash again, and I
seemed to be able to recreate success with starting with a blank
workbook, again. Although this isn't a good answer, hopefully someone
else will be able to use this tip if they encounter the same problem.

Thanks for your help, and sorry for the long post.

-Chip