
'FILLTMP.BAS

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Create HTML File for ChemSketch Document by using a template'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Const Title = "Create HTML file."

Function Main As String
Dim Form, CurPage As object
Dim Diag As object, n As Boolean
Dim mask,a,Range, FileName,TempStr As String
Dim Res As integer, Message As String
Dim Flag, UserStr, UserMess, UserText As String
Dim Mass(100) As integer
Dim i, NPages, MaxNum As integer
Dim ErrorMsg as string

  CurPage = ActiveDocument.ActivePage
  UserText = "D"
  Res = 0
  for i = 1 to 100
    Mass(i) = 0
  next i 
  NPages = ActiveDocument.Count
  Range = "1"
  If NPages > 1 Then Range = "1-"+Str(NPages)
  FileName = "Template.htm"
  
  Form = ReadForm("FillTmp.frm")
  Form.SetStrValue("Range", Range)
  Do
    Form.SetStrValue("FileName", FileName)
    'Display form
    If Form.ExecForm Then
      FileName = Form.GetStrValue("FileName")
      Range = Form.GetStrValue("Range")
      Flag = Form.GetStrValue("Flag")
    Else
      Main = "Cancelled"    
      Exit Function
    End If
    ErrorMsg = ""
    UserStr = Range
    'Res - size of Mass()
    Res = CheckText(UserStr, Mass)
    mask = FileName
    If JustPathName(FileName) = "" Then mask = GetProgPathName + FileName
    n = FindFirst(mask, a)
    If n = False Then
      ErrorMsg = "File "+FileName+" was not found." + Chr(13)+ "Check the file name, please."
    Else
      If Res = 0 Then
        ErrorMsg = "Enter correct sequence of positive numbers (e.g. 1,4-6,3)"
      Else 
        If Res > 100 Then
          ErrorMsg = "The count of pages is out of range (100 pages)"
        Else
          MaxNum = MaxElement(Mass, Res)
          If MaxNum > NPages Then
            ErrorMsg = "Some of your entered pages are out of range."
          End If
        End If
      End If
    End If
    If ErrorMsg <> "" Then
      MessageBox(ErrorMsg, Title, MBB_OK or MBI_EXCLAMATION)
    End IF
  Loop While ErrorMsg <> ""
  
  Res = Res - 1
  If not CreateHTMLfile(Mass, Res, FileName, Range, Flag) Then Exit Function

  Main = "Completed." + Chr(13)+ Chr(13) + "See result in Newfile.htm"

End Function


Function MaxElement (ByRef Mass() As integer, MassSize As integer) As integer
Dim EL, i As integer
	El = 1
	for i = 1 to MassSize-1
		If El <= Mass(i) Then El = Mass(i)  
	next i
	MaxElement = El
End Function


' n - size of Mass()
Function CreateHTMLfile( ByRef Mass() As integer, ByVal n As integer, FileName As String, Range As String, Flag As String ) As boolean
Dim Page, CurDoc As object
Dim DName, FName, GFName As String
Dim UserStr, UserMess, UserText, TempStr As String
Dim RecStr, PName As String
Dim i, w, h As integer
Dim PrevFName, NextFName, AltStr As String
Dim TemplName, NewTemplName, FName As String
Dim Secs, Min, Sec As integer
	CurDoc = ActiveDocument
	w = CurDoc.ActivePage.GetWidth
	h = Curdoc.activePage.GetHeight
	CreateHTMLfile = false
	UserStr = "1"
	If Flag = "For each page" Then UserStr = "2"
	FName = FileName
	DName = JustPathName(FName)
	open FName access read As #1
	NewTemplName = DName + "NewFile.htm"
	open NewTemplName access write As #2
	If n >= 2 Then
		Secs = n*9
		Min = Int((n*9 )/60)
		Sec = Secs - (Min*60)
		TempStr = "The process may take" + Chr(13) + Chr(10) + "up to " + Str(Min) + " min " + Str(Sec) + " sec. " + Chr(13) + Chr(10)
		TempStr = TempStr + "Do you want to continue?"  
		If MessageBox(TempStr,Title,MBB_YESNO or MBI_QUESTION) = MBR_NO Then
		       Exit Function
		End If
	End If
		
	for i = 1 to n
		Page = CurDoc.Item(Mass(i))
		FName = DName + "Page" + Str(i) + ".gif"
		Page.ExportToGIF(FName)
	next i
	If not FillUserTemplate(Mass,UserStr, n, NewTemplName, DName) Then Exit Function
	close #1
	close #2
	CreateHTMLfile = true
End Function

