Function Main As String

Dim Form, CurPage As Object
Dim Text, TempStr, UserFileName As String
Dim Props, FileName, Export, RecStr As String
Dim UserAnswer As String
Dim MolNum, PropFlag As Integer
Const Title = "Export to an SDF file."

  CurPage = ActiveDocument.ActivePage
  MolNum = 0
  MolNum = CurPage.Diagrams.Count
  If MolNum = 0 Then
      TempStr = "There are no structures on your page." + Chr(13)
      TempStr = TempStr + "Please draw structure and try again."
      Main = TempStr
      Exit Function
  End If
  'Display form
  Form = ReadForm("ExpSDF.frm")
  If Form.ExecForm Then
      Props=Form.GetStrValue("Properties")
      FileName=Form.GetStrValue("FileName")
      Export=Form.GetStrValue("Export")
  Else 
      Main = "Cancelled"
      Exit Function
  End If
        
 'Process entered data
  PropFlag = 2
  If Props = "Yes" then PropFlag = 1
  If FileName = "" Then 
      FileName = "TestFile.sdf"
  Else
      If Right(FileName, 1) = "\" then 
          FileName = FileName + "TestFile.sdf"
      Else
          FileName = AddDefaultExtension(FileName, "SDF")
      End If
  End If
 
  Open FileName Access Write As #1
       
  If Export="The whole document" Then
      ExportDocument(PropFlag)
  Else
      ExportPage(CurPage, PropFlag, 1)
      RecStr = ">  <ID>"
      Print #1, RecStr
      RecStr = "1"
      Print #1, RecStr
      Print #1, ""
      RecStr = "$$$$"
      Print #1, RecStr
  End If
  Close #1
  Main = "Completed"
End Function

Sub ExportDocument(ByVal PropFlag As Integer)
Dim Page As Object
Dim ID, i As Integer
Dim RecStr As String
 ID = 0
 For i = 1 to ActiveDocument.Count
     ID = ID+1
     Page = ActiveDocument.Item(i)
     ExportPage(Page, PropFlag, 0)
     RecStr = ">  <ID>"
     Print #1, RecStr
     RecStr = Str(ID)
     Print #1, RecStr
     Print #1, ""
     RecStr = "$$$$"
     Print #1, RecStr
 Next i

End Sub

Sub ExportPage(CurPage As Object, ByVal PropFlag As Integer,ByVal WDoc As Integer)
Dim Bond, Atom1, Atom2 As Object
Dim Atoms, Struct, Mol, Conf, Diag As Object
Dim Atoms1, Struct1 As Object
Dim DiagNum As Integer
Dim TempStr, RecStr As String
Dim i As Integer
Dim MolWeight As Double	
  DiagNum = 0
  DiagNum = CurPage.Diagrams.Count
  Atoms = Assemblies.AddEmpty
  Mol = Atoms.Molecules.AddEmpty
  Conf = Atoms.Conformations.AddEmpty
  Struct = Atoms.Structures.Derive(Mol,Conf)
  For Each Diag in CurPage.Diagrams
      Atoms1 = Assemblies.AddFromCS(Diag)
           If Atoms1 = NULL Then
                Stop "Cannot export page. There is an unsupported molecule."
                'MessageBox("Atoms1 is NULL", "Error", MBB_OK)	
                Exit Sub	
           End If
      Struct1 = Atoms1.Structures.Derive(Atoms1.Molecules.Item(1), Atoms1.Conformations.Item(1))
      Atoms.Merge(Struct1)
  Next Diag
  Mol = Atoms.Molecules.Item(1)
  Conf = Atoms.Conformations.Item(1)
  If Atoms = NULL Then
      MessageBox("Atom is NULL", "Error", MBB_OK)	
 	Exit Sub	
  End If
  RecStr = ""
  Print #1, RecStr
  RecStr = "  -ACD/LAB-"
  Print #1, RecStr
  RecStr = ""
  Print #1, RecStr
  RecStr = BuildCountsLine(Atoms)
  Print #1, RecStr
  BuildAtomBlock(Atoms)
  BuildBondBlock(Atoms, Mol)
  BuildPropertiesBlock(Atoms)
  Struct = Atoms.Structures.Item(1)
  Diag = CurPage.Diagrams.Item(1)
  If CurPage.Diagrams.Count = 1 Then
      RecStr = ">  <Formula>"
      Print #1, RecStr
      RecStr = Diag.GetBrutto
      Print #1, RecStr
      Print #1, ""
  End If
  MolWeight = 0
  For i = 1 to CurPage.Diagrams.Count
      MolWeight = MolWeight +  CurPage.Diagrams.Item(i).GetMolWeight
  Next i
  Print #1, ">  <FW>"
  RecStr = FStr(MolWeight, 10, 3)
  Print #1, RecStr
  Print #1, ""
  Kill(Atoms)
  Kill(Atoms1)
