🏠
MolView.txt
/developer/Tips/MolView.txt
/developer/Tips/
D:\share6\www\developer\Tips\MolView.txt
txt
MolView
Attribute VB_Name = "codeMolView"
Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Dim XM!(1000)
Dim YM!(1000)
Dim ZM!(1000)
Dim AM%(1000)
Public nMode% '表示の仕方 1 ボンド無し 2 プレン無し
Public szOpenedFileName$
Public szTempFileName$
Public bLightPos%
Function GetAtomSymbol(A) As String
Dim obj As Object
Set obj = CreateObject("ChemicalComponent.Atom")
obj.Index = A
GetAtomSymbol = obj.Symbol
Set obj = Nothing
End Function
Sub InsertAtom(nFile%, X!, Y!, Z!, A)
Static PREVIOUS_ATOM
If A > 0 Then
If PREVIOUS_ATOM <> A Then
InsertMaterial nFile%, A
PREVIOUS_ATOM = A
End If
Print #1, "Separator {"
InsertTranslation nFile%, X!, Y!, Z!
r! = GetIonRadious(A, 0) / 10
InsertSphere nFile%, r!
Print #1, "}"
'InsertOrbital nFile%
End If
End Sub
Sub InsertOrbital(nFile%)
Print #nFile%, "Separator {"
InsertGlass nFile%
pi = 3.14159265358979
N% = 16
m% = 8
ds = 1 / N% * pi * 2
dp = 1 / m% * pi / 2
RR = 2
For i% = 0 To N%
s = i% / N% * pi * 2
For J% = -m% To m%
P = J% / m% * pi / 2
Rr1 = InvWave(2, 1, 0, 0.5, s, P)
Rr2 = InvWave(2, 1, 0, 0.5, s + ds, P)
Rr3 = InvWave(2, 1, 0, 0.5, s + ds, P + dp)
Rr4 = InvWave(2, 1, 0, 0.5, s, P + dp)
X1! = Rr1 * Cos(s) * Cos(P)
Y1! = Rr1 * Sin(s) * Cos(P)
Z1! = Rr1 * Sin(P)
X2! = Rr2 * Cos(s + ds) * Cos(P)
Y2! = Rr2 * Sin(s + ds) * Cos(P)
Z2! = Rr2 * Sin(P)
X3! = Rr3 * Cos(s + ds) * Cos(P + dp)
Y3! = Rr3 * Sin(s + ds) * Cos(P + dp)
Z3! = Rr3 * Sin(P + dp)
X4! = Rr4 * Cos(s) * Cos(P + dp)
Y4! = Rr4 * Sin(s) * Cos(P + dp)
Z4! = Rr4 * Sin(P + dp)
Print #nFile%, "Coordinate3 { point ["
Print #nFile%, X1!, Y1!, Z1!; ","
Print #nFile%, X2!, Y2!, Z2!; ","
Print #nFile%, X3!, Y3!, Z3!; ","
Print #nFile%, X4!, Y4!, Z4!
Print #nFile%, "]"
Print #nFile%, "}"
Print #nFile%, "IndexedFaceSet {"
Print #nFile%, "coordIndex ["
Print #nFile%, "0,1,2,3"
Print #nFile%, "]"
Print #nFile%, "}"
Next
Next
Print #nFile%, "}"
End Sub
Function InvWave(N%, m%, L%, pp, t, P)
Exit Function
s = 0
ppp = 1
Do While ppp > pp
r = 0.01 * Exp(s / 10)
ppp = SchrodingerWaveFunction(N%, m%, L%, r, t, P)
s = s + 1
Loop
End Function
Public Function SchrodingerWaveFunction(N%, m%, L%, r, t, P)
PrincipalQuantumNumber = N%
AzimuthalQuantumNumber = m%
MagneticQuantumNumber = L%
Dim r0 As Double
Dim Z As Double
Dim pi As Double
r0 = 0.5
Z = 1
pi = 3.14159265
Select Case PrincipalQuantumNumber '主量子数
Case 1
'1s
SchrodingerWaveFunction = 1 / Sqr(pi) * (Z / r0) ^ (3 / 2) * Exp(-Z * r / r0)
Case 2
Select Case AzimuthalQuantumNumber '方位量子数
Case 0
'2s
SchrodingerWaveFunction = 1 / (4 * Sqr(2 * pi)) * (Z / r0) ^ (3 / 2) * (2 - Z * r / r0) * Exp(-Z * r / (2 * r0))
Case 1
Select Case MagneticQuantumNumber '磁気量子数
Case -1
'2py
SchrodingerWaveFunction = 1 / (4 * Sqr(2 * pi)) * (Z / r0) ^ (3 / 2) * Z * r / r0 * Exp(-Z * r / (2 * r0)) * Sin(t) * Sin(P)
Case 0
'2pz
SchrodingerWaveFunction = 1 / (4 * Sqr(2 * pi)) * (Z / r0) ^ (3 / 2) * Z * r / r0 * Exp(-Z * r / (2 * r0)) * Cos(t)
Case 1
'2px
SchrodingerWaveFunction = 1 / (4 * Sqr(2 * pi)) * (Z / r0) ^ (3 / 2) * Z * r / r0 * Exp(-Z * r / (2 * r0)) * Sin(t) * Cos(P)
End Select
End Select
Case 3
Select Case AzimuthalQuantumNumber '方位量子数
Case 0
'3s
SchrodingerWaveFunction = 1 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (27 - 18 * Z * r / r0 + 2 * (Z * r / r0) ^ 2) * Exp(-Z * r / (3 * r0))
Case 1
Select Case MagneticQuantumNumber '磁気量子数
Case -1
'3py
SchrodingerWaveFunction = 1 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) * (6 - Z * r / r0) * Exp(-Z * r / (3 * r0)) * Sin(t) * Sin(P)
Case 0
'3pz
SchrodingerWaveFunction = 1 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) * (6 - Z * r / r0) * Exp(-Z * r / (3 * r0)) * Cos(t)
Case 1
'3px
SchrodingerWaveFunction = 1 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) * (6 - Z * r / r0) * Exp(-Z * r / (3 * r0)) * Sin(t) * Cos(P)
End Select
Case 2
Select Case MagneticQuantumNumber '磁気量子数
Case -2
'3dxy
SchrodingerWaveFunction = 2 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) ^ 2 * Exp(-Z * r / (3 * r0)) * Sin(t) ^ 2 * Sin(2 * P)
Case -1
'3dyz
SchrodingerWaveFunction = 2 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) ^ 2 * Exp(-Z * r / (3 * r0)) * Sin(t) * Cos(t) * Cos(P)
Case 0
'3dz2
SchrodingerWaveFunction = 2 / (27 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) ^ 2 * Exp(-Z * r / (3 * r0)) * (Cos(P) ^ 2 - 1 / 3)
Case 1
'3dxz
SchrodingerWaveFunction = 2 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) ^ 2 * Exp(-Z * r / (3 * r0)) * Sin(t) * Cos(t) * Sin(P)
Case 2
'3dx2-y2
SchrodingerWaveFunction = 2 / (81 * Sqr(3 * pi)) * (Z / r0) ^ (3 / 2) * (Z * r / r0) ^ 2 * Exp(-Z * r / (3 * r0)) * Sin(t) ^ 2 * Cos(2 * P)
End Select
End Select
End Select
End Function
Sub InsertString(nFile%, X!, Y!, Z!, b$, A$)
Print #nFile%, "Separator {"
InsertTranslation nFile%, X!, Y!, Z!
Print #nFile%, "Scale {"
Print #nFile%, " scaleFactor 0.08 0.08 0.08"
Print #nFile%, "}"
Print #nFile%, "AsciiText {"
Print #nFile%, "string [" + Chr$(34) + A$ + Chr$(34) + "]"
Print #nFile%, "}"
Print #nFile%, "}"
End Sub
Function GetIonRadious(A, b%) As Double
Dim obj As Object
Set obj = CreateObject("ChemicalComponent.Atom")
GetIonRadious = obj.GetIonRadious(CInt(A), b%)
Set obj = Nothing
End Function
Sub InsertBond(nFile%, XR!, YR!, ZR!, XL!, YL!, ZL!)
Static PREVIOUS_LINE
If PREVIOUS_LINE <> "1" Then
InsertGuru nFile%
PREVIOUS_LINE = "1"
End If
Print #nFile%, "Separator {"
Print #nFile%, "Coordinate3 { point ["
Print #nFile%, XR!, YR!, ZR!; ","
Print #nFile%, XL!, YL!, ZL!
Print #nFile%, "]"
Print #nFile%, "}"
Print #nFile%, "IndexedLineSet {"
Print #nFile%, "coordIndex ["
Print #nFile%, "0,1"
Print #nFile%, "]"
Print #nFile%, "}"
Print #nFile%, "}"
End Sub
Sub InsertGass(nFile%, r!, G!, b!)
Print #nFile%, "Material {"
Print #nFile%, "ambientColor 0.1 0.1 0.1"
Print #nFile%, "diffuseColor "; r! / 2, G! / 2, b! / 2
Print #nFile%, "specularColor 0.1 0.1 0.1"
Print #nFile%, "emissiveColor 0.0 0.0 0"
Print #nFile%, "shininess 0.1"
Print #nFile%, "transparency 0"
Print #nFile%, "}"
End Sub
Sub InsertGlass(nFile%)
Print #nFile%, "Material {"
Print #nFile%, "ambientColor 0.3 0.3 0.5"
Print #nFile%, "diffuseColor 0.5 0.5 0.9"
Print #nFile%, "specularColor 0.5 0.5 0.9"
Print #nFile%, "emissiveColor 0.0 0.0 0"
Print #nFile%, "shininess 0.1"
Print #nFile%, "transparency 0.4"
Print #nFile%, "}"
End Sub
Sub InsertGuru(nFile%)
Print #nFile%, "Material {"
Print #nFile%, "ambientColor 0.1 0.5 0.1"
Print #nFile%, "diffuseColor 0.2 0.5 0.2"
Print #nFile%, "specularColor 0.2 0.5 0.2"
Print #nFile%, "emissiveColor 0.0 0.4 0.0"
Print #nFile%, "shininess 0.1"
Print #nFile%, "transparency 0.1"
Print #nFile%, "}"
End Sub
Sub InsertMetal(nFile%, r!, G!, b!)
Print #nFile%, "Material {"
Print #nFile%, "ambientColor 0.1 0.1 0.1"
Print #nFile%, "diffuseColor 0.1 0.1 0.1"
Print #nFile%, "specularColor "; 1 - (1 - r!) / 2, 1 - (1 - G!) / 2, 1 - (1 - b!) / 2
Print #nFile%, "emissiveColor 0.0 0.0 0"
Print #nFile%, "shininess 0.1"
Print #nFile%, "transparency 0"
Print #nFile%, "}"
End Sub
Sub InsertShapeHints(nFile%)
Print #1, "ShapeHints{"
Print #1, "vertexOrdering COUNTERCLOCKWISE"
Print #1, "shapeType SOLID"
Print #1, "faceType CONVEX"
Print #1, "}"
End Sub
Sub InsertSphere(nFile%, r!)
Print #1, "Sphere {"
Print #1, "radius "; r!
Print #1, "}"
End Sub
Sub InsertTranslation(nFile%, X!, Y!, Z!)
Print #nFile%, "Translation {"
Print #nFile%, "translation "; X!; Y!; Z!
Print #nFile%, "}"
End Sub
Sub InsertCamera(nFile%)
Print #nFile%, "PerspectiveCamera {"
Print #nFile%, "position 0 2 10"
Print #nFile%, "orientation -1 0 0 0.19"
Print #nFile%, "focalDistance 10"
Print #nFile%, "}"
End Sub
Sub InsertPointLight(nFile%, r!, G!, b!, A!, X!, Y!, Z!)
Print #nFile%, "PointLight {"
Print #nFile%, "on TRUE"
Print #nFile%, "intensity "; A!
Print #nFile%, "color "; r!, G!, b!
Print #nFile%, "location "; X!, Y!, Z!
Print #nFile%, "}"
End Sub
Sub InsertDirectionalLight(nFile%, r!, G!, b!, A!, X!, Y!, Z!)
Print #nFile%, "DirectionalLight {"
Print #nFile%, "on TRUE"
Print #nFile%, "intensity "; A!
Print #nFile%, "color "; r!, G!, b!
Print #nFile%, "direction "; X!, Y!, Z!
Print #nFile%, "}"
End Sub
Sub InsertMaterial(nFile%, A)
Dim N&, m&, r!, G!, b!
N& = GetAtomColor(A)
RR% = N& / &H10000: m& = N& Mod &H10000
GG% = m& / &H100&: BB% = m& Mod &H100&
r! = RR% / 256
G! = GG% / 256
b! = BB% / 256
If IsMetal(A) Then
InsertMetal nFile%, r!, G!, b!
Else
InsertGass nFile%, r!, G!, b!
End If
End Sub
Function IsMetal(A) As Integer
Dim obj As Object
Set obj = CreateObject("ChemicalComponent.Atom")
obj.Index = A
IsMetal = obj.IsMetal
Set obj = Nothing
End Function
Function GetAtomColor(A) As Long
Dim obj As Object
Set obj = CreateObject("ChemicalComponent.Atom")
obj.Index = A
GetAtomColor = obj.Color
Set obj = Nothing
End Function
Sub InsertScale(nFile%)
Print #nFile%, "Scale {"
Print #nFile%, "scaleFactor 10 10 10"
Print #nFile%, "}"
End Sub
Sub InsertTriangleSurface(nFile%, X1!, Y1!, Z1!, X2!, Y2!, Z2!, X3!, Y3!, Z3!)
Print #nFile%, "Separator {"
InsertGlass nFile%
Print #nFile%, "Coordinate3 { point ["
Print #nFile%, X1!, Y1!, Z1!; ","
Print #nFile%, X2!, Y2!, Z2!; ","
Print #nFile%, X3!, Y3!, Z3!
Print #nFile%, "]"
Print #nFile%, "}"
Print #nFile%, "IndexedFaceSet {"
Print #nFile%, "coordIndex ["
Print #nFile%, "0,1,2"
Print #nFile%, "]"
Print #nFile%, "}"
Print #nFile%, "}"
End Sub
Sub InsertWWW(nFile%)
Print #nFile%, "WWWInline{"
Print #nFile%, "name " + Chr$(34) + "starfield2.wrl" + Chr$(34)
Print #nFile%, "}"
End Sub
Sub MolToVrml(src, dst, nMode)
Dim zParam!(10), szParamText$(10)
Dim LL%(255), RR%(255)
Dim S1%(255), S2%(255), S3%(255)
nAtomMax = 0
nbondmax = 0
nSurfacemax = 0
Open src For Input As #2
Do While Not EOF(2)
Line Input #2, szText$
P% = 1: nToken% = 0: szToken$ = ""
While szText$ <> ""
P% = InStr(szText$, ",")
If P% = 0 Then
szToken$ = szText$
szText$ = ""
Else
szToken$ = Mid$(szText$, 1, P% - 1)
szText$ = Mid$(szText$, P% + 1)
End If
szParamText$(nToken%) = szToken$
zParam!(nToken%) = Val(szToken$)
nToken% = nToken% + 1
Wend
Select Case nToken% ' Number を評価します。
Case 4 ' Number の値が 4 の場合。
XM(nAtomMax) = zParam!(0) / 3 + 2
YM(nAtomMax) = zParam!(1) / 3 + 2
ZM(nAtomMax) = zParam!(2) / 3 + 2
AM%(nAtomMax) = zParam!(3) Mod 256
X! = XM(nAtomMax)
Y! = YM(nAtomMax)
Z! = ZM(nAtomMax)
Xmm = Xmm + X
Ymm = Ymm + Y
Zmm = Zmm + Z
aA% = AM%(nAtomMax)
nAtomMax = nAtomMax + 1 '原子の個数
Case 2 ' Number の値が 2 の場合。
LL%(nbondmax) = zParam!(0) - 1
RR%(nbondmax) = zParam!(1) - 1
nbondmax = nbondmax + 1
Case 3 ' Number の値が 3 の場合。
S1%(nSurfacemax) = zParam!(0) - 1
S2%(nSurfacemax) = zParam!(1) - 1
S3%(nSurfacemax) = zParam!(2) - 1
nSurfacemax = nSurfacemax + 1
Case Else ' その他の値の場合。
End Select
Loop
Close
U% = 1
m% = 1
Open dst For Output As #1
Print #1, "#VRML V1.0 ascii"
Print #1, ""
Print #1, "DEF BackgroundColor Info {"
Print #1, "string " & Chr(34) & "0.8 0.8 0.8" & Chr(34)
Print #1, "}"
Print #1, "Separator {"
InsertCamera 1
'InsertWWW 1
XP! = 0: YP! = -0.7: ZP! = -0.7: SP! = 0
r! = 1: G! = 1: b! = 1: A! = 1: X! = XP!: Y! = YP!: Z! = ZP!
InsertDirectionalLight 1, r!, G!, b!, A!, X!, Y!, Z!
XP! = 0: YP! = 1: ZP! = 0: SP! = 0
r! = 1: G! = 1: b! = 1: A! = 0.5: X! = XP!: Y! = YP!: Z! = ZP!
InsertDirectionalLight 1, r!, G!, b!, A!, X!, Y!, Z!
XP! = -10: YP! = 10: ZP! = 10: SP! = -20
r! = 1: G! = 0.8: b! = 0.8: A! = 0.5: X! = XP! - SP!: Y! = YP! + SP!: Z! = ZP! + SP!
InsertDirectionalLight 1, r!, G!, b!, A!, X!, Y!, Z!
XP! = -10: YP! = -10: ZP! = -10: SP! = -20
r! = 0.8: G! = 1: b! = 1: A! = 0.5: X! = XP! - SP!: Y! = YP! + SP!: Z! = ZP! + SP!
InsertDirectionalLight 1, r!, G!, b!, A!, X!, Y!, Z!
InsertTranslation 1, -Xmm / nAtomMax, -Ymm / nAtomMax, -Zmm / nAtomMax
Print #1, "FontStyle {"
Print #1, "size 1"
Print #1, "}"
If (nMode And 4) = 4 Then
For i = 0 To nAtomMax - 1
X! = XM(i)
Y! = YM(i)
Z! = ZM(i)
aA% = AM%(i)
Symbol$ = GetAtomSymbol(Str(aA%))
'原子の挿入
InsertAtom 1, X!, Y!, Z!, aA%
Next
End If
If (nMode And 8) = 8 Then
InsertGuru 1
For i = 0 To nAtomMax - 1
X! = XM(i)
Y! = YM(i)
Z! = ZM(i)
aA% = AM%(i)
Symbol$ = GetAtomSymbol(Str(aA%))
'文字の挿入
InsertString 1, X!, Y!, Z!, Str(aA%), Format$(CInt(i + 1), "(#)")
Next
End If
Print #1, "Coordinate3 { point ["
For i = 0 To nAtomMax - 1
X! = XM(i)
Y! = YM(i)
Z! = ZM(i)
aA% = AM%(i)
If i = nAtomMax - 1 Then
Print #1, X!, Y!, Z!
Else
Print #1, X!, Y!, Z!; ","
End If
Next
Print #1, "]}"
'結合
If (nMode And 1) = 1 Then
InsertGuru 1
For i = 0 To nbondmax - 1
Print #1, "IndexedLineSet {"
Print #1, "coordIndex ["
Write #1, LL%(i), RR%(i)
Print #1, "]}"
Next
End If
If (nMode And 2) = 2 Then
InsertGlass 1
For i = 0 To nSurfacemax - 1
Print #1, "IndexedFaceSet {"
Print #1, "coordIndex ["
Write #1, S1%(i), S2%(i), S3%(i), -1, S3%(i), S2%(i), S1%(i)
Print #1, "]}"
Next
End If
1730 Print #1, "}"
1740 Close
End Sub
Function OpenFile(szFileName$) As String
If szFileName$ = "" Then
MsgBox "ﾌｧｲﾙが開かれていません"
Exit Function
End If
If szFileName$ = "" Then Exit Function
szOpenedFileName$ = szFileName$
UpdateDocument
OpenFile = szTempFileName$
End Function
Function GetNewFileName() As String
Dim nBufferLength&
nBufferLength& = 255
Dim szPath As String * 255
Dim wResult&
Dim wUnique&
Dim szPrefix As String * 255
Dim szTempFileName As String * 255
szPrefix$ = "MLV"
wUnique& = 0
wResult& = GetTempPath(nBufferLength&, szPath$)
GetNewPath$ = MidB$(szPath$, 1, LenB(szPath$))
wResult& = GetTempFileName(GetNewPath$, szPrefix$, wUnique&, szTempFileName$)
GetNewFileName = MidB$(szTempFileName$, 1, LenB(szTempFileName$))
End Function
Sub UpdateDocument()
If szTempFileName$ <> "" Then Kill szTempFileName$
szTempFileName$ = GetNewFileName()
MolToVrml szOpenedFileName$, szTempFileName$, nMode%
t = ""
N = 0
Open szTempFileName$ For Input As #1
Do While Not EOF(1) And N < 100
Line Input #1, tt
t = t & tt & Chr(13) & Chr(10)
N = N + 1
Loop
Close
frmMolView.TextEdit.Text = t
End Sub
Type Ver.1.05
[utf-8] [shift_jis]
🎄🎂🌃🕯🎉
Copyright ©1996- 2024 Databese Amenity Laboratory of Virtual Research Institute, Yamagata University All Rights Reserved.