Function FillUserTemplate(ByRef Mass() As integer, ByRef Flag As String, ByVal n As integer, ByVal name As String, ByVal DName As String) As boolean
Dim i, j, pos, Flag1 As integer
Dim RecStr, TempStr, RStr, PName As String
Dim TStr As String
Dim IsEof As Boolean

	FillUserTemplate = false
	If Flag = "1" or Flag = "2" and n = 1 Then
	' "1" - one html document	
		Do
			read #1, RecStr, 250
			'print #2, RecStr
			'MessageBox(Left(RecStr, 7), "Left", MBB_OK)
			Do
				print #2, RecStr
				eof #1, IsEof
				If IsEof or InStr(1, LCase(RecStr), "</html>") > 0 Then GOTO L1
				read #1, RecStr, 250
 			Loop While Left(RecStr, 16) <> "<!-- [PageBlock]"
			print #2, RecStr
			Flag1 = 0
			open "Buffer.dat" access write As #3
			print #3, RecStr
			If Flag = "1" Then
				print #2, "<p><a href=""Page1.htm""><font face=""Arial, Helvetica, sans-serif"" size=""2""><b>sk.doc</b></font></a></p>"
			Else
				PName = ActiveDocument.Item(Mass(1)).GetName
				If PName = "" Then PName = "Page" + Str(n)
				print #2, "<p><a href=""Page1.htm""><font face=""Arial, Helvetica, sans-serif"" size=""2""><b>" + PName + "</b></font></a></p>"
			End If
			Do
				read #1, RecStr, 250
				print #2, RecStr
				print #3, RecStr
				If Left(RecStr, 16) = "<!-- [PageImage]" Then Flag1 = 1
				eof #1, IsEof
				If IsEof or InStr(1, LCase(RecStr), "</html>") > 0 Then GOTO L1	
			Loop While Left(RecStr, 17) <> "<!-- [/PageBlock]"
			close #3
			'MessageBox(Str(n), "n=", MBB_OK)
			If Flag1 = 1 Then
       				open "Buffer.dat" access read As #3
       				open "Page1.htm" access write As #4
       				print #4, "<html>"
       				print #4, "<head>"
       				print #4, "<title>sk.doc</title>"
       				print #4, "</head>"
       				read #3, RecStr, 250
       				print #4, RecStr
       				'MessageBox(RecStr, "<body>", MBB_OK)
       				If Left(RecStr, 16) = "<!-- [PageBlock]" Then
       					TStr = GetTag(RecStr, "<body")
       					'MessageBox(TStr, "<body>", MBB_OK)
       					print #4, TStr
       				End If
       				print #4, "<a Name=""Top"">"
       				print #4, "<p><a href="""+ name +"""><font face=""Arial,Helvetica, sans-serif"" size=""2"" color=""FFF000""><b>Back</b></font></a></p>"
       				Do
       					read #3, RecStr, 250
       					print #4, RecStr	
       				Loop While Left(RecStr, 16) <> "<!-- [PageImage]" 
       				TempStr = GetTag(RecStr, "<img")
       				If TempStr <> "" Then
       					RStr = ""
       					pos = InStr(4, TempStr, "[ImageSrc]")
       					If pos <> 0 Then
       						for j = 1 to n	
       							PName = "Page" + Str(j) + ".gif"
       							RStr = RStr + Left(TempStr, pos-1)
       							RStr = RStr + """" + PName + """"
       							'MessageBox(RStr, "RStr", MBB_OK)
       							for i = pos+10 to Len(TempStr)
       					
       								RStr = RStr + Mid(TempStr, i, 1)
       							next i
       				
       							print #4, RStr
       							RStr = ""
       						next j
       					End If
       				End If
       				Do 
       					read #3, RecStr, 250
       					print #4, RecStr
       				Loop While Left(RecStr, 17) <> "<!-- [/PageBlock]"
       				print #4, "<a><a href=""#Top""><font face=""Arial,Helvetica, sans-serif"" size=""1"" color=""FFF000"">Top</font></a><br></p>"
				close #3
				print #4, "</body>"
				print #4, "</html>"
				close #4
		
			Else
				close #3
				Exit Function
			End If
			
			eof #1, IsEof
		
		loop until IsEof or InStr(1, LCase(RecStr), "</html>") > 0
	Else
		If not FillForEachPage(Mass, n, name, DName) Then Exit Function
	End If
L1:	FillUserTemplate = true
End Function

