HOME 教育状況公表 本日
files
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.03
[utf-8] [shift_jis]

QRコード
https://edu.yz.yamagata-u.ac.jp/developer/type.asp?url=%2Fdeveloper%2FTips%2FMolView.txt

SSLの仕組み

このマークはこのページで 著作権が明示されない部分について付けられたものです。

山形大学 データベースアメニティ研究所
〒992-8510 山形県米沢市城南4丁目3-16 3号館(物質化学工学科棟) 3-3301
准教授 伊藤智博
0238-26-3573
http://amenity.yz.yamagata-u.ac.jp/

Copyright ©1996- 2019 Databese Amenity Laboratory of Virtual Research Institute,  Yamagata University All Rights Reserved.