Option Explicit
Dim fileNumber As String, excelSgCode As Integer
Dim generatorLineStart(1 To 3, 1 To 3, 1 To 3) As Integer 'internal SG Code; [4,6,12] polyhedron; polyhedron count
Dim operatorLineStart(1 To 3) As Integer 'initial lines for symmetry operators in sheet "symmetry operators"
Dim generatorInteger(1 To 5) As Integer
Dim sgCode As Integer
Dim brv As Boolean, iMB As Integer
Dim errorStatus As Boolean
Dim errorString As String
Dim referenceText As String
Property Let cifNumber(value As String)
fileNumber = value
End Property
Property Let spaceGroupCode(value As Integer)
sgCode = value
End Property
Property Get errorMessage(value As String)
value = errorString
End Property
Property Get onError(value As Boolean)
value = errorStatus
End Property
Sub transferSymmGenerators()
Dim inputLine As String
Dim pathname As String
Dim nField As Integer
Dim outputString(1 To 16) As String
Dim i As Integer, j As Integer, k As Integer
Dim nDataBlock As Integer
Dim useDataBlock(1 To 12) As Boolean
Dim volumeBlock(1 To 12) As Double
Dim multiplicityBlock(1 To 12) As String
Dim cnBlock(1 To 12) As Integer
Dim dbStart(1 To 12) As Integer
Dim dbEnd(0 To 11) As Integer
Dim atomsBlock(1 To 12) As String
Dim lineStore(1 To 72) As String
Dim nLineStore As Integer
Dim blockLineStart(1 To 12) As Integer
Dim nOctahedra As Integer, nTetrahedra As Integer
Dim cationGenerator(1 To 12, 1 To 5) As Integer
Dim anionGenerator(1 To 5) As Integer
Dim lineNumber As Integer
'...
pathname = micaExcelFolder & "xlTransferSymmGenerators" & LTrim(Str(sgCode)) & ".txt"
Open pathname For Input As #1
Do Until EOF(1)
Line Input #1, inputLine
brv = interpretLine(inputLine, outputString, nField)
If outputString(1) = "DATA" And outputString(2) = fileNumber Then
'...Entry matched. Read data until end of entry
nLineStore = 0
outputString(1) = ""
Do Until outputString(1) = "DATA"
Line Input #1, inputLine
nLineStore = nLineStore + 1
lineStore(nLineStore) = inputLine
brv = interpretLine(inputLine, outputString, nField)
If outputString(1) = "GENERATOR" Then
nDataBlock = nDataBlock + 1
useDataBlock(nDataBlock) = True
dbStart(nDataBlock) = nLineStore
dbEnd(nDataBlock - 1) = nLineStore - 1
cnBlock(nDataBlock) = outputString(2)
For j = 1 To 5
cationGenerator(nDataBlock, j) = outputString(j + 2)
Next j
cationGenerator(nDataBlock, 1) = cationGenerator(nDataBlock, 1) + 1
cationGenerator(nDataBlock, 2) = cationGenerator(nDataBlock, 2) + 1
volumeBlock(nDataBlock) = Replace(outputString(nField), ".", decimalSeparator)
atomsBlock(nDataBlock) = outputString(nField - 2) & " " & outputString(nField - 1)
End If
Loop
dbEnd(nDataBlock) = nLineStore - 1
End If
Loop
Close #1
'..........
For i = 1 To nDataBlock
multiplicityBlock(i) = "" 'default option
If cnBlock(i) = 6 Then multiplicityBlock(i) = "1" 'default option
Next i
'.....eliminate any repeated octahedra
For i = 1 To nDataBlock - 1
For k = i + 1 To nDataBlock
If Abs(volumeBlock(k) - volumeBlock(i)) < 0.0001 Then
useDataBlock(k) = False
multiplicityBlock(i) = "2"
End If
Next k
Next i
'Assign sheet line-numbers according to space group
  nOctahedra = 0
  nTetrahedra = 0
If sgCode = 12 Then
For i = 1 To nDataBlock
If useDataBlock(i) Then
   If cnBlock(i) = 12 Then
   blockLineStart(i) = 2
   ElseIf cnBlock(i) = 4 Then
   blockLineStart(i) = 18
   Else
     nOctahedra = nOctahedra + 1
     If nOctahedra = 1 Then
     blockLineStart(i) = 26
     Else
     blockLineStart(i) = 36
     End If
   End If
End If
Next i
ElseIf sgCode = 15 Then
For i = 1 To nDataBlock
If useDataBlock(i) Then
   If cnBlock(i) = 12 Then
   blockLineStart(i) = 2
   ElseIf cnBlock(i) = 4 Then
     nTetrahedra = nTetrahedra + 1
     If nTetrahedra = 1 Then
     blockLineStart(i) = 18
     Else
     blockLineStart(i) = 26
     End If
   Else
     nOctahedra = nOctahedra + 1
     If nOctahedra = 1 Then
     blockLineStart(i) = 34
     Else
     blockLineStart(i) = 44
     End If
   End If
