scctext.prg

程序包 解压安装即可 很好用的 请大家放心用

		this.aEnvironment[4] = set("talk")
		this.aEnvironment[5] = set("asserts")
		
		SET TALK OFF

		declare INTEGER SetFileAttributes in win32api ;
			STRING lpFileName, INTEGER dwFileAttributes
		declare INTEGER sprintf in msvcrt40.dll ;
			STRING @lpBuffer, string lpFormat, integer iChar1, integer iChar2, ;
			integer iChar3, integer iChar4, integer iChar5, integer iChar6, ;
			integer iChar7, integer iChar8

		set safety off
		set deleted off
		select 0
		if C_DEBUG
			set asserts on
		endif
		
	endproc
	
	procedure Cleanup
		local array aEnvironment[alen(this.aEnvironment)]
		=acopy(this.aEnvironment, aEnvironment)
		set deleted &aEnvironment[1]
		set safety &aEnvironment[3]
		use
		select (aEnvironment[2])
		if this.iHandle <> -1
			=fclose(this.iHandle) 
			this.iHandle = -1
		endif
		SET TALK &aEnvironment[4]		
		if used(this.cVCXCursor)
			use in (this.cVCXCursor)
			this.cVCXCursor = ""
		endif
		set asserts &aEnvironment[5]
	endproc
	
	procedure Destroy
		if type("this.oThermRef") = "O"
			this.oThermRef.Release()
		endif
	
		this.Cleanup
		
		if this.lMadeBackup
			if this.iResult <> 0
				this.RestoreBackup()
			endif
			this.DeleteBackup()
		endif
	endproc
	
	PROCEDURE Error
		Parameters nError, cMethod, nLine, oObject, cMessage

		local cAction
		
		THIS.HadError = .T.
		this.iError = m.nError
		this.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
	
		if this.SetErrorOff
			RETURN
		endif
		
		m.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
		if type("m.oObject") = "O" .and. .not. isnull(m.oObject) .and. at(".", m.cMethod) = 0
			m.cMethod = m.oObject.Name + "." + m.cMethod
		endif
				
		if C_DEBUG
			m.cAction = this.Alert(ERRORMESSAGE_LOC, MB_ICONEXCLAMATION + ;
				MB_ABORTRETRYIGNORE, ERRORTITLE_LOC)
			do case
			case m.cAction="RETRY"
				this.HadError = .f.
				clear typeahead
				set step on
				&cAction
			case m.cAction="IGNORE"
				this.HadError = .f.
				return
			endcase
		else
			if m.nError = 1098
				* User-defined error
				m.cAction = this.Alert(message(), MB_ICONEXCLAMATION + ;
					MB_OK, ERRORTITLE_LOC)
			else
				m.cAction = this.Alert(ERRORMESSAGE_LOC, MB_ICONEXCLAMATION + ;
					MB_OK, ERRORTITLE_LOC)
			endif
		endif
		this.Cancel

	ENDPROC
	
	procedure Cancel
		parameters cMessage
		if !empty(m.cMessage)
			m.cAction = this.Alert(m.cMessage)
		endif
		return to Process -1
	endproc
	
	PROCEDURE Alert
		parameters cMessage, cOptions, cTitle, cParameter1, cParameter2

		private cOptions, cResponse

		m.cOptions = iif(empty(m.cOptions), 0, m.cOptions)

		if parameters() > 3 && a parameter was passed
			m.cMessage = [&cMessage]
		endif
		
		clear typeahead
		if !empty(m.cTitle)
			m.cResponse = MessageBox(m.cMessage, m.cOptions, m.cTitle)
		else
			m.cResponse = MessageBox(m.cMessage, m.cOptions, ALERTTITLE_LOC)
		endif

		do case
		* The strings below are used internally and should not 
		* be localized
		case m.cResponse = 1
			m.cResponse = "OK"
		case m.cResponse = 6
			m.cResponse = "YES"
		case m.cResponse = 7
			m.cResponse = "NO"
		case m.cResponse = 2
			m.cResponse = "CANCEL"
		case m.cResponse = 3
			m.cResponse = "ABORT"
		case m.cResponse = 4
			m.cResponse = "RETRY"
		case m.cResponse = 5
			m.cResponse = "IGNORE"
		endcase
		return m.cResponse

	ENDPROC

	procedure Process
		local cThermLabel
		
		if this.FilesAreWritable()
			* Backup the file(s)

			this.MakeBackup()
			
			* Create and show the thermometer
			m.cThermLabel = iif(this.lGenText, this.cTextName, this.cTableName)
			this.oThermRef = createobject("thermometer", C_THERMLABEL_LOC)
			this.oThermRef.Show()
			
			if this.lGenText
				this.iResult = this.WriteTextFile()
			else
				this.iResult = this.WriteTableFile()
			endif
			
			if this.iResult = 0
				this.oThermRef.Complete(C_THERMCOMPLETE_LOC)
			endif
		endif
	endproc
	
	procedure FilesAreWritable
		private aText
		if this.lGenText
			* Verify we can write the text file
			if (adir(aText, this.cTextName) = 1 .and. 'R' $ aText[1, 5])
				if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cTextName) = "NO"
					return .f.
				endif
			endif
			=SetFileAttributes(this.cTextName, FILE_ATTRIBUTE_NORMAL)
		else
			* Verify we can write the table
			if (adir(aText, this.cTableName) = 1 .and. 'R' $ aText[1, 5])
				if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cTableName) = "NO"
					return .f.
				endif
			else
				if (adir(aText, this.cMemoName) = 1 .and. 'R' $ aText[1, 5])
					if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cMemoName) = "NO"
						return .f.
					endif
				endif
			endif
			=SetFileAttributes(this.cTableName, FILE_ATTRIBUTE_NORMAL)
			=SetFileAttributes(this.cMemoName, FILE_ATTRIBUTE_NORMAL)
		endif
		return .t.
	endproc
	
	procedure WriteTableFile
		this.iHandle = fopen(this.cTextName)
		if this.iHandle = -1
			this.Alert(ERR_FOPEN_LOC + this.cTextName)
			return -1
		endif

		this.oThermRef.iBasis = fseek(this.iHandle, 0, 2)
		fseek(this.iHandle, 0, 0)
		
		this.ValidVersion(fgets(this.iHandle, 8192))
		this.CreateTable(fgets(this.iHandle, 8192), val(fgets(this.iHandle, 8192)))
		do case
			case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX, PRJTYPE_MENU, ;
				PRJTYPE_REPORT, PRJTYPE_LABEL)
				this.WriteTable
			otherwise
				this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + this.cType)
		endcase
		
		=fclose(this.iHandle)
		this.iHandle = -1
		if inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX)
			if this.cType = PRJTYPE_VCX
				* Additional work may need to be performed on a VCX
				this.FixUpVCX
			endif
			
			use
			compile form (this.cTableName)
		endif
		use
		return 0 && Success
	endproc
	
	procedure FixUpVCX
		private aClassList, i
		select objname, recno() from dbf() where not deleted() and reserved1 == 'Class' ;
			into array aClassList
		if type('aClassList[1]') <> 'U'
			* If objects were added to or removed from a class during merge, 
			* the record count will be out of sync.
			for m.i = 1 to alen(aClassList, 1)
				go (aClassList[m.i, 2])
				if m.i = alen(aClassList, 1)
					replace reserved2 with ;
						alltrim(str(reccount() - aClassList[m.i, 2]))
				else
					replace reserved2 with ;
						alltrim(str(aClassList[m.i + 1, 2] - aClassList[m.i, 2] - 1))
				endif
			endfor
		endif
	endproc
	
	procedure CreateTable
		parameters cFieldlist, iCodePage
		private c1, c2, c3, c4, c5, c6, aStruct

		do case
			* BugBug: This is a workaround for the problem with CREATE TABLE and a long
			* field list
			case inlist(this.cType, PRJTYPE_REPORT, PRJTYPE_LABEL)
				dimension aStruct[75, 4]
				this.GetReportStructure(@aStruct)
				create table (this.cTableName) free from array aStruct
				release aStruct
				if .not. m.cFieldlist == this.Fieldlist()
					this.Cancel(ERR_FIELDLISTTOOLONG_LOC)
				endif
			case len(m.cFieldlist) < 251
				create table (this.cTableName) free (&cFieldList)
			case len(m.cFieldlist) < 501
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251)
				create table (this.cTableName) free (&c1&c2)
			case len(m.cFieldlist) < 751
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501)
				create table (this.cTableName) free (&c1&c2&c3)
			case len(m.cFieldlist) < 1001
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501, 250)
				m.c4 = substr(m.cFieldlist, 751)
				create table (this.cTableName) free (&c1&c2&c3&c4)
			case .f. .and. len(m.cFieldlist) < 1251
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501, 250)
				m.c4 = substr(m.cFieldlist, 751, 250)
				m.c5 = substr(m.cFieldlist, 1001)
				* BugBug: This causes an error
				create table (this.cTableName) free (&c1&c2&c3&c4&c5)
			case .f. .and. len(m.cFieldlist) < 1501
				m.c1 = substr(m.cFieldlist, 1, 250)
				m.c2 = substr(m.cFieldlist, 251, 250)
				m.c3 = substr(m.cFieldlist, 501, 250)
				m.c4 = substr(m.cFieldlist, 751, 250)
				m.c5 = substr(m.cFieldlist, 1001, 250)
				m.c6 = substr(m.cFieldlist, 1251)
				* BugBug: This causes an error
				create table (this.cTableName) free (&c1&c2&c3&c4&c5&c6)
			otherwise
				* Not supported
				this.Cancel(ERR_FIELDLISTTOOLONG_LOC)
		endcase
		if cpdbf() <> m.iCodePage
			use
			this.SetCodePage(this.cTableName, m.iCodePage)
		endif
		use (this.cTableName) exclusive
	endproc
	
	procedure ValidVersion
		parameters cVersion
		if .not. m.cVersion == SCCTEXTVER_LOC
			this.Cancel(ERR_BADVERSION_LOC)
		endif
	endproc
	
	procedure FieldList
		* Returns a CREATE TABLE compatible field list for the current workarea.
		local cStruct, i
		local array aStruct[1]
		
		=afields(aStruct)
		m.cStruct = ""
		for m.i = 1 to alen(aStruct, 1)
			if .not. empty(m.cStruct)
				m.cStruct = m.cStruct + ","
			endif
			m.cStruct = m.cStruct + aStruct[m.i, 1] + " " + aStruct[m.i, 2] + ;
				"(" + alltrim(str(aStruct[m.i, 3])) + "," + ;
				alltrim(str(aStruct[m.i, 4])) + ")"
		endfor
		
		return m.cStruct
	endproc
	
	procedure CreateVcxCursor
		private iSelect, aClasslist, i, j, iCount, aRec, aStruct
		
		this.cVCXCursor = "_" + sys(3)
		do while used(this.cVCXCursor)
			this.cVCXCursor = "_" + sys(3)
		enddo
		
		* Get an ordered list of the classes in the vcx
		select padr(uniqueid, fsize('uniqueid')), recno() from dbf() ;
			where .not. deleted() .and. reserved1 == "Class" ;
			into array aClasslist order by 1

		m.iSelect = select() && The original .VCX

		* Create the temporary cursor
		=afields(aStruct)
		create cursor (this.cVCXCursor) from array aStruct
		
		* Copy the header record
		select (m.iSelect)
		go top
		scatter memo to aRec
		insert into (this.cVCXCursor) from array aRec
		
		* Scan through the class list and copy the classes over
		if type('aClassList[1]') <> 'U'
			for m.i = 1 to alen(aClasslist, 1)
				go (aClasslist[m.i, 2])
				m.iCount = 1 + val(reserved2)
				for m.j = 1 to m.iCount
					scatter memo to aRec
					insert into (this.cVCXCursor) from array aRec
					skip
				endfor
			endfor
		endif
		
		* Close the original file and use the cursor we've created
		use in (m.iSelect)
		
		select (this.cVCXCursor)
	endproc
	
	procedure WriteTextFile
		private iCodePage, aText
		
		use (this.cTableName) exclusive
		
		this.oThermRef.iBasis = reccount()

		m.iCodePage = cpdbf()
		
		if this.cType = PRJTYPE_VCX
			this.CreateVcxCursor
		endif

		this.iHandle = fcreate(this.cTextName)
		if this.iHandle = -1
			this.Alert(ERR_FCREATE_LOC + this.cTextName)
			return -1
		endif
		
		* First line contains the SCCTEXT version string
		=fputs(this.iHandle, SCCTEXTVER_LOC)

		* Second line contains the CREATE TABLE compatible field list
		=fputs(this.iHandle, this.FieldList())
		* Third line contains the code page
		=fputs(this.iHandle, alltrim(str(m.iCodePage)))
		
		do case
		case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX, PRJTYPE_LABEL, ;
			PRJTYPE_REPORT, PRJTYPE_MENU, PRJTYPE_DBC)
			this.WriteText
		otherwise
			this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + m.cType)
		endcase

		=fclose(this.iHandle)
		this.iHandle = -1
		use
		return 0 && Success
	endproc

	procedure WriteTable
		private cLine, bInMemo, cMemo, cEndMark, bBinary, cFieldname, cValue, iSeconds
		m.cLine = ""
		m.bInMemo = .f.
		m.cMemo = ""
		m.cEndMark = ""
		m.bBinary = .f.
		m.cFieldname = ""
		m.cValue = ""
		
		this.oThermRef.Update(fseek(this.iHandle, 0, 1))
		m.iSeconds = seconds()
		
		do while .not. feof(this.iHandle)
			if (seconds() - m.iSeconds > 1)
				this.oThermRef.Update(fseek(this.iHandle, 0, 1))
				m.iSeconds = seconds()
			endif
			
			m.cLine = fgets(this.iHandle, 8192)
			
			if m.bInMemo
				do case
				case m.cEndMark == m.cLine
				case rat(m.cEndMark, m.cLine) <> 0
					if m.bBinary
						m.cMemo = m.cMemo + ;
							this.HexStr2BinStr(left(m.cLine, rat(m.cEndMark, m.cLine) - 1))
					else
						m.cMemo = m.cMemo + left(m.cLine, rat(m.cEndMark, m.cLine) - 1)
					endif
				otherwise
					if m.bBinary
						m.cMemo = m.cMemo + this.HexStr2BinStr(m.cLine)
					else
						m.cMemo = m.cMemo + m.cLine + CRLF
					endif
					loop				
				endcase
				
				* Drop out of if/endif to write the memo field
			else
				do case
				case empty(m.cLine)
					loop
				case m.cLine == MARKEOF
					* Don't read anything past the [EOF] mark
					return
				case m.bInMemo .and. m.cEndMark == m.cLine
				case this.IsRecordMark(m.cLine)
					append blank
					loop
				case this.IsMemoStartMark(m.cLine, @cFieldname)
					m.bInMemo = .t.
					m.bBinary = .f.
					m.cEndMark = this.SectionMark(m.cFieldname, .f., .f.)
					loop
				case this.IsBinStartMark(m.cLine, @cFieldname)
					m.bInMemo = .t.
					m.bBinary = .t.
					m.cEndMark = this.SectionMark(m.cFieldname, .f., .t.)
					loop
				case this.IsFieldMark(m.cLine, @cFieldname, @cValue)
					do case
					case inlist(type(m.cFieldname), "C", "M")
						replace (m.cFieldname) with m.cValue
					case type(m.cFieldname) = "N"
						replace (m.cFieldname) with val(m.cValue)
					case type(m.cFieldname) = "L"
						replace (m.cFieldname) with &cValue
					otherwise
						this.Cancel(ERR_UNSUPPORTEDFIELDTYPE_LOC + type(m.cFieldname))
					endcase
					loop
				otherwise
					if this.Alert(ERR_LINENOACTION_LOC + chr(13) + chr(13) + m.cLine + chr(13) + chr(13) + ;
						ERR_ALERTCONTINUE_LOC, MB_YESNO) = IDNO
						this.Cancel
					endif
				endcase
			endif
			
			* Write the memo field
			replace (m.cFieldname) with m.cMemo
			m.bInMemo = .f.
			m.cFieldname = ""
			m.cMemo = ""
			m.cEndMark = ""
		enddo
	endproc
	
	procedure IsMemoStartMark
		parameters cLine, cFieldname
		private cStartMark, cStartMark2
		if at(MARKMEMOSTARTWORD, m.cLine) = 1
			m.cFieldname = strtran(m.cLine, MARKMEMOSTARTWORD, "", 1, 1)
			m.cFieldname = left(m.cFieldname, rat(MARKMEMOSTARTWORD2, m.cFieldname) - 1)
			return .t.
		endif
		return .f.
	endproc

	procedure IsBinStartMark
		parameters cLine, cFieldname