' Sk2VRML.BAS

CONST TITLE="Export To VRML 2.0"
CONST BALLSTICKS=1
CONST STICKS=2
CONST SPACEFILL=3

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Main As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The utility exports the structures to VRML 2.0                      '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Form, page, diag, asm, struc, allstruc As Object
Dim FileName, ViewMode As String
Dim OK As Boolean
Dim ndiag, i As Integer

  Main="There is no structure on your page."

  page=ActiveDocument.ActivePage
  ndiag=page.Diagrams.Count
  If ndiag<1 Then Exit Function

  Form = ReadForm("Sk2vrml.frm")
  Form.SetStrValue("Remark","     "+Str(ndiag)+"  structure(s) will be exported to VRML 2.0 file.")
  ' Display form
  If Form.ExecForm Then
      FileName=Form.GetStrValue("FileName")
      ViewMode=Form.GetStrValue("View")
  Else 
      Main = "Cancelled"    
      Exit Function
  End If

  If FileName = "" Then 
      FileName = "Exported"
  Else
      If Right(FileName, 1) = "\" then 
          FileName = FileName + "Exported"
      Else
          FileName = RemoveExtension(FileName)
      End If
  End If

  diag=page.Diagrams.Item(1)
  asm=Assemblies.AddFromCS(diag)
  If asm=NULL Then Exit Function
  struc=Asm.Structures.Item(1)
  If struc=NULL Then Exit Function

  allstruc=struc
  For i=2 To ndiag
    diag=page.Diagrams.Item(i)
    asm=Assemblies.AddFromCS(diag)
    If asm<>NULL Then
      struc=asm.Structures.Item(1)
      If struc<>NULL Then allstruc.Assembly.Merge(struc)
    End If
  Next i

  Select Case ViewMode
    Case "Ball-and-sticks"
            OK=SaveStructureAsVRML2File(allstruc,FileName,BALLSTICKS)
    Case "Sticks"
            OK=SaveStructureAsVRML2File(allstruc,FileName,STICKS)
    Case "Fill-space"
            OK=SaveStructureAsVRML2File(allstruc,FileName,SPACEFILL)
  End Select

  If OK Then Main = "Completed."
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function SaveStructureAsVRML2File(Struct As  object,ByVal FileName As  String,ByVal view As  Integer) As  boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Write VRML2 file                                                    '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim i,j,natoms,nbonds,bnd1(1),bnd2(1),border(1) As  Integer, elsym(1) As  String
Dim x(1),y(1),z(1),xx,yy,zz,xbt,ybt,zbt,xmb,ymb,zmb,h,htmp,red,green,blue As  Double
  SaveStructureAsVRML2File = TRUE

  ' Prepare a structure (collect atomic data, etc.)
  AdjustXYZToCenter(struct)
  CollectMolInfo(struct,natoms,nbonds,elsym,x,y,z,bnd1,bnd2,border)

  ' Write a file
  Open FileName+".WRL" Access Write As  2

  ' Header
  Print #2,"#VRML V2.0 utf8" :Print #2,"Group {" : Print #2,"children ["

  ' Atoms
  For i=1 to natoms
    VRMLAtomColor(elsym(i),red,green,blue)
    Print #2,"Transform {"
    Print #2,"   translation ",x(i)," ",y(i)," ",z(i)
    Print #2,"   children ["
    Print #2,"      Shape {"
    Print #2,"      appearance Appearance {"
    Print #2,"          material Material {"
    Print #2,"          diffuseColor "+Str(red)+" "+Str(green)+" "+Str(blue)
    Print #2,"      }}"
    Print #2,"      geometry Sphere {"
    Select Case view
      Case 1
        If UCase(elsym(i))="H" Then
          Print #2,"      radius",Spc(1),0.15
        Else
          Print #2,"      radius",Spc(1),0.25
        End If
      Case 2
        Print #2,"      radius",Spc(1),0.10
      Case 3
        If UCase(elsym(i))="H" Then
          Print #2,"      radius",Spc(1),0.85
        Else
          Print #2,"      radius",Spc(1),1.20
        End If
      End Select
    Print #2," }}]}"
  Next i 'atom


