Option Explicit
Global CurrentFileName$, InputFile1$, OutputFile1$, _
OutputFileNum1%, InputFileNum1%
Global tt1(5000) As String, tt2(5000) As String
Global LCount1%, Lcount2%
Global Linecounter%
Global EmergencyStop%
Global SStrings(500) As String
Global SSubs(500) As String
Global Findings(5000) As String
Global subsIndex%
Global stringsIndex%
Global i%, Ins$
Global mm2&
Global AppPath 'new & change all app.paths
Global Default_Editor
Sub InitArrays()
Dim X
On Error GoTo ErrInitArrays
'initialise 3 arrays
'search-strings, subroutine names
'and output
For X = 0 To 500
SStrings(X) = ""
SSubs(X) = ""
Next
For X = 0 To 5000
Findings(X) = ""
Next
stringsIndex = 0
InputFileNum1 = FreeFile
'read searchstrings into array
If Right(AppPath, 1) = "" Then
Open AppPath & "SString.txt" For Input As InputFileNum1
Else
Open AppPath & "SString.txt" For Input As InputFileNum1
End If
While Not EOF(InputFileNum1)
Line Input #InputFileNum1, Ins
Ins = Trim(Ins)
'next if/end
If Len(Ins) > 0 Then
SStrings(stringsIndex) = Ins
stringsIndex = stringsIndex + 1
End If
Wend
Close InputFileNum1
subsIndex = 0
InputFileNum1 = FreeFile
'read subroutine heading into array
If Right(AppPath, 1) = "" Then
Open AppPath & "SSubs.txt" For Input As InputFileNum1
Else
Open AppPath & "SSubs.txt" For Input As InputFileNum1
End If
While Not EOF(InputFileNum1)
Line Input #InputFileNum1, Ins
Ins = Trim(Ins)
'new few
If Len(Ins) > 0 Then
SSubs(subsIndex) = Ins
subsIndex = subsIndex + 1
End If
Wend
Close InputFileNum1
Exit Sub
ErrInitArrays:
MsgBox "Error accessing Search Strings " & Err
Exit Sub
End Sub
Sub Main()
' Default_Editor = GetProfile("Default_Editor")
' frmY2K1.Show
End Sub
Function notCurrencyFloat(locc%, sstring$)
Dim II$, xx%, qq$, kk$, flag%, OFlag%
Dim locc2%
If Not (IsNumeric(sstring)) Then
notCurrencyFloat = True
Exit Function
End If
locc2 = locc
II = Ins
'expand funtionality to accommodate
'variations on 18,19,19xx etc. here
Do
OFlag = True
flag = False
qq = ""
xx = 0
kk = Mid$(II, locc2 + xx, 1)
'build numeric string inc. decimals
While kk = "." Or kk = "," Or IsNumeric(kk)
xx = xx + 1
qq = qq & kk
kk = Mid$(II, locc2 + xx, 1)
Wend
'occurrence contains a decimal point
If InStr(qq, ".") > 0 Or InStr(qq, ",") > 0 Then
flag = True
OFlag = False
End If
If flag Then
'look at remainder of string
II = Mid$(II, locc2 + xx, Len(II) - locc2 + xx)
locc2 = InStr(1, II, sstring, 1)
If locc2 > 0 Then
flag = True 'another instance
Else
flag = False
End If
End If
Loop While flag
notCurrencyFloat = OFlag
End Function
Sub MainProcess(way)
Dim LC%, FC%, k%, X%, subroutine$, FS&, locc%, tt$, _
CharCase%, dd%, ee%
Dim ShortOut$
Dim occtot%, MM&, mm3%
' On Error GoTo errMainProcess
InitArrays
InputFileNum1 = FreeFile
LC = 0
FC = 0
X = 0
Open InputFile1 For Input As InputFileNum1
MM = FileLen(InputFile1)
frmY2K1.txtBytes.Text = Format(MM, "#,###,###")
DoEvents
frmY2K1.txtBytes.Refresh
mm3 = 0
frmY2K1.ProgressBar1.Value = 0
Dim tmp%
tmp = 0
'scan whole file
While Not EOF(InputFileNum1)
'increment progress bar
If way Then
'If mm3 = 10 ^ mm2 Then
tmp = tmp + 1
'new next
If tmp < frmY2K1.ProgressBar1.Max Then
frmY2K1.ProgressBar1.Value = tmp
End If
'mm3 = 0
'End If
'mm3 = mm3 + 1
DoEvents
End If
If EmergencyStop Then GoTo bb:
'skip past blank lines
Do
Line Input #InputFileNum1, Ins
Ins = Trim(Ins)
Loop Until (Len(Ins) > 0 Or EOF(InputFileNum1)) _
And Left(Ins, 1) <> "~"
LC = LC + 1
If way Then
frmY2K1.txtCurrentLOCs.Text = LC
frmY2K1.txtCurrentLOCs.Refresh
frmY2K1.txtToTalLocs.Text = _
frmY2K1.txtToTalLocs.Text + 1
frmY2K1.txtToTalLocs.Refresh
End If
Ins = Trim(Ins)
Linecounter = Linecounter + 1
'check if inpur string is a subroutine name
For i = 0 To subsIndex - 1
If InStr(1, SSubs(i), Ins, 1) Then
subroutine = SSubs(i)
Linecounter = 0
FC = FC + 1
If way Then
frmY2K1.txtCurrentFuncs.Text = FC
frmY2K1.txtCurrentFuncs.Refresh
frmY2K1.txtTotalFuncs.Text = _
frmY2K1.txtTotalFuncs.Text + 1
frmY2K1.txtTotalFuncs.Refresh
End If
GoTo AA
End If
Next
If EmergencyStop Then GoTo bb:
'check input string for date occurrences
For k = 0 To stringsIndex - 1
If EmergencyStop Then GoTo bb:
Ins = UCase(Ins)
SStrings(k) = UCase(SStrings(k))
locc = InStr(1, Ins, SStrings(k), 1)
If locc > 0 Then
'skip processing if only currentcy float
If notCurrencyFloat(locc, SStrings(k)) Then
'save string containing occurrence,
'shorten to first
'50 chars if too long
Findings(X) = Trim(subroutine) & "--" & Trim(Ins)
dd = Len(Findings(X))
ee = Len(SStrings(k))
If dd > 50 Then
''new 50 to 48
Findings(X) = Left$(Findings(X), 48) & _
" " & Left$(SStrings(k), 9) & Space(10 - ee) _
& " #" & Linecounter
Else
Findings(X) = Findings(X) & Space(50 - dd) _
& " " & Left$(SStrings(k), 9) & Space(10 - ee)
_
& " #" & Linecounter
End If
X = X + 1
'update screen
If way Then
frmY2K1.txtCurrentOCCs.Text = X
frmY2K1.txtCurrentOCCs.Refresh
frmY2K1.txtToTOCCS.Text = _
frmY2K1.txtToTOCCS.Text + 1
frmY2K1.txtToTOCCS.Refresh
End If
End If
Exit For
End If
Next
If EmergencyStop Then GoTo bb:
AA:
Wend
frmY2K1.txtCurrentOCCs.Text = X
frmY2K1.txtCurrentOCCs.Refresh
'frmY2K1.txtToTOCCS.Text = frmY2K1.txtToTOCCS.Text + x
frmY2K1.txtToTOCCS.Refresh
frmY2K1.txtToTalFiles.Text = frmY2K1.txtToTalFiles.Text + 1
frmY2K1.txtToTalFiles.Refresh
bb:
Close InputFileNum1
If X > 1 Then
'dump findings array to file
OutputFileNum1 = FreeFile
'new few
If Len(CurrentFileName) > 6 Then
OutputFile1 = Left(CurrentFileName, _
(Len(CurrentFileName) - 2)) & _
frmY2K1.txtToTalFiles.Text & ".txt"
Else
OutputFile1 = CurrentFileName & _
frmY2K1.txtToTalFiles.Text & ".txt"
End If
'new next 20..
Dim tDir$, Myname$, MyPath, FoundFlag
If Right(AppPath, 1) = "" Then
MyPath = AppPath
Else
MyPath = AppPath & ""
End If
Myname = Dir(MyPath, vbDirectory)
'Retrieve the first entry.
FoundFlag = False
Do While Myname <> "" And Not (FoundFlag)
'Start the loop.
'Ignore the current directory and the
'encompassing directory.
If Myname <> "." And Myname <> ".." Then
'Use bitwise comparison to make sure
'MyName is a directory.
If (GetAttr(MyPath & Myname) And vbDirectory) _
= vbDirectory Then
If Myname = "OUTFILES" Then
FoundFlag = True
End If
End If
End If
Myname = UCase(Dir) ' Get next entry.
Loop
If FoundFlag Then
If Right(AppPath, 1) = "" Then
Open AppPath & "outfiles" & OutputFile1 _
For Output As OutputFileNum1
Else
Open AppPath & "outfiles" & OutputFile1 _
For Output As OutputFileNum1
End If
Else
If Right(AppPath, 1) = "" Then
MkDir AppPath & "outfiles"
Open AppPath & "outfiles" & OutputFile1 _
For Output As OutputFileNum1
Else
MkDir AppPath & "outfiles"
Open AppPath & "outfiles" & OutputFile1 _
For Output As OutputFileNum1
End If
End If
Write #OutputFileNum1, OutputFile1
Write #OutputFileNum1, ""
Write #OutputFileNum1, ""
For i = 0 To X - 1
Write #OutputFileNum1, Findings(i)
k = Len(Findings(i))
Next
Close OutputFileNum1
End If
Exit Sub
errMainProcess:
MsgBox "Error in MainProccess " & Err & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Exit Sub
End Sub
Sub Setup(way%)
Dim intCtr As Integer
Dim lngPos As Long, lngStart As Long
Dim strPath As String, strTemp As String
Dim strFile() As String
'"way" indicates display method for scan process
'0 = fast dont update screen every line
'1 = slow, update screen every line
Dim Myname$, MyPath$, X%, Y&, TotalBytes&
AppPath = App.Path
frmY2K1.mnuInputFiles.Enabled = False
frmY2K1.cmdStop.Enabled = True
'init counters
frmY2K1.txtToTalLocs.Text = 0
frmY2K1.txtToTalFiles.Text = 0
frmY2K1.txtToTOCCS.Text = 0
frmY2K1.txtTotalFuncs.Text = 0
EmergencyStop = False
intCtr = 0
TotalBytes = 0
strTemp = frmY2K1.cdlgOpen.FileName
frmY2K1.cdlgOpen.FileName = ""
lngPos = InStr(1, strTemp, Chr$(0))
If lngPos > 0 Then
strPath = Left(strTemp, lngPos - 1)
' Parse files
lngStart = lngPos + 1
Do
ReDim Preserve strFile(intCtr)
lngPos = InStr(lngStart, strTemp, Chr(0))
If lngPos > 0 Then
strFile(intCtr) = Mid(strTemp, lngStart, lngPos - lngStart)
lngStart = lngPos + 1
Else
strFile(intCtr) = Mid(strTemp, lngStart)
End If
intCtr = intCtr + 1
Loop While lngPos > 0
Else
lngPos = 1
ReDim strFile(0)
Do While lngPos > 0
lngPos = InStr(lngPos, strTemp, "")
If lngPos > 0 Then
strPath = Left(strTemp, lngPos - 1)
strFile(0) = Mid(strTemp, lngPos + 1)
lngPos = lngPos + 1
End If
Loop
End If
'for all selected files in the list
' get filesize
For intCtr = 0 To UBound(strFile)
If Right(strPath, 1) = "" Then
Y = FileLen(strPath & strFile(intCtr))
Else
Y = FileLen(strPath & "" & strFile(intCtr))
End If
TotalBytes = TotalBytes + Y
'if file too big, exit
If Y > 5000000 Then
MsgBox "Individual File Size Limit of 5MB exceeded (" &
strFile(intCtr) & ") - Processing " & InputFile1 & " Aborted"
frmY2K1.mnuprocess.Enabled = False
frmY2K1.mnuInputFiles.Enabled = True
Exit Sub
End If
Next
'format display
frmY2K1.txtToTbytes = Format(TotalBytes, "#,###,###")
'either setup progress bar limits or delay message
If way Then
mm2 = 0
TotalBytes = TotalBytes / 28 'LOCs > 100
While TotalBytes > 100
TotalBytes = TotalBytes / 10
mm2 = mm2 + 1
Wend
'frmY2K1.ProgressBar1.Max = TotalBytes
Else
Dim tmp%, hrs%, mins%
tmp = TotalBytes / 3000
hrs = tmp 3600
mins = tmp 60
If mins = 0 Then mins = 1
If hrs > 1 Then
MsgBox "This process could take up to " & hrs & " hour/s"
Else
MsgBox "This process could take " & mins & " minute/s"
End If
End If
frmY2K1.MousePointer = 11
'scan all files
For X = 0 To UBound(strFile)
If EmergencyStop Then Exit For
If Right(strPath, 1) = "" Then
InputFile1 = strPath & strFile(X)
Else
InputFile1 = strPath & "" & strFile(X)
End If
CurrentFileName = strFile(X)
''new one
CurrentFileName = Left(CurrentFileName, (InStr(1,
CurrentFileName, ".") - 1))
frmY2K1.txtCurrentLOCs.Text = 0
frmY2K1.txtCurrentOCCs.Text = 0
frmY2K1.txtCurrentFuncs.Text = 0
frmY2K1.Label8(4) = InputFile1
MainProcess (way)
DoEvents
Next
Beep: Beep
If EmergencyStop Then
MsgBox "Process Aborted", 64
Else
MsgBox "Done", 64
End If
frmY2K1.ProgressBar1.Value = 0
frmY2K1.MousePointer = 0
frmY2K1.cmdStop.Enabled = False
frmY2K1.mnuInputFiles.Enabled = True
frmY2K1.mnuprocess.Enabled = False
End Sub
Function GetProfile(KeyName)
Dim fnum As Integer
Dim temp As String
On Error GoTo Err_GetProfile
fnum = FreeFile
If Right(App.Path, 1) = "" Then
Open App.Path & "Year-2000.ini" For Input As fnum
Else
Open App.Path & "" & "Year-2000.ini" For Input As fnum
End If
While Not EOF(fnum) And InStr(temp, KeyName) <> 1
Line Input #fnum, temp
If Left$(temp, 1) = "'" Then temp = "" 'comments
Wend
If InStr(temp, KeyName) = 1 Then
GetProfile = Right(temp, (Len(temp) - InStr(temp, "=")))
Else
MsgBox KeyName & " not found in Year-2000.ini"
GetProfile = ""
End If
Exit_GetProfile:
Close
Exit Function
Err_GetProfile:
MsgBox "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description & " in GetProfile _
while trying to open Year-2000.ini - possibly file not found?"
Resume Exit_GetProfile
End Function