Function FillForEachPage(ByRef Mass() As integer, ByVal NumPages As integer, ByVal name As String, ByVal DName As String) As boolean
Dim TStr, SLet, RecStr, PName, FName As String
Dim Flag1, i As integer
Dim IsEof As Boolean
	FillForEachPage = false
	Flag1 = 0
	
	Do
		read #1, RecStr, 250
		Do
			print #2, RecStr
			eof #1, IsEof
			If IsEof or InStr(1, LCase(RecStr), "</html>") > 0 Then GOTO L1
			read #1, RecStr, 250
 		Loop While Left(RecStr, 16) <> "<!-- [PageBlock]"
		open "Buffer.dat" access write As #3
		print #3, RecStr
		Do
			read #1, RecStr, 250
			print #3, RecStr
			print #2, RecStr
			If Left(RecStr, 16) = "<!-- [PageImage]" Then Flag1 = 1
			eof #1, IsEof
			If IsEof or InStr(1, LCase(RecStr), "</html>") > 0 Then GOTO L1
		Loop While Left(RecStr, 17) <> "<!-- [/PageBlock]"
		close #3
		If Flag1 = 0 Then Exit Function
		print #2, "<a name=""Home"">"
		print #2, "<table>"
		for i = 1 to NumPages
			Print #2, "   <tr>"
			PName = ActiveDocument.Item(Mass(i)).GetName
			'MessageBox(PName,"PName=", MBB_OK)
			If PName = "" Then PName = "Page" + Str(i)
			'MessageBox(PName,"PName=", MBB_OK)
			FName = "Page" + Str(i) + ".htm"
			RecStr = "      <td  align=""left"" width=""20%""><a href=""" +FName+ """><b>" + Str(i) + "</b></a></td>"
			print #2,RecStr
			
			RecStr = "      <td  align=""left""><a href=""" +FName+ """><b>" + PName + "</b></a></td>"
			print #2, RecStr
			print #2, "   </tr>"
		next i
		print #2, "</table><br>"
		
		If not BuildHTML(NumPages, name, DName)Then Exit Function
		
		eof #1, IsEof
		
	loop until IsEof or InStr(1, LCase(RecStr), "</html>") > 0
L1:	FillForEachPage = true
End Function

Function BuildHTML(ByVal n As integer, ByVal name As String, ByVal DName As String) As boolean
Dim i, j, pos As integer
Dim RecStr, TStr, FName, RStr As String
Dim PrevFName, NextFName, PName As String
	BuildHTML = false
	'MessageBox(Str(n), "n=", MBB_OK)
	for i = 1 to n
		select case i
			case 1
				FName = "Page1.htm"
				PrevFName = name + "#Home"
				NextFName = "Page2.htm"
			case n
				If n = 2 Then
					PrevFName = "Page1.htm"
				Else
					PrevFName = "Page" + Str(n-1) + ".htm"
				End If
				FName = "Page" + Str(n) + ".htm"
							
				NextfName = name + "#Home"
			case Else
				FName = "Page" + Str(i) + ".htm"
							
				PrevFName = "Page" + Str(i-1) + ".htm"
				NextFName = "Page" + Str(i+1) + ".htm"
		End select
		'MessageBox(FName, "FName", MBB_OK)
		FName = DName + FName
		open FName access write As #4
		PName = "Page" + Str(i)			
		print #4, "<html>"
		print #4, "<head>"
		print #4, "<title>""" + PName + """</title>"
		print #4, "</head>"
		open "Buffer.dat" access read As #3
		read #3, RecStr, 250
		print #4, RecStr
		TStr = GetTag(RecStr, "<body")
		print #4, TStr
		Do
			read #3, RecStr, 250
			print #4, RecStr
			If Left(RecStr, 16) = "<!-- [PageImage]" Then
				TStr = GetTag(RecStr, "<img")
				If TStr <> "" Then
					RStr = ""
					pos = InStr(4, TStr, "[ImageSrc]")
					If pos <> 0 Then
						PName = "Page" + Str(i) + ".gif"
						RStr = RStr + Left(TStr, pos-1)
						RStr = RStr + """" + PName + """"
						'MessageBox(RStr, "RStr", MBB_OK)
						for j = pos+10 to Len(TStr)
							RStr = RStr + Mid(TStr, j, 1)
						next j
						print #4, RStr
					End If
				End If
			Else
				If Left(RecStr, 15) = "<!-- [PrevPage]" and PrevFName <> "" Then
					RStr = ""
					TStr = GetHRefTag(RecStr)
					'MessageBox(TStr, "GetTag=", MBB_OK)
					pos = InStr(2, TStr, "[PrevLink]")
					If pos <> 0 Then
						RStr = RStr + Left(TStr, pos-1)
						RStr = RStr + """" + PrevFName + """"
						'MessageBox(RStr, "RStr", MBB_OK)
						for j = pos+10 to Len(TStr)
							RStr = RStr + Mid(TStr, j, 1)
						next j
						print #4, RStr
						'MessageBox(RStr, "Prev", MBB_OK)
					End If	
				Else
					If Left(RecStr, 15) = "<!-- [NextPage]" and NextFName <> "" Then
						RStr = ""
						TStr = GetHRefTag(RecStr)
						'MessageBox(TStr, "GetTag=", MBB_OK)
						pos = InStr(2, TStr, "[NextLink]")
						If pos <> 0 Then
							RStr = RStr + Left(TStr, pos-1)
							RStr = RStr + """" + NextFName + """"
							'MessageBox(RStr, "RStr", MBB_OK)
							for j = pos+10 to Len(TStr)
								RStr = RStr + Mid(TStr, j, 1)
							next j
							print #4, RStr
							'MessageBox(RStr, "Next", MBB_OK)
						End If	
						
					End If	
				End If
				
			End If
			
		Loop While Left(RecStr, 17) <> "<!-- [/PageBlock]"
		print #4, "</body>"
		print #4, "</html>"
		close #3
		close #4
	next i
	BuildHTML = true
End Function

Function GetHRefTag(ByRef s As String) As String
Dim i, pos1, pos2 As integer
Dim TStr As String
	GetHRefTag = ""
	pos1 = 0
	pos2 = 0
	pos1 = InStr(1, s, "<a")
	pos2 = InStr(1, s, "/a>")
	If pos1 = 0 or pos2 = 0 Then Exit Function
	TStr = ""
	for i = pos1 to pos2
		TStr = TStr + Mid(s,i, 1)
	next i

	GetHRefTag = TStr+ "a>"
End Function

Function GetTag(ByVal s As String, ByVal Key As String) As String
Dim i As integer
Dim SLet As String
Dim temps As String
Dim pos, i As integer
	temps = ""
	pos = InStr(1, s, Key)
	If pos <> 0 Then
		i = pos
		Do 
			SLet = Mid(s, i, 1)
			temps = temps+SLet
			i = i+1
		Loop While SLet <> ">"
	End If
	'MessageBox(temps, "GetTag=", MBB_OK)
	GetTag = temps
End Function

Function CheckUserText(ByVal Text As String) As String
Dim i As integer
Dim pos, StrLen As integer
Dim TempStr As String
        StrLen = Len(Text)
        pos = InStr(2, Text, ".")
        CheckUserText = ""
        If pos = 0 Then
          	CheckUserText = Text + ".htm"
        Else
          If pos = StrLen-3 Then
            	If Ucase(Right(Text, 3)) = "HTM" Then
            		CheckUserText = Text
			MessageBox(Text, "",MBB_OK)
           	 Else
              		TempStr = "Error in the extension of your file name." + Chr(13) + "Please try again."
              		MessageBox(TempStr, Title, MBB_OK or MBI_EXCLAMATION)
           	 End If
          Else
            	CheckUserText = Text + ".htm"
		MessageBox(Text + ".htm", " + .htm", MBB_OK)
          End If
        End If
	
End Function

Function CheckText(Text As String, ByRef Mass() As integer) As integer
Dim i, j, n, StartNum, EndNum, pos, Num As integer
Dim TempStr, TempStr1, SLet, TrueSymbols As String
Dim Num1, s  As integer
	CheckText = 0
	RemoveSpaces(Text)
	TrueSymbols = "0123456789,-"
	If Len(Text) = 0 Then Exit Function
	for i = 1 to Len(Text)
		SLet = Mid(Text, i, 1)
		If InStr(1, TrueSymbols, SLet) = 0 Then
			Text = Text + ","
			Exit Function
		End If
	next i
	n = 1
	Num1 = 0
	TempStr = ""
	Text = Text+ ","
	for i = 1 to Len(Text)
		SLet = Mid(Text, i, 1)
		If SLet = "," Then
			
			Num = Int(Val(TempStr))
			If Num > 0 and Num < 100 Then
				If Num1 <> 0 Then
					s = 1
					If Num1 > Num Then s = -1
					j = Num1
					while j <> Num + s
						Mass(n) = j
						n = n+1
						j = j + s
						If n > 100 Then Exit Do
					End while 
					Num1 = 0
					TempStr = ""
				Else 
					Mass(n) = Num
					n = n+1
					Num = 0
					TempStr = ""
				End If
			Else
				Exit Function
			End If
		Else
			If SLet = "-" Then
				If Num1 <> 0 Then Exit Function
				Num1 = Int(Val(TempStr))
				If Num1 < 1  or Num1 > 100 Then Exit Function
				TempStr = ""
			Else
				TempStr = TempStr + SLet
			End If
		End If

		If n > 100 Then Exit for
	next i
	CheckText = n
End Function

Sub RemoveSpaces(Text As String)
Dim i, TextLen As integer
Dim SLet, TempStr As String
	TextLen = Len(Text)
	TempStr = ""
	for i = 1 to TextLen
		SLet = Mid(Text, i, 1)
		If SLet <> " " Then TempStr = TempStr + SLet
	next i
	Text = TempStr
End Sub