' Bonds
   If view<3 Then
    For i=1 to nbonds
       xx=(x(bnd1(i))-x(bnd2(i)))^2
       yy=(y(bnd1(i))-y(bnd2(i)))^2
       zz=(z(bnd1(i))-z(bnd2(i)))^2
       h=(XX+YY+ZZ)^(0.5)
       VRMLGetBondMid(x(bnd1(i)),y(bnd1(i)),z(bnd1(i)),x(bnd2(i)),y(bnd2(i)),z(bnd2(i)),xmb,ymb,zmb)
       For j=1 to 2
         If j=1 Then VRMLGetBondMid(x(bnd1(i)),y(bnd1(i)),z(bnd1(i)),xmb,ymb,zmb,xbt,ybt,zbt)
         If j=2 Then VRMLGetBondMid(x(bnd2(i)),y(bnd2(i)),z(bnd2(i)),xmb,ymb,zmb,xbt,ybt,zbt)
         VRMLBondColor( x(bnd1(i)),y(bnd1(i)),z(bnd1(i)),elsym(bnd1(i)),x(bnd2(i)),y(bnd2(i)),z(bnd2(i)),elsym(bnd2(i)),xbt,ybt,zbt,red,green,blue)
         Print #2,"Transform {"
         Print #2,"      translation "+Str(xbt)+" "+Str(ybt)+" "+Str(zbt)
         htmp=h/2
         If J=1 Then Print #2,"      ",VRMLStringBondRot(htmp,x(bnd1(i)),y(bnd1(i)),z(bnd1(i)),xmb,ymb,zmb)
         If J=2 Then Print #2,"      ",VRMLStringBondRot(htmp,x(bnd2(i)),y(bnd2(i)),z(bnd2(i)),xmb,ymb,zmb)
         Print #2,"   children ["
         Print #2,"      Shape {"
         Print #2,"      appearance Appearance {"
         Print #2,"          material Material {"
         Print #2,"      diffuseColor "+Str(red)+" "+Str(green)+" "+Str(blue)
         Print #2,"      }}"
         Print #2,"      geometry Cylinder {"
         Print #2,"               height ",h/2
         Print #2,"               radius 0.10"
         Print #2," }}]}"
       Next j
    Next i
  End If

' Tail
  Print #2,"]"
  Print #2,"}"

  Close #2
End Function 'Write_VRML_File



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub VRMLAtomColor(s As  String,r As  Double,g As  Double,b As  Double)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Define atom colors for virtual reality view                         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Select Case UCase(s)
        Case "H"
          r=1 :g=1: b=1
        Case "C"
          r=0.6 :g=0.6: b=0.6
        Case "N"
          r=0 :g=0: b=1
        Case "O"
          r=1 :g=0: b=0
        Case "F"
          r=0 :g=1: b=0
        Case "CL"
          r=0 :g=0.9: b=0.1
        Case "BR"
          r=0 :g=0.8: b=0.2
        Case "I"
          r=0 :g=0.7: b=0.3
        Case "S"
          r=1 :g=1: b=0
        Case "P"
          r=1 :g=0.8: b=0
        Case Else
          r=0.75:g=0.75: b=0.75
  End Select
End Sub



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub VRMLBondColor(X1 As  Double,Y1 As  Double,Z1 As  Double,N1 As  String,X2 As  Double,Y2 As  Double,Z2 As  Double,N2 As  String,xbt As  Double,ybt As  Double,zbt As  Double,r As  Double,g As  Double,b As  Double)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Define bond colors for virtual reality view                         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim D1,D2 As  Double
  D1=((X1-xbt)^2+(Y1-ybt)^2+(Z1-zbt)^2)^(0.5)
  D2=((X2-xbt)^2+(Y2-ybt)^2+(Z2-zbt)^2)^(0.5)
  If D1>D2 Then
    VRMLAtomColor(N2,r,g,b)
  Else
    VRMLAtomColor(N1,r,g,b)
  End If
End Sub



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub VRMLGetBondMid(X1 As  Double,Y1 As  Double,Z1 As  Double,X2 As  Double,Y2 As  Double,Z2 As  Double,xbt As  Double,ybt As  Double,zbt As  Double)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Write VRML2 file - service routine                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim X1d,Y1d,Z1d,X2d,Y2d,Z2d,X3d,Y3d,Z3d As  Double
  X1d=X1 : X2d=X2
  If X1>X2 Then
   X1d=X2 :X2d=X1
  End If
  Y1d=Y1 : Y2d=Y2
  If Y1>Y2 Then
   Y1d=Y2 : Y2d=Y1
  End If
  Z1d=Z1 : Z2d=Z2
  If Z1>Z2 Then
   Z1d=Z2 : Z2d=Z1
  End If
  xbt=X1d+1/2*(X2d-X1d) : ybt=Y1d+1/2*(Y2d-Y1d) : zbt=Z1d+1/2*(Z2d-Z1d)
