'Import SDF file with specific field
 
function Main as string
Dim Form as object
Dim Message as string
Dim Number as integer
Dim FileName, FieldName as string
const Title = "Import SDF Data"

  FileName = "Testfile.sdf"
  FieldName = "Formula"
  Number = 4
  Form = ReadForm("Sdf2sk.frm")
  Do
    Form.SetStrValue("FileName", FileName)
    Form.SetIntValue("Number", Number)
    Form.SetStrValue("Field", FieldName)
    ' Display form
    If Form.ExecForm Then
      Number = Form.GetIntValue("Number")
      FileName = Form.GetStrValue("FileName")
      FieldName = Form.GetStrValue("Field")
    Else 
      Main = "Cancelled"    
      Exit Function
    End If
 
    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
 
    if FileExists(FileName) then
      Exit Do
    Else
      Message = "File " + FileName + " is not found." + Chr(13) + "Check the file name, please."
      MessageBox(Message, Title, MBB_OK)
    End If
  Loop While True
  
  ImportFromSDFile(FileName, Number, FieldName)

  Main = "Completed"

end function

function FileExists(byval FileName as string) as boolean
Dim fname as string

  FileExists = FindFirst(FileName, fname)

end function

sub ImportFromSDFile(FName as string, ByVal Res as integer, ByVal FieldName as string)
Dim NumRec as integer
Dim LineOfRec as string
Dim i as integer
Dim x, y, z as double
Dim NumAtoms, NumBonds, NumAdProp, ChiralFlag as integer
Dim AtomName as string
Dim ElNum as integer
Dim ElMass as double
Dim Atom as object
Dim Struct, Mol, Atoms, Conf, Diag as object
Dim NumAtom1, NumAtom2 as integer
Dim BondType as integer
Dim Atom1, Atom2, Bond as object
Dim MinDist as double
Dim pw, ph, l, t, w, h as integer
Dim MessField as string
Dim TBox as object
Dim Flag as integer
Dim J, sl, st, DiagNum as integer
Dim workpage, NewPage as object
Dim N, sw, sh as integer
Dim Diag as object
Dim minScale, scaleX, scaleY as double
Dim ACharge as integer
Dim CHGStr as string
Dim jj as integer
	' Res - Number of structures
	
	N = Int(Res/2)
	
	workpage = ActiveDocument.ActivePage
	if workpage.Drawings.Count <> 0 then workpage = ActiveDocument.AddEmpty
	
	pw = workpage.GetWidth
	ph = workpage.GetHeight
	
  	if Res > 2*N then N = N+1
	
	sw = Int((pw-300)/2)
  	sh = Int((ph-300)/N)
        Open FName Access read as 1
        NumRec = 0
	J = 0
	sl = 150
	st = 150
         
