Option Explicit

'V1.0 - First Version

Sub GenErr

	Dim sIniFile, sPath, aFiles, iFileIndex, iFileCount, sFile

	sIniFile = "c:\Intellipro.ini"

	'Hide...
	Call zGen_PopupMsg("I'm going to hide while I'm doing this...", 2)
	Call zQTP_MinimizeWindow

	'What is the path to the files?
	sPath = zGen_GetIni(sIniFile, "GenErr", "Path", "C:\Program Files\HP\QuickTest Professional\Tests\")

	'Get user to confirm the path
	sPath = Inputbox ("Confirm path to files:", "User Input Required", sPath)

	If sPath = "" Then
		Call ExitTest()
	End If

	'Check the path exists
	If Not zFile_FolderExists(sPath) Then
		Msgbox sPath, vbExclamation, "Path NOT Found - Aborting:"
		Call ExitTest()
	End If

	'Get the files to process
	aFiles = zFile_GetListFromFolder(sPath)

	iFileCount = UBound(aFiles)

	If iFileCount = 0 Then

		Msgbox sPath, vbExclamation, "No files found - Aborting:"
		Call ExitTest()

	Else

		'Save the path for next time
		Call zGen_SetIni(sIniFile, "GenErr", "Path", sPath)

		For iFileIndex = 1 to iFileCount

			sFile = aFiles(iFileIndex)

			'Only process .qfl files for now
			If Right(sFile,4) = ".qfl" Then

				Call zGen_PopupMsg("Processing File : " & sFile & " - " & cStr(iFileIndex) & " of " & cStr(iFileCount), 1)

				'Strip away the file extension
				sFile = Left(sFile,Len(sFile)-4)

				Call ProcessFile(sPath, sFile, "qfl")

			Else
				'Ignore other types of files for now 
				Call zGen_PopupMsg("Ignoring File : " & sFile, 1)

			End If

		Next

	End If

End Sub

'=========================

Private Sub ProcessFile(sPath,sFile, sExtn)

	Dim sMod, sFromFile, sToFile, oFso, oFileFrom, oFileTo, iLine, sLine

	Const ForReading = 1, ForWriting = 2, ForAppending = 8
	Const TristateTrue = -1

	sMod = "Xxx"
	iLine = 0

	sFromFile = sPath & sFile & "." & sExtn
	sToFile   = sPath & sFile & "_001." & sExtn

	Set oFso = CreateObject("Scripting.FileSystemObject")

	Set oFileFrom = oFso.OpenTextFile(sFromFile, ForReading, False, TristateTrue)
	Set oFileTo   = oFso.OpenTextFile(sToFile,   ForWriting, True,  TristateTrue)

	Do Until oFileFrom.AtEndOfStream

		iLine = iLine + 1

		sLine = oFileFrom.ReadLine

		sLine = ProcessLine(sFile,sMod,iLine,sLine)

		oFileTo.WriteLine sLine

	Loop

	oFileFrom.Close
	oFileTo.Close

	Set oFileFrom = Nothing
	Set oFileTo   = Nothing

	Set oFso = Nothing

End Sub

'=========================

Private Function ProcessLine(sApp,sMod,iLine,sLine)

	Dim sTemp, iLen, iTabCount, iVisibleLength, iPaddingRequired, iPaddingTabs, sPadding, sPaddingTabs
	Dim iCharIndex, iCharCount, iSpaceCount, sChar, iChar, iTabsRequired, iPaddingRemainder
	Dim iTotalTabs, sTotalTabs, sCode, sSuffix

	'Set the return value
	ProcessLine = sLine

	'Detect blank lines
	If sLine = "" Then
		Exit Function
	End If

	If sLine ="Option Explicit" Then
		Exit Function
	End If

	'Detect blank lines - Replace all tabs with spaces, then trim 
	sTemp = Trim(Replace(sLine,vbtab,""))

	If sTemp = "" Then
		'Reset the return value to make blank lines REALLY blank
		ProcessLine = ""
		Exit Function   
	End If

	'Ignore comment lines - leave as-is (including incorrect tabs/spacing if any)
	If Left(sTemp,1) = "'" Then
		Exit Function
	End If

	'Ignore lines that end with the continuation character '_'
	If Right(sTemp,1) = "_" Then
		Exit Function
	End If

	'Ignore start/end subs and functions - make check case insensitive

	'Functions
	If UCase(Left(sTemp,9)) = "FUNCTION " Then
		sMod = ExtractMod(Mid(sTemp,10))
		ProcessLine = "Function " & Mid(sTemp,10)
		Exit Function
	ElseIf UCase(Left(sTemp,17)) = "PRIVATE FUNCTION " Then
		sMod = ExtractMod(Mid(sTemp,18))
		ProcessLine = "Private Function " & Mid(sTemp,18) 	
		Exit Function	
	ElseIf UCase(Left(sTemp,16)) = "PUBLIC FUNCTION " Then
		sMod = ExtractMod(Mid(sTemp,17))
		ProcessLine = "Public Function " & Mid(sTemp,17) 	
		Exit Function	
	ElseIf UCase(Left(sTemp,24)) = "PUBLIC DEFAULT FUNCTION " Then
		sMod = ExtractMod(Mid(sTemp,25))	
		ProcessLine = "Public Default Function " & Mid(sTemp,25)  	
		Exit Function  
	ElseIf UCase(Left(sTemp,13)) = "EXIT FUNCTION" Then
		'Correct indenting matters - leave for now 
		Exit Function  
	ElseIf UCase(Left(sTemp,12)) = "END FUNCTION" Then
		sMod = "###" 	
		ProcessLine = "End Function"
		Exit Function
	End If

	'Subs
	If UCase(Left(sTemp,4)) = "SUB " Then
		sMod = ExtractMod(Mid(sTemp,5))
		ProcessLine = "Sub " & Mid(sTemp,5)
		Exit Function
	ElseIf UCase(Left(sTemp,12)) = "PRIVATE SUB " Then
		sMod = ExtractMod(Mid(sTemp,13))
		ProcessLine = "Private Sub " & Mid(sTemp,13)
		Exit Function
	ElseIf UCase(Left(sTemp,11)) = "PUBLIC SUB " Then
		sMod = ExtractMod(Mid(sTemp,12))
		ProcessLine = "Public Sub " & Mid(sTemp,12)
		Exit Function
	ElseIf UCase(Left(sTemp,19)) = "PUBLIC DEFAULT SUB " Then
		sMod = ExtractMod(Mid(sTemp,20))
		ProcessLine = "Public Default Sub " & Mid(sTemp,20)
		Exit Function
	ElseIf UCase(Left(sTemp,8)) = "EXIT SUB" Then
		'Correct indenting matters - leave for now
		Exit Function
	ElseIf UCase(Left(sTemp,7)) = "END SUB" Then
		sMod = "###"
		ProcessLine = "End Sub"
		Exit Function
	End If

	'If, Else, ElseIf, Endif
	If UCase(Left(sTemp,3)) = "IF " Then
		Exit Function
	ElseIf UCase(Left(sTemp,4)) = "ELSE" Then
		Exit Function
	ElseIf UCase(Left(sTemp,7)) = "ELSEIF " Then
		Exit Function
	ElseIf UCase(Left(sTemp,6)) = "END IF" Then
		Exit Function
	End If

	'For, Next, Exit For
	If UCase(Left(sTemp,4)) = "FOR " Then
		Exit Function
	ElseIf UCase(Left(sTemp,4)) = "NEXT" Then
		Exit Function
	ElseIf UCase(Left(sTemp,8)) = "EXIT FOR" Then
		Exit Function
	End If

	'While, Wend
	If UCase(Left(sTemp,6)) = "WHILE " Then
		Exit Function
	ElseIf UCase(Left(sTemp,4)) = "WEND" Then
		Exit Function
	End If

	'Do, Loop, Exit Do
	If UCase(Left(sTemp,2)) = "DO" Then
		Exit Function
	ElseIf UCase(Left(sTemp,4)) = "LOOP" Then
		Exit Function
	ElseIf UCase(Left(sTemp,7)) = "EXIT DO" Then
		Exit Function
	End If

	'Select Case ?

	'Withs ?

	'If we get to here:
		'Line not blank or spaces or tabs
		'Line not comment or spaces/tabs followed by comment
		'Line not start/end/exit of function or sub 
		'Line not continued on next line
		'Line not loops or branches

	'Process leading spaces and tabs
		'Split away the leading chunk mixture of spaces and tabs (can be ANY combination)

	iLen = Len(sLine)
	iCharCount = 0
	iSpaceCount = 0
	iTabCount = 0

	For iCharIndex = 1 to iLen

		iCharCount = iCharCount + 1
		
		'Look for spaces, tabs and anything else
		sChar = Mid(sLine,iCharIndex,1)
		iChar = Asc(sChar)

		If iChar = 32 Then
			'Space
			iSpaceCount = iSpaceCount + 1

		ElseIf iChar = 9 Then
			'Tab
			iTabCount = iTabCount + 1

		Else
			'Not space or tab so exit loop
			Exit For
		End If

	Next

	'Extract the code from the string
	sCode = Mid(sLine,iCharCount)

	'Work out what needs to go on the front
		'Ignore funny numbers of spaces because they are incorrect anyway

	'For every 4 spaces substitute a tab
	iTabsRequired = Int(iSpaceCount/4)

	'Caclulate total number of tabs
	iTotalTabs = iTabCount + iTabsRequired

	'Make a string with that many tabs
	sTotalTabs = String(iTotalTabs, 9)

	'Reconstruct the line - tabs plus code
	sTemp = sTotalTabs & sCode

	'Now remove any trailing spaces and tabs - QTP seems to accumulate these
	sTemp = BackNibble(sTemp)

	'Now calculate how long the line APPEARS to be

	'Recount the tabs - there might be some buried in the code line
	iTabCount = zStr_Count(sTemp, vbTab)

	iLen = Len(sTemp)

	'The total visible length is the total number of chars plus an extra 3 chars for each tab
	iVisibleLength = iLen + ( 3 * iTabCount )

	'Only process lines with less that 130 characters
	If iVisibleLength < 130 Then

		iPaddingRequired = 130 - iVisibleLength

		iPaddingTabs = Int(iPaddingRequired / 4)
		sPaddingTabs = String(iPaddingTabs, 9)

		iPaddingRemainder = iPaddingRequired - (iPaddingTabs * 4)

		sPadding = Space(iPaddingRemainder) & sPaddingTabs

		sSuffix = " :If Err <> 0 Then Call zErr(" & Chr(34) & sApp & Chr(34) & "," & Chr(34) & sMod & Chr(34) & "," & cStr(iLine) & ",Err)"

		'Assemble the final line and return it from the function
		ProcessLine = sTemp & sPadding & sSuffix

	End If

End Function

'=========================

Private Function ExtractMod(sInput)

	'Extract the function/sub name from the string

	Dim sTemp, iPosn

	'Remove any leading spaces and add a bracket onto the end so there is ALWAYS one to find
	sTemp = Trim(sInput) & "("

	'Look for an opening blacket to terminate the function name
	iPosn = inStr(sTemp,"(")

	'Trim away any spaces, brackets and parameters
	sTemp = Trim(Left(sTemp,iPosn-1))

	'Return the name
	ExtractMod = sTemp

End Function
'=========================

Private Function BackNibble(sInput)

	Dim sTemp, iLen, iPos, sChar, iChar

	sTemp = sInput
	BackNibble = sTemp

	iLen = Len(sTemp)

	For iPos = iLen to 1 step -1

		sChar = Mid(sTemp,iPos,1)
		iChar = Asc(sChar)

		If iChar = 32 Then
			sTemp = Left(sTemp,iPos-1)

		ElseIf iChar = 9 Then
			sTemp = Left(sTemp,iPos-1)

		Else
			'Not space or tab -> exit!
			BackNibble = sTemp
			Exit Function
		End If

	Next

End Function

'=========================

Private Function zStr_Count(sInput, sSrch)

	Dim iCount, sTemp

	iCount = 0
	sTemp  = sInput

	While inStr(sTemp,sSrch) > 0

		iCount = iCount + 1

		sTemp = Replace(sTemp, sSrch, "", 1, 1)

	Wend

	zStr_Count = iCount

End Function

'========================================

Private Function zFile_Exists(sFileName)

	Dim oFso

	Set oFso = CreateObject("Scripting.FileSystemObject")

	If oFso.FileExists(sFileName) Then

		zFile_Exists = True

	Else

		zFile_Exists = False

	End If

	Set oFso = Nothing

End Function

'========================================

Private Sub zGen_PopupMsg(sMsg, iDelay)

	Dim oShell

	If iDelay = 0 Then
		Msgbox sMsg

	Else

		Set oShell = CreateObject("Wscript.Shell")

		oShell.Popup sMsg, iDelay, ""

		Set oShell = Nothing

	End If

End Sub

'========================================

Private Sub zQTP_MinimizeWindow

	Dim oApp

	Set oApp = GetObject("","QuickTest.Application")

	oApp.WindowState = "Minimized"

	Set oApp = Nothing

End Sub

'========================================

Private Function zGen_GetIni(sIniFile, sSection, sKey, sDefault)

	Dim iRet, sReturnString

	Extern.Declare micLong, "GetPrivateProfileString", "kernel32.dll", "GetPrivateProfileStringA", micString, micString, micString, micString + micByRef, micDWord, micString 

	iRet = Extern.GetPrivateProfileString( sSection, sKey, sDefault, sReturnString, 256, sIniFile )

	If iRet > 0 Then
		zGen_GetIni = sReturnString
	Else
		zGen_GetIni = sDefault
	End If

End Function

'========================================

Private Sub zGen_SetIni(sIniFile, sSection, sKey, sValue)

	Dim iRet

	Extern.Declare micLong, "WritePrivateProfileString", "kernel32.dll", "WritePrivateProfileStringA", micString, micString, micString, micString

	iRet = Extern.WritePrivateProfileString( sSection, sKey, sValue, sIniFile )

End Sub

'========================================

Private Function zFile_FolderExists(sFolder)

	'This function checks to see if a folder exists

	'Usage:
		'If zFile_FolderExists(sFolder) Then
			'Xxxxx
		'End If

	Dim oFso

	Set oFso = CreateObject("Scripting.FileSystemObject")

	If oFso.FolderExists(sFolder) Then

		zFile_FolderExists = True

	Else

		zFile_FolderExists = False

	End If

	Set oFso = Nothing

End Function

'========================================

Private Function zFile_GetListFromFolder(sFolder)

	'This function returns an array with the names of all the files in a folder

	'Usage:
		'aFiles = zFile_GetListFromFolder(sFolder)

	'NOTE the array starts from 1 because zero is used to indicate an empty folder
	'The zeroth entry also holds the reason the folder is empty

	Dim oFso, oFolder, cFiles, oFile, aFiles(), iFile

	iFile = 0

	ReDim aFiles(0)

	Set oFso = CreateObject("Scripting.FileSystemObject")

	If oFso.FolderExists(sFolder) Then

		Set oFolder = oFso.GetFolder(sFolder)

		Set cFiles = oFolder.Files

		If cFiles.Count > 0 Then

			For Each oFile In cFiles

				iFile = iFile + 1

				ReDim Preserve aFiles(iFile)

				aFiles(iFile) = oFile.Name

			Next

		Else
			aFiles(0) = "No Files in Folder"

		End If

	Else
		aFiles(0) = "Folder does not exist"

	End If

	zFile_GetListFromFolder = aFiles

End Function

'########################################