VERSION 2.00
Begin Form HTMLForm
Caption = "COBOL to HTML Converter"
ClientHeight = 1680
ClientLeft = 1095
ClientTop = 1590
ClientWidth = 4560
Height = 2085
Left = 1035
LinkTopic = "Form1"
ScaleHeight = 1680
ScaleWidth = 4560
Top = 1245
Width = 4680
Begin TextBox Text1
Height = 375
Left = 240
TabIndex = 4
Top = 1920
Width = 3255
End
Begin CommandButton Command4
Caption = "Output File"
Height = 495
Left = 2880
TabIndex = 3
Top = 120
Width = 1575
End
Begin CommonDialog CMDia2
DefaultExt = "htm"
Filter = "HTML|*.htm|All Files|*.*"
Flags = 34822
Left = 4560
Top = 120
End
Begin CommandButton Command3
Caption = "Input File"
Height = 495
Left = 120
TabIndex = 2
Top = 120
Width = 1575
End
Begin CommonDialog CMDia1
Filter = "Cobol Files(*.cbl;*.cob;*.src;*.lib)|*.cbl;*.cob;*.src;*.lib|All File|*.*"
Flags = 65540
Left = 1800
Top = 120
End
Begin CommandButton Command2
Caption = "E&XIT"
Height = 495
Left = 2880
TabIndex = 1
Top = 1080
Width = 1575
End
Begin CommandButton Command1
Caption = "Make HTML"
Height = 495
Left = 120
TabIndex = 0
Top = 1080
Width = 1575
End
Begin Label Label1
Height = 495
Left = 240
TabIndex = 5
Top = 2640
Width = 3495
End
End
Option Explicit
Dim InFile$, OutFile$
Dim MaxHeight As Integer
Dim MaxWidth As Integer
Sub Command1_Click ()
Dim a$
Dim KeyWordProcedure$
Dim KeyWordSection$
Dim KeyWordPreform$
Dim c$
Dim S As Integer
Dim P As Integer
Dim MayBeErr As Integer
command1.Enabled = False
MayBeErr = True
S = 0
P = 0
On Error GoTo Herror
KeyWordProcedure$ = "PROCEDURE"
KeyWordSection$ = " SECTION"
KeyWordPreform$ = " PERFORM "
InFile$ = CMDia1.Filename
OutFile$ = CMDia2.Filename
Open InFile$ For Input As #1
Open OutFile$ For Output As #2
Print #2, ""
Print #2, "" & ConvertAllASCII$(InFile$) & ""
Print #2, ""
Print #2, ""
Print #2, ""
'-------------- go till procedure division
c$ = "Bottom"
c$ = c$ & "-"
Print #2, c$
S = S + 1
Print #2, "Sect."
c$ = UpDownTag$("S", S)
Print #2, c$
P = P + 1
Print #2, "Para."
c$ = UpDownTag$("P", P)
Print #2, c$
Do While Not EOF(1)
a$ = ReadLine$()
Select Case Mid$(a$, 7, 1)
Case "*", "-", "/"
'
Case Else
If Mid$(a$, 8, 4) <> Space(4) Then
If Left(UCase$(Trim$(Mid$(a$, 8))), Len(KeyWordProcedure$)) = KeyWordProcedure$ Then
c$ = ConvertAllASCII$(a$)
Print #2, c$
Exit Do
End If
End If
End Select
c$ = ConvertAllASCII$(a$)
Print #2, c$
Loop
'
If Not EOF(1) Then
Print #2, c$
Do While Not EOF(1)
a$ = ReadLine$()
Select Case Mid$(a$, 7, 1)
Case "*", "-", "/"
c$ = ConvertAllASCII$(a$)
Print #2, c$
Case Else
If Mid$(a$, 8, 4) = Space$(4) Then
If InStr(a$, KeyWordPreform$) = 0 Then
c$ = ConvertAllASCII$(a$)
Print #2, c$
Else
c$ = ConvertAllASCII$(a$)
c$ = "" & c$ & ""
Print #2, c$
End If
Else
If a$ = "" Then
Print #2, ""
ElseIf InStr(8, UCase$(a$), KeyWordSection$) > 0 Then
S = S + 1
c$ = Mid$(ConvertAllASCII$(a$), 7)
c$ = UpDownTag$("S", S) & "" & c$ & ""
Print #2, c$
Else
P = P + 1
c$ = Mid$(ConvertAllASCII$(a$), 7)
c$ = UpDownTag$("P", P) & "" & c$ & ""
Print #2, c$
End If
End If
End Select
Loop
End If
S = S + 1
Print #2, "Sect."
c$ = UpDownTag$("S", S)
Print #2, c$
P = P + 1
Print #2, "Para."
c$ = UpDownTag$("P", P)
Print #2, c$
c$ = "Top"
Print #2, c$
Print #2, ""
Print #2, "
"
Print #2, ""
Print #2, ""
MayBeErr = False
Herror:
Close
If MayBeErr Then
MsgBox "ERROR !! " & Format$(Err) & ", " & Error$
End If
command1.Enabled = True
Exit Sub
End Sub
Sub Command2_Click ()
Unload HTMLform
End Sub
Sub Command3_Click ()
CMDia1.Action = 1
End Sub
Sub Command4_Click ()
CMDia2.Action = 2
End Sub
Function ConvertAllASCII$ (a$)
Dim i As Integer
Dim b$
Dim c$
b$ = ""
For i = 1 To Len(a$)
c$ = Mid$(a$, i, 1)
Select Case c$
Case """"
b$ = b$ & """
Case "<"
b$ = b$ & "<"
Case ">"
b$ = b$ & ">"
Case "&"
b$ = b$ & "&"
Case " " To "z"
b$ = b$ & c$
Case Else
b$ = b$ & "&#" & Asc(c$) & ";"
End Select
Next i
ConvertAllASCII$ = b$
End Function
Sub Form_Load ()
MaxHeight = Height
MaxWidth = Width
TrimmerForm.Hide
End Sub
Sub Form_Resize ()
If windowstate <> 1 Then
windowstate = 0
Height = MaxHeight
Width = MaxWidth
End If
End Sub
Sub Form_Unload (Cancel As Integer)
TrimmerForm.Show
End Sub
Function ReadLine$ ()
Dim a$, b$
Dim c
Line Input #1, a$
ReadLine$ = RTrim$(Tab2Space$(a$))
End Function
Function Tab2Space$ (c$)
Dim a$, b$
Dim i
a$=c$
While InStr(a$, Chr(9)) > 0
i = InStr(a$, Chr(9)) - 1
b$ = Mid(a$, 1, i)
a$ = b$ & Space$((Int(i / 8) + 1) * 8 - i) & Mid(a$, i + 2)
Wend
Tab2Space$ = RTrim$(a$)
End Function
Sub Text1_Change ()
label1.Caption = "'" & WordAfterSpace((text1.Text)) & "'"
End Sub
Function UpDownTag$ (T$, count As Integer)
Dim a$
a$ = "Up "
UpDownTag$ = a$ & "Dn "
End Function
Function WordAfterSpace$ (a$)
Dim start As Integer
Dim finish As Integer
Dim temp$
start = InStr(a$, " ") + 1
finish = InStr(InStr(start, a$, LTrim$(Mid$(a$, start))) + 1, a$, " ")
If start = 1 Then
temp$ = ""
ElseIf finish < start Then
temp$ = Mid$(a$, start)
Else
temp$ = Mid$(a$, start, finish - start)
End If
temp$ = Trim$(temp$)
If InStr(temp$, ".") > 0 Then
temp$ = Left$(temp$, InStr(temp$, ".") - 1)
End If
WordAfterSpace$ = temp$
End Function