L1:     read #1, LineOfRec, 80
        read #1, LineOfRec, 80
        if DelSpace(LineOfRec) = "" then
     	close #1
     	exit sub
        end if
        read #1, LineOfRec, 80
        read #1, LineOfRec, 80
        NumRec = NumRec+1
        J = J+1
        NumAtoms = Int(Val(Mid(LineOfRec, 1, 3)))
        NumBonds = Int(Val(Mid(LineOfRec, 4, 3)))
        NumAdProp = Int(Val(Mid(LineOfRec, 31, 3)))
        'MessageBox(Str(NumAtoms) + Chr(13) + Str(NumBonds) + Chr(13) + Str(NumAdProp), "Atoms, Bonds, AdProp = ", MBB_OK )
        ChiralFlag = Int(Val(Mid(LineOfRec, 25, 3)))
        'Read atoms
        Atoms = Assemblies.AddEmpty
        Conf = Atoms.Conformations.AddEmpty
        Mol = Atoms.Molecules.AddEmpty
        Struct = Atoms.Structures.Derive(Mol, Conf)
        for i = 1 to NumAtoms
           read #1, LineOfRec, 80
           x = Val(Mid(LineOfRec, 1, 10))
           y = Val(Mid(LineOfRec, 11, 10))
           z = Val(Mid(LineOfRec, 21, 10))
           AtomName = DelSpace(Mid(LineOfRec, 31, 3))
           AtomProperties(AtomName, ElNum, ElMass)
           'MessageBox(Str(ElNum), "ElNum", MBB_OK)
           ACharge = GetTypeOfCharge(Int(Val(Mid(LineOfRec, 37, 3))))
           Atom = NewAtom(ElNum)
           Struct.Assembly.Add(Atom)	
           Atom.SetCharge(ACharge)
           Struct.SetAtomXYZ(Atom, x, y, z)
        next i
       'read bonds

        for i = 1 to NumBonds
           read #1, LineOfRec, 80
           NumAtom1 = Int(Val(Mid(LineOfRec, 1, 3)))
           NumAtom2 = Int(Val(Mid(LineOfRec, 4, 3)))
           'MessageBox(Str(NumAtom1) + Chr(13) + Str(NumAtom2), "NumAtoms 1 2 =", MBB_OK)
           BondType = SelectTypeBond(Int(Val(Mid(LineOfRec, 7, 3))))
           Atom1 = Atoms.Item(NumAtom1)
           Atom2 = Atoms.Item(NumAtom2)
           Bond = NewBond(Atom1, Atom2, BondType)
           Struct.Molecule.Add(Bond)
        next i
	read #1, LineOfRec, 80
	while Left(LineOfRec, 1) <> ">" and  Left(LineOfRec, 4) <> "$$$$"
		
       		if Left(LineOfRec, 6) = "M  CHG" then
       			CHGStr = Mid(LineOfRec, 7, 73)
       			if Int(Val(Mid(LineOfRec, 7, 3))) <> 0 then
       				jj = 10
       				for i =1 to Int(Val(Mid(LineOfRec, 7, 3))) 
       					Atom = Atoms.Item(Int(Val(Mid(LineOfRec, jj, 4))))
       					jj = jj+4
       					ACharge = Int(Val(Mid(LineOfRec, jj, 4)))
       					Atom.SetCharge(ACharge)
       					jj = jj+4
       				next i
       			end if	
       		end if
		
        	read #1, LineOfRec, 80
        wend
	MinDist = GetMinBondLength(Conf, Mol)
	if GetMinBondLength(Conf, Mol) > 1.36 then SetBondLenth(Struct, Mol, 1.36)
	
    	if Res >= 1 then
      		'MessageBox(Str(J) + Chr(13) + Str(NumRec), "J, nrecord = ", MBB_OK)
      		if J = 1 and NumRec > 1 then
        		NewPage = ActiveDocument.AddEmpty
        		if NewPage = NULL then
          			MessageBox("Document is full.", "SDF To Sketch Converter", MBI_EXCLAMATION)
        		end if
       			ActiveDocument.SetActivePage(NewPage)
			workpage = ActiveDocument.ActivePage
      		end if
      		
      		diag = workpage.Diagrams.AddEmpty
      		diag.Depict(struct)
      		diag.GetBound(l,t,w,h)
      		if w > sw or h > sh-100 then
            		scaleX = sw/w
            		scaleY = (sh-200)/h
            		minScale = MinDouble(scaleX, scaleY)
            		diag.SetBound(sl, st, Int(w*minScale), Int(h*minScale))
      		else
        		diag.SetBound(sl, st, w, h)
      		end if
      		if J < N  or J > N then
        		st = st+sh
      		else
        		if J = N then
          			sl = sl+sw
          			st = 150
        		end if
      		end if
      		if J = Res then
        		J = 0
        		sl = 150
        		st = 150
      		end if
    	end if
	MessField = ""
	Flag = 0
	while Left(LineOfRec, 4) <> "$$$$"
		
		if Left(LineOfRec, 1) = ">" then
			MessField = ""
			'MessageBox(">Yes", "", MBB_OK)
			if InStr(2, Ucase(LineOfRec), Ucase(FieldName)) <> 0 then
				'MessageBox(FieldName + " Yes", "",MBB_OK)
				Flag = 1
				MessField = FieldName 
				read #1, LineOfRec, 80
				while Left(LineOfRec, 1) <> ">" and Left(LineOfRec, 4) <> "$$$$"
					if DelSpace(LineOfRec) <> "" then
						MessField = MessField + "  " + LineOfRec
						'MessageBox(MessField, "MessField", MBB_OK)
					end if
					read #1, LineOfRec, 80
				wend		
			end if
		end if
		if MessField = "" then
			read #1, LineOfRec, 80
		else
			if Flag = 1 then	
				diag.GetBound(l, t, w, h)		
				'MessageBox(Str(h), "h=", MBB_OK)
				TBox = workpage.TextBoxes.AddEmpty
				TBox.SetContent(MessField)
				TBox.SetBound(l, h+t+100,1000, 100)	
			end if
		end if
	wend
	
	Kill(Atoms)
	GOTO L1
	
end sub

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 

function MinDouble(x1 as double, x2 as double) as double
	if x1 < x2 then MinDouble = x1
	MinDouble = x2
end function

sub SetBondLenth(Struct as object, Mol as object, ByVal Dist as double)
Dim CurBond as object
	for each CurBond in Mol
		Struct.SetBLen(CurBond.Atom1, CurBond.Atom2, Dist)
	next CurBond
end sub