End Sub



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function VRMLStringBondRot(Length As  Double,X1 As  Double,Y1 As  Double,Z1 As  Double,X2 As  Double,Y2 As  Double,Z2 As  Double) As  String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Write VRML2 file - service routine                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim X3,Y3,Z3,X4,Y4,Z4,X5,Y5,Z5,XXX,YYY,ZZZ As  Double
  If X2>X1 Then
    X3=X2-X1 : XXX=1
  Else
    X3=X1-X2 : XXX=-1
  End If
  If Y2>Y1 Then
    YYY=1 : Y3=Y2-Y1
  Else
    YYY=-1 : Y3=Y1-Y2
  End If
  If Z2>Z1 Then
    ZZZ=1 : Z3=Z2-Z1
  Else
    ZZZ=-1 : Z3=Z1-Z2
  End If
  X4=0 : Y4=Length : Z4=0
  If X3>X4 Then
    X5=XXX*(X4+(X3-X4)/2)
  Else
    X5=XXX*(X3+(X4-X3)/2)
  End If
  If Y3>Y4 Then
    Y5=YYY*(Y4+(Y3-Y4)/2)
  Else
    Y5=YYY*(Y3+(Y4-Y3)/2)
  End If
  If Z3>Z4 Then
    Z5=ZZZ*(Z4+(Z3-Z4)/2)
  Else
    Z5=ZZZ*(Z3+(Z4-Z3)/2)
  End If
  VRMLStringBondRot="rotation"+Spc(1)+Str(X5)+Spc(1)+Str(Y5)+Spc(1)+Str(Z5)+Spc(1)+"3.1415"
End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CollectMolInfo(Struct As  object,natoms As  Integer, nbonds As  Integer,elsym() As  String, x() As  Double, y() As  Double, z() As  Double, bnd1() As  Integer, bnd2() As  Integer, border() As  Integer)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Collect atomic info for further exporting                           '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim i As  Integer,atoms,bonds,atom,bond As  object
  atoms=Struct.Assembly
  natoms=atoms.Count
  ReDim elsym(natoms):ReDim x(natoms):ReDim y(natoms):ReDim z(natoms)
  For i=1 to natoms
    atom=atoms.Item(i)
    elsym(i)=RTrim(atom.ElSymbol)
    Struct.GetAtomXYz(atom,x(i),y(i),z(i))
  Next i
  bonds=Struct.Molecule
  nbonds=bonds.Count
  If nbonds > 0 Then 'todo: check what we'll have if there are no bonds
    ReDim bnd1(nbonds):ReDim bnd2(nbonds):ReDim border(nbonds)
    For i=1 to nbonds
      bond=bonds.Item(i)
      bnd1(i)= atoms.Index(bond.Atom1)
      bnd2(i)= atoms.Index(bond.Atom2)
      border(i) = bond.GetBondOrder
    Next i
  End If
End Sub



' Remove extension from the given filename
function RemoveExtension(ByVal FileName As String) As String
Dim PointPos, BackslashPos As Integer

  PointPos = RInStr(FileName, ".")
  If PointPos = 0 Then
    RemoveExtension = FileName
  Else
    BackslashPos = RInStr(FileName, "\")
    If BackslashPos > PointPos Then
      RemoveExtension = FileName
    Else
      RemoveExtension = Left(FileName, PointPos - 1)
    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



'***LIBRARY PROCEDURES BEGIN



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AdjustXYZToCenter(strconf As Object)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Go to center-of-molecule coordinate system                          '
'                                                                     '
' ENTER                                                               '
'     strconf         object of type CB_CONFORMATION or CB_STRUCTURE  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim x(1),y(1),z(1),x0,y0,z0,xx,yy,zz As Double, i,natoms As Integer, asm As Object

  If strconf.GetType<>CB_STRUCTURE And strconf.GetType<>CB_CONFORMATION Then Exit Sub

  asm=strconf.Assembly
  With asm
    natoms=.Count
    Redim x(natoms) : Redim y(natoms) : Redim z(natoms)
    x0=0.0 : y0=0.0 : z0=0.0
    For i=1 to natoms
      strconf.GetAtomXyz(.Item(i),x(i),y(i),z(i))
      x0=x0+x(i) : y0=y0+y(i) : z0=z0+z(i)
    Next i
    x0=x0/Dbl(natoms) : y0=y0/Dbl(natoms) : z0=z0/Dbl(natoms)
    For i=1 to natoms
      strconf.SetAtomXyz(.Item(i),x(i)-x0,y(i)-y0,z(i)-z0)
    Next i
  End With
End Sub


'***LIBRARY PROCEDURES END