End Sub

Function BuildCountsLine(Atoms As Object) As String
Dim Mol As Object
Dim TempStr As String
Dim i, NProp As Integer
Dim Atom As Object
  TempStr = ""
  TempStr = TempStr + AddSpaces(Str(Atoms.Count), 3)
  Mol = Atoms.Molecules.Item(1)
  TempStr = TempStr + AddSpaces(Str(Mol.Count), 3)
  TempStr = TempStr + "  0  0  0  0  0  0  0  0"
  NProp = 0
  For Each Atom in Atoms
      If Atom.GetCharge <> 0 Then NProp = 1
  Next Atom
  TempStr = TempStr + AddSpaces(Str(NProp), 3)
  BuildCountsLine = TempStr
End Function

Function AddSpaces(ByVal s As String, ByVal n As Integer) As String
  AddSpaces = Spc(n-Len(s)) + s
End Function

Function GetTypeOfCharge(ByVal Charge As Integer) As Integer
Dim n As Integer
  Select Case Charge
      Case 3
           n = 1
      Case 2
           n = 2
      Case 1
           n = 3
      Case -1
           n = 5
      Case -2
           n = 6
      Case -3
           n = 7
      Case Else
           n = 0
  End Select
  GetTypeOfCharge = n
End Function 

Sub BuildAtomBlock(Atoms As Object)
Dim Conf, Mol As Object
Dim RecStr As String
Dim Point As Object
Dim x, y, z As Double
Dim n As Integer
Dim TempStr As String
Dim Charge As Integer
  Conf = Atoms.Conformations.Item(1)
  For Each Point in Atoms
      Conf.GetAtomXYZ(Point, x, y, z)
      TempStr = FStr(x, 10, 4) + FStr(y, 10, 4) + FStr(z, 10, 4)
      TempStr = TempStr + AddSpaces(Point.ElSymbol, 3)
      TempStr = TempStr + "  0"
      Charge = GetTypeOfCharge(Point.GetCharge)
      TempStr = TempStr + AddSpaces(Str(Charge), 3)
      RecStr = TempStr + "  0  0  0"
      Print #1, RecStr
  Next Point
End Sub


Sub BuildBondBlock(Atoms As Object, Mol As Object)
Dim Bond As Object
Dim i, n1, n2 As Integer
Dim TempStr As String
Dim Atom1, Atom2 As Object
Dim RecStr As String
  For Each Bond in Mol
      Atom1 = Bond.Atom1
      Atom2 = Bond.Atom2
      n1 = Atoms.Index(Atom1)
      n2 = Atoms.index(Atom2)
      TempStr = AddSpaces(Str(n1), 3) + AddSpaces(Str(n2), 3)
      TempStr = TempStr + AddSpaces(Str(Bond.GetBondOrder), 3) + "  0"
      If Mol.IsRing(Bond) Then
           TempStr = TempStr + AddSpaces(Str(1), 3)
      Else
           TempStr = Tempstr + AddSpaces(Str(2), 3)
      End If
      RecStr = TempStr + "  0  0"
      Print #1, RecStr
  Next Bond
End Sub


Sub BuildPropertiesBlock(Atoms As Object)
Dim Atom As Object
Dim CHGStr, tstr As String
Dim i As Integer
  tstr = ""
  CHGStr = ""
  i = 0
  For Each Atom in Atoms
      If Atom.GetCharge <> 0 Then
           tstr = tstr + AddSpaces(Str(Atoms.Index(Atom)), 4) + AddSpaces(Str(Atom.GetCharge), 4)
           i = i+1
      End If
  Next Atom
  If i <> 0 Then
      CHGStr = "M  CHG" + AddSpaces(Str(i), 3) + tstr
  End If
  If CHGStr <> "" Then Print #1, CHGStr
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function AddDefaultExtension(ByVal FileName As String, ByVal DefExt As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If FileName doesn't have extension then add defext extension to it  '
'                                                                     '
' ENTER                                                               '
'     FileName     suppiled file name                                 '
'     DefExt       default file extension                             '
' EXIT                                                                '
'     returns file name appended with extension, if necessary         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim PointPos, BackslashPos As Integer
  PointPos = RInStr(FileName, ".")
  If PointPos = 0 Then
    AddDefaultExtension = FileName + "." + DefExt
  Else
    BackslashPos = RInStr(FileName, "\")
    If BackslashPos > PointPos Then 
      AddDefaultExtension = FileName + "." + DefExt
    Else
      AddDefaultExtension = FileName
    End If
  End If
End Function

' Returns the rightmost position of substring SubStr inside string S, 0 if S doesn't contain SubStr
Function RInStr(ByVal S As String, ByVal SubStr As String) As Integer
Dim I As Integer

  I = 0
  Do 
    RInStr = I
    I = InStr(I + 1, S, SubStr)
  Loop While I <> 0

End Function