End If
Next i
ElseIf sgCode = 151 Then 'SG 151
For i = 1 To nDataBlock
If useDataBlock(i) Then
   If cnBlock(i) = 12 Then
   blockLineStart(i) = 2
   ElseIf cnBlock(i) = 4 Then
     nTetrahedra = nTetrahedra + 1
     If nTetrahedra = 1 Then
     blockLineStart(i) = 18
     Else
     blockLineStart(i) = 26
     End If
   Else
     nOctahedra = nOctahedra + 1
     If nOctahedra = 1 Then
     blockLineStart(i) = 34
     ElseIf nOctahedra = 2 Then
     blockLineStart(i) = 44
     Else
     blockLineStart(i) = 54
     End If
   End If
End If
Next i
ElseIf sgCode = 58 Then
For i = 1 To nDataBlock
If useDataBlock(i) Then
   If cnBlock(i) = 12 Then
     blockLineStart(i) = 2
   ElseIf cnBlock(i) = 4 Then
     nTetrahedra = nTetrahedra + 1
     If nTetrahedra = 1 Then
     blockLineStart(i) = 18
     Else
     blockLineStart(i) = 26
     End If
   Else
     nOctahedra = nOctahedra + 1
     If nOctahedra = 1 Then
     blockLineStart(i) = 34
     ElseIf nOctahedra = 2 Then
     blockLineStart(i) = 44
     ElseIf nOctahedra = 3 Then
     blockLineStart(i) = 54
     Else
     blockLineStart(i) = 64
     End If
   End If
End If
Next i
ElseIf sgCode = 63 Then
For i = 1 To nDataBlock
If useDataBlock(i) Then
   If cnBlock(i) = 12 Then
   blockLineStart(i) = 2
   ElseIf cnBlock(i) = 4 Then
     nTetrahedra = nTetrahedra + 1
     blockLineStart(i) = 18
   Else
     nOctahedra = nOctahedra + 1
     If nOctahedra = 1 Then
     blockLineStart(i) = 26
     Else
     blockLineStart(i) = 36
     End If
   End If
End If
Next i
End If
With ActiveSheet
For i = 1 To nDataBlock
If useDataBlock(i) Then
'write volume and atom information to block header
.Cells(blockLineStart(i) - 1, 6).value = "Generators " & multiplicityBlock(i) & "[" _
& Replace(LTrim(Format(volumeBlock(i), "0.0000")), ",", ".") & "]"
'.Cells(blockLineStart(i) - 1, 10).value = atomsBlock(i)
'load generators to sheet
For j = 1 To 5
.Cells(blockLineStart(i), j + 5) = cationGenerator(i, j)
Next j
'...
lineNumber = blockLineStart(i) + 2
For k = dbStart(i) + 1 To dbEnd(i)
brv = interpretLine(lineStore(k), outputString, nField)
For j = 1 To 5
anionGenerator(j) = outputString(j + 2)
Next j
anionGenerator(1) = anionGenerator(1) + 1
anionGenerator(2) = anionGenerator(2) + 1
'...
lineNumber = lineNumber + 1
For j = 1 To 5
.Cells(lineNumber, 5 + j) = anionGenerator(j)
Next j
Next k
End If
Next i
End With
End Sub
Sub transferAtomicCoordinates()
Dim inputLine As String
Dim pathname As String
Dim nField As Integer
Dim outputString(1 To 16) As String
Dim i As Integer, j As Integer
Dim nLine As Integer, nLineEntry As Integer
Dim entryStore(1 To 20) As String
Dim cell(1 To 6) As Double
Dim doubleValue As Double
Dim intValue As Integer
Dim xyz(1 To 3) As String
Dim multiplicity As Integer
xyz(1) = "x": xyz(2) = "y": xyz(3) = "z"
'...
pathname = micaExcelFolder & "xlTransferAtomicCoordinates" & LTrim(Str(sgCode)) & ".txt"
Open pathname For Input As #1
Do Until EOF(1)
Line Input #1, inputLine
brv = interpretLine(inputLine, outputString, nField)
If outputString(1) = "DATA" And outputString(3) = fileNumber Then
'...Entry matched. Read data until end of entry
outputString(1) = ""
nLineEntry = 0
Do Until outputString(1) = "DATA"
Line Input #1, inputLine
brv = interpretLine(inputLine, outputString, nField) 'necessary for loop control
nLineEntry = nLineEntry + 1
entryStore(nLineEntry) = inputLine
Loop
End If
Loop
Close #1
'interpret entryStore array for matched entry and output to sheet
With ActiveSheet
.Cells(1, 2) = fileNumber
'...cell parameters
inputLine = entryStore(1)
brv = interpretLine(inputLine, outputString, nField) 'necessary for loop control
For i = 1 To 6
cell(i) = Replace(outputString(i + 1), ".", decimalSeparator)
Next i
If sgCode = 12 Or sgCode = 15 Then
.Cells(3, 2) = cell(1)
.Cells(4, 2) = cell(2)
.Cells(5, 2) = cell(3)
.Cells(6, 2) = cell(5)
ElseIf sgCode = 151 Then
.Cells(3, 2) = cell(1)
.Cells(4, 2) = cell(3)
Else
.Cells(3, 2) = cell(1)
.Cells(4, 2) = cell(2)
.Cells(5, 2) = cell(3)
End If
'...
If sgCode = 15 Then
'.....
If cell(2) > cell(1) Then
ActiveSheet.Cells(6, 26).FormulaR1C1 = "2M1" 'Z6
Else
ActiveSheet.Cells(6, 26).FormulaR1C1 = "2M2"
End If
With ActiveSheet.Cells(6, 26)
.Characters(Start:=2, Length:=1).Font.FontStyle = "Italic"
.Characters(Start:=3, Length:=1).Font.Subscript = True
End With
'.....
End If
'...
'transfer anion coordinates
If sgCode = 12 Or sgCode = 15 Then
nLine = 7
ElseIf sgCode = 151 Then
nLine = 5
Else
nLine = 6
End If
For i = 2 To nLineEntry
inputLine = entryStore(i)
brv = interpretLine(inputLine, outputString, nField)
If outputString(nField) = "F" Then
For j = 1 To 3
nLine = nLine + 1
.Cells(nLine, 1) = outputString(5) & " " & outputString(6) & " " & xyz(j)
'...
doubleValue = Replace(outputString(j + 1), ".", decimalSeparator)
.Cells(nLine, 2).value = doubleValue
intValue = outputString(1)
.Cells(nLine, 3).value = intValue + 1
'special shading for C2/m: red background for fixed coordinates
If sgCode = 12 Then
multiplicity = Left(outputString(6), 1)
If multiplicity = 4 And j = 2 Then
    .Cells(nLine, 2).Interior.Color = RGB(255, 0, 0)
    .Cells(nLine, 2).Font.Color = RGB(255, 255, 255)
    .Cells(nLine, 2).Font.Bold = True