function GetMinBondLength(Conf as Object, Mol as Object) as Double
Dim MinIsFound as Boolean
Dim MinDist, Dist as Double
Dim CurBond as Object

	MinIsFound = False
	MinDist = 0
	for each CurBond in Mol
		Dist = Conf.GetDist(CurBond.Atom1, CurBond.Atom2)
		if (not MinIsFound) or (Dist < MinDist) then MinDist = Dist
		MinIsFound = True
	next CurBond

	GetMinBondLength = MinDist
end function

function SelectTypeBond(ByVal Bond as integer) as integer
Dim TBond as integer

  select case Bond
    case 1
      TBond = BO_SINGLE
    case 2
      TBond = BO_DOUBLE
    case 3
      TBond = BO_TRIPLE
    case 4
      TBond = BO_AROMATIC
    case else
      TBond = BO_SINGLE
  end select
  SelectTypeBond = TBond

end function

sub AtomProperties(elname as string, elnum as integer, fmass as double)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Returns element's properties                                        '
'                                                                     '
' ENTER                                                               '
'     ElSymb          the string for chemical symbol                  '
' EXIT                                                                '
'     returns TRUE if the string match some element otherwise FALSE   '
'     fills in if applicable:                                         '
'     ElNumber        element number, integer                         '
'     imass           element mass, integer                           '
'     fmass           element mass, double                            '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim s as string
Dim imass as integer
  Select Case Ucase(elname)
        Case "H"
          elnum=1 : imass=1 : fmass=1.0079
        Case "D"
          elnum=1 : imass=2: fmass=2.0100
        Case "T"
          elnum=1 : imass=3: fmass=3.0200
        Case "HE"
          elnum=2 : imass=4: fmass=4.0026
        Case "LI"
          elnum=3 : imass=7: fmass=6.9410
        Case "BE"
          elnum=4 : imass=9: fmass=9.0122
        Case "B"
          elnum=5 : imass=11: fmass=10.8110
        Case "C"
          elnum=6 : imass=12: fmass=12.0107
        Case "N"
          elnum=7 : imass=14: fmass=14.0067
        Case "O"
          elnum=8 : imass=16: fmass=15.9994
        Case "F"
          elnum=9 : imass=19: fmass=18.9984
        Case "NE"
          elnum=10 : imass=20: fmass=20.1797
        Case "NA"
          elnum=11 : imass=23: fmass=22.9898
        Case "MG"
          elnum=12 : imass=24: fmass=24.3050
        Case "AL"
          elnum=13 : imass=27: fmass=26.9815
        Case "SI"
          elnum=14 : imass=28: fmass=28.0855
        Case "P"
          elnum=15 : imass=31: fmass=30.9738
        Case "S"
          elnum=16 : imass=32: fmass=32.0660
        Case "CL"
          elnum=17 : imass=35: fmass=35.4527
        Case "AR"
          elnum=18 : imass=40: fmass=39.9480
        Case "K"
          elnum=19 : imass=39: fmass=39.0983
        Case "CA"
          elnum=20 : imass=40: fmass=40.0780
        Case "SC"
          elnum=21 : imass=45: fmass=44.9559
        Case "TI"
            elnum=22: imass=48: fmass=47.8670
        Case "V"
            elnum=23 : imass=51: fmass=50.9415
        Case "CR"
            elnum=24: imass=52: fmass=51.9961
        Case "MN"
            elnum=25: imass=55: fmass=54.9380
        Case "FE"
            elnum=26: imass=56: fmass=55.8450
        Case "CO"
            elnum=27: imass=59: fmass=58.9332
        Case "NI"
            elnum=28 : imass=59: fmass=58.6934
        Case "CU"
            elnum=29 : imass=64: fmass=63.5460
        Case "ZN"
            elnum=30 : imass=65: fmass=65.3900
        Case "GA"
            elnum=31 : imass=70: fmass=69.7230
        Case "GE"
            elnum=32 : imass=73: fmass=72.6100
        Case "AS"
            elnum=33 : imass=75: fmass=74.9216
        Case "SE"
            elnum=34 : imass=79: fmass=78.9600
        Case "BR"
            elnum=35 : imass=80: fmass=79.9040
        Case "KR"
            elnum=36 : imass=84: fmass=83.8000
        Case "RB"
            elnum=37 : imass=85: fmass=85.4678
        Case "SR"
            elnum=38 : imass=88: fmass=87.6200
        Case "Y"
            elnum=39 : imass=89: fmass=88.9058
        Case "ZR"
            elnum=40 : imass=91: fmass=91.2240
        Case "NB"
            elnum=41 : imass=93: fmass=92.9064
        Case "MO"
            elnum=42 : imass=96: fmass=95.9400
        Case "TC"
            elnum=43 : imass=98: fmass=98.0000
        Case "RU"
            elnum=44 : imass=101: fmass=101.0700
        Case "RH"
            elnum=45 : imass=103: fmass=102.9055
        Case "PD"
            elnum=46 : imass=106: fmass=106.4200
        Case "AG"
            elnum=47 : imass=108: fmass=107.8682
        Case "CD"
            elnum=48 : imass=112: fmass=112.4110
        Case "IN"
            elnum=49 : imass=115: fmass=114.8180
        Case "SN"
            elnum=50 : imass=119: fmass=118.7100
        Case "SB"
            elnum=51 : imass=122: fmass=121.7600
        Case "TE"
            elnum=52 : imass=128: fmass=127.6000
        Case "I"
            elnum=53 : imass=127: fmass=126.9045
        Case "XE"
            elnum=54 : imass=131: fmass=131.2900
        Case "CS"
            elnum=55 : imass=133: fmass=132.9054
        Case "BA"
            elnum=56 : imass=137: fmass=137.3270
        Case "LA"
            elnum=57 : imass=139: fmass=138.9055
        Case "CE"
            elnum=58 : imass=140: fmass=140.1160
        Case "PR"
            elnum=59 : imass=141: fmass=140.9076
        Case "ND"
            elnum=60 : imass=144: fmass=144.2400
        Case "PM"
            elnum=61 : imass=145: fmass=145.0000
        Case "SM"
            elnum=62 : imass=150: fmass=150.3600
        Case "EU"
            elnum=63 : imass=152: fmass=151.9640
        Case "GD"
            elnum=64 : imass=157: fmass=157.2500
        Case "TB"
            elnum=65 : imass=159: fmass=158.9253
        Case "DY"
            elnum=66 : imass=163: fmass=162.5
        Case "HO"
            elnum=67 : imass=165: fmass=164.9303
        Case "ER"
            elnum=68 : imass=167: fmass=167.2600
        Case "TM"
            elnum=69 : imass=169: fmass=168.9342
        Case "YB"
            elnum=70 : imass=173: fmass=173.0400
        Case "LU"
            elnum=71 : imass=175: fmass=174.9670
        Case "HF"
            elnum=72 : imass=178: fmass=178.4900
        Case "TA"
            elnum=73 : imass=181: fmass=180.9479
        Case "W"
            elnum=74 : imass=184: fmass=183.8400
        Case "RE"
            elnum=75 : imass=186: fmass=186.2070
        Case "OS"
            elnum=76 : imass=190: fmass=190.2300
        Case "IR"
            elnum=77 : imass=192: fmass=192.2170
        Case "PT"
            elnum=78 : imass=195: fmass=195.0780
        Case "AU"
            elnum=79 : imass=197: fmass=196.9666
        Case "HG"
            elnum=80 : imass=201: fmass=200.5900
        Case "TL"
            elnum=81 : imass=204: fmass=204.3833
        Case "PB"
            elnum=82 : imass=207: fmass=207.2000
        Case "BI"
            elnum=83 : imass=209: fmass=208.9804
        Case "PO"
            elnum=84 : imass=209: fmass=209.0000
        Case "AT"
            elnum=85 : imass=210: fmass=210.0000
        Case "RN"
            elnum=86 : imass=222: fmass=222.0000
        Case "FR"
            elnum=87 : imass=223: fmass=223.0000
        Case "RA"
            elnum=88 : imass=226: fmass=226.0000
        Case "AC"
            elnum=89 : imass=227: fmass=227.0000
        Case "TH"
            elnum=90 : imass=232: fmass=232.0381
        Case "PA"
            elnum=91 : imass=231: fmass=231.0359
        Case "U"
            elnum=92 : imass=238: fmass=238.0289
        Case "NP"
            elnum=93 : imass=237: fmass=237.0000
        Case "PU"
            elnum=94 : imass=244: fmass=244.0000
        Case "AM"
            elnum=95 : imass=243: fmass=243.0000
        Case "CM"
            elnum=96 : imass=247: fmass=247.0000
        Case "BK"
            elnum=97 : imass=247: fmass=247.0000
        Case "CF"
            elnum=98 : imass=251: fmass=251.0000
        Case "ES"
            elnum=99 : imass=252: fmass=252.0000
        Case "FM"
            elnum=100 : imass=257: fmass=257.0000
        Case "MD"
            elnum=101 : imass=258: fmass=258.0000
        Case "NO"
            elnum=102 : imass=259: fmass=259.0000
        Case "LR"
            elnum=103 : imass=262: fmass=262.0000
        Case "KU"
            elnum=104 : imass=265: fmass=Dbl(imass)
        Case else
            elnum=0: imass=0: fmass=0.0
  End Select

end sub

function DelSpace(BYVal s as string) as string
Dim SLet as string
Dim i as integer
Dim TempStr as string
        TempStr = ""
        for i = 1 to Len(s)
           SLet = Mid(s, i, 1)
           if SLet <> " " then TempStr = TempStr + SLet
        next i
        DelSpace = TempStr
end function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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