Else
    .Cells(nLine, 2).Interior.Color = RGB(202, 237, 251) 'light blue
    .Cells(nLine, 2).Font.Color = RGB(0, 0, 0)
    .Cells(nLine, 2).Font.Bold = False
End If
End If 'sgCode = 12 block
Next j
End If
Next i
'transfer cation coordinates (for information)
If sgCode = 12 Then
nLine = 21
ElseIf sgCode = 15 Then
nLine = 27
ElseIf sgCode = 151 Then
nLine = 25
ElseIf sgCode = 58 Then
nLine = 32
ElseIf sgCode = 63 Then
nLine = 20
End If
For i = 2 To nLineEntry
inputLine = entryStore(i)
brv = interpretLine(inputLine, outputString, nField)
If outputString(nField) = "T" Then
nLine = nLine + 1
.Cells(nLine, 1) = outputString(5) & " " & outputString(6)
For j = 1 To 3
doubleValue = Replace(outputString(j + 1), ".", decimalSeparator)
.Cells(nLine, j + 1).value = doubleValue
Next j
intValue = outputString(1)
.Cells(nLine, 5).value = intValue + 1
End If
Next i
End With
End Sub
Sub transferReferenceText()
Dim inputLine As String
Dim index As Integer
Dim dynamicFileNumber As String
Dim dataFound As Boolean
'...pick up reference details
Open micaExcelFolder & "references" & LTrim(Str(sgCode)) & ".txt" For Input As #1
Do Until EOF(1)
Line Input #1, inputLine
If Left(inputLine, 1) = "#" Then
dynamicFileNumber = Mid(inputLine, 2, Len(inputLine) - 1)
'...
If dynamicFileNumber = fileNumber Then
dataFound = True
referenceText = ""
repeat:
Line Input #1, inputLine
If Left(inputLine, 1) <> "#" Then
referenceText = referenceText & inputLine & " "
End If
If Left(inputLine, 1) <> "#" Then GoTo repeat
'At end of this procedure, output is stored in referenceText
End If
'...
End If
Loop
Close #1
If Not dataFound Then
referenceText = "No reference data for this structure are available."
End If
'Fill text box in current sheet
If ActiveSheet.Name = "C2_c" Then
    ActiveSheet.Shapes.Range(Array("TextBox 5")).Select
Else
    ActiveSheet.Shapes.Range(Array("TextBox 2")).Select
End If
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = referenceText
End Sub
Function extractIntegers(inputString As String)
Dim i As Integer, integerCount As Integer, i1 As Integer
Dim inField As Integer
inField = False
integerCount = 0
For i = 1 To Len(inputString)
If Mid(inputString, i, 1) <> " " And Not inField Then
i1 = i
inField = True
ElseIf Mid(inputString, i, 1) = " " And inField Then
integerCount = integerCount + 1
generatorInteger(integerCount) = Mid(inputString, i1, i - i1)
inField = False
End If
Next i
If integerCount < 5 Then
integerCount = 5
generatorInteger(integerCount) = Mid(inputString, i1, Len(inputString) - i1)
End If
End Function
