有没有人遇到以下问题：写入文本文件的VBA代码，在此过程中多次打开和关闭文件（因为有时它还需要读取同一文件）跳过实际写入文件代码的某些部分（主要在“If”块内）。此外，如果为一个文件启动代码，但是当代码被放入循环中以多次执行相同的操作（使用一组不同的输入参数）时，代码可以正常运行。更重要的是，如果我包含额外的打开/注释行写入/关闭，代码有时会按预期工作（这些注释行不会写入文本文件）。最后，如果我在代码中放置断点并按顺序按下VBEditor中的“运行”按钮，代码也会按预期完成。我的一位同事也用他的代码在不同的PC上体验过这一点。
所述问题的解决方案（似乎）如下：
我意识到多次打开/关闭文件可能不是最好的选择。由于我重写了代码以将所有“Open for Input”部分移到现在只有“Open for Append”部分的前面，所以一切正常。因此问题本身已经解决了，但我感兴趣的是： 为什么 会发生这种情况？ 也许这也与其他用户有关。
此问题在升级到Windows 10和Office 2013之后的某个时间首先发生。也许它与安装的某些更新相关联。这与VBA中的读/写算法修改/扩充有关吗？
提取不相关内容的代码在这里（经常发生 not-written 问题的部分包含在“$$$$$$$$$$$$$$$最多的问题有这个部分$$$$$$$$$$$$$$$$$$$$$$$$“lines”：
Private Sub ok_Click()
'#### ::: IeejasGeometrija IzdrukasGeometrija LapaIerakstam ApstradesApaksprogramma Uzdevums Solis
dirnamefi = Array(, "Z:\HIN_Files\", "Z:\Ad_HIN_Files\", "", tlocdisk)
Dim ladfst As Variant, astefst As Variant, stprim As Integer, rsect As String, ladmult As String, tlad As String, tmult As String, tsect As String ' NoSave As Boolean
Dim oldCHKstring As String, CHKstring As String, Link0string() As String, outchk As String, darbachk As String, wasithuh As Integer, anylutil As Boolean, multiadd As String, inhinfs() As String
Dim murr As Integer, aiiu As Integer, vibtrue As Boolean, cnames As String, tingeom As String, toutgeom As String, postSCF As Boolean, semiEmp As Boolean, ophiur As Integer, sonne As Integer
Dim SCFmod As String, chatyp As String, gnum As Integer, gname As String, absem As String, geomcheck As String, uzdprim As String, stavokliSS() As String, multimol As Integer, multimola As Integer
If InStr(Me.baze, "Gen") > 0 And (Me.GenBStxb.Value = "" Or IsNull(Me.GenBStxb.Value)) Then: Me.GenBStxb.BackColor = RGB(255, 200, 200): MsgBox "Please fill in Gen basis set name!": Exit Sub: Else: Me.GenBStxb.BackColor = RGB(255, 255, 255)
SCFmod = "": anylutil = False
postSCF = (InStr(Me.metodes, "CCSD") + InStr(Me.metodes, "MP2") + InStr(Me.metodes, "MP4") + InStr(Me.metodes, "EPT") + InStr(Me.metodes, "CASSCF") > 0)
Select Case Me.metodes.Value
Case "AM1", "PM3", "PM6", "PDDG", "PM3MM", "CNDO", "INDO", "MINDO", "MINDO3", "ZIndo"
semiEmp = True: postSCF = False
Case "MP2", "MP4(DQ)", "CCSD", "CCSD(T)", "EPT", "CASSCF", "MP4"
semiEmp = False: postSCF = True
Case Else
semiEmp = False: postSCF = False
End Select
If Me.InGeom = "" Then: MsgBox "Nav noradita izmantojama geometrija!": Exit Sub
If Me.FragmCkB And IsNull(Me.FragmTxtBx.Value) Then: MsgBox "Nav noradits dalijums fragmentos!": Exit Sub
If Me.FrgGuessCkB And IsNull(Me.IzlaistSolus.Value) = False Then: If LenB(Me.IzlaistSolus.Value) > 0 Then MsgBox "Parbaudiet CHK rindas ievadfailaa! Vel nav ielabots, lai fragmenti strada kopa ar izlaistajiem."
gname = tdisk & "\" & Me.outname_txb & ".gjf"
UzdPar "unum", Me.Uzdevumi 'reads input from DB
Dim nononono As Boolean, natonatonato As Boolean: nononono = False: natonatonato = False: sonne = 1
If lapa = "ElectronicSpectrum" Then sonne = vardx(Me.istate.Value, stavokliSS(), ",")
If Me.NaTO.Value And LenB(Me.NaTOtxb.Value) > 0 And lapa = "ElectronicSpectrum" Then: natonatonato = True
If Me.SpinNatural.Value Or Me.NOck.Value Or Me.NOAB.Value Then nononono = True
If Me.NBOcheck.Value Or nononono Or natonatonato Then FormchkChk.Value = True 'Or ESPcharge.Value
Dim bjaka As Integer
If (uzd = "ExcitedStateAbsorption" Or uzd = "ExcitedStateEmission") And vide = "vacuum" Then: MsgBox "Nevar veikt sho aprekinu vakuumaa!": Exit Sub
OutGeomVisible 'reads from Access form
'############################### Multimol initializes #################################################
multimol = 1
ReDim Preserve inhinfs(1 To multimol)
If InStr(Me.InGeom.Value, ".chk") > 0 Then
inhinfs(1) = Me.InGeom.Value
Else
inhinfs(multimol) = Dir(dirnamefi(Me.geom) & Me.InGeom.Value & ".hin")
Do
multimol = multimol + 1
reDim Preserve inhinfs(1 To multimol)
inhinfs(multimol) = Dir()
Loop Until LenB(inhinfs(multimol)) = 0
multimol = multimol - 1
ReDim Preserve inhinfs(1 To multimol)
End If
If IsNull(Me.OutGeom) Then Me.OutGeom.Value = ""
If InStr(Me.OutGeom, "*") + InStr(Me.OutGeom, "?") = 0 Then multiadd = Me.OutGeom.Value Else multiadd = ""
If multimol > 1 Then Me.OutGeom.Value = ""
For multimola = 1 To multimol
'############################### Multimol begins #################################################
Me.InGeom.Value = Replace(Replace(inhinfs(multimola), dirnamefi(Me.geom), ""), ".hin", "")
If Me.OutGeom.Value = "" And multimol = 1 Then
Me.OutGeom.Value = Me.InGeom.Value
ElseIf multimol > 1 Then
If semiEmp Then
If multiadd <> "" Then Me.OutGeom.Value = Me.InGeom.Value & "_" & Replace(Me.metodes.Value, "-", "") & multiadd Else Me.OutGeom.Value = Me.InGeom.Value & "_" & Replace(Me.metodes.Value, "-", "")
Else
If multiadd <> "" Then Me.OutGeom.Value = Me.InGeom.Value & "_" & Replace(Me.metodes.Value, "-", "") & "." & Replace(Replace(Replace(Me.baze.Value, "(", ""), ")", ""), ",", ".") & multiadd Else Me.OutGeom.Value = Me.InGeom.Value & "_" & Replace(Me.metodes.Value, "-", "") & "." & Replace(Replace(Replace(Me.baze.Value, "(", ""), ")", ""), ",", ".")
End If
End If
For ophiur = 1 To sonne
For st = 1 To nst
If st = 1 And ophiur > 1 Then GoTo nophiur2
If InStr(keywordsfs(st), "CalcAll") > 0 And st > 1 And InStr(Me.IzlaistSolus, "1") = 0 And Me.TsChk And (Me.TsOptGrp = 2 Or Me.TsOptGrp = 3) Then
gnum = FreeFile()
Open gname For Append As gnum
Print #gnum,
Print #gnum, "!lutil gettsqst " & dirnamefi(4) & Me.outname_txb & ".out"
Close #gnum
End If
If Me.geom < 3 Then
tingeom = Me.InGeom
Else
If Me.CHKnos = 1 Then tingeom = vardc(Me.caenames, Me.InGeom.ListIndex + 1) Else tingeom = Mid(Trim(Me.caenames), InStrRev(RTrim(Me.caenames), " "))
End If
toutgeom = tingeom
If izlaistfs(st) = False Then
PapEps = "": PapInf = "": PapRedun = "": PapReaf = "": PapRW = "": PapEPT = "": PapPop = ""
absem = "": bjaka = 0
gnum = FreeFile()
openitdude:
'On Error Resume Next
Open gname For Append As gnum
Debug.Print "Opened!"
' $$$$$$$$$$$$$$ MOST PROBLEMS WITH THIS SECTION $$$$$$$$$$$$$$$$$$$$$$$$$
If Me.AtvertPapildinat + st > 2 Then
If Me.AtvertPapildinat + st = 3 Then Print #gnum, "" 'should not be done...
Close #gnum: Open gname For Append As gnum
Print #gnum, ""
Print #gnum, "--Link1--"
Print #gnum, ""
End If
Close #gnum
' $$$$$$$$$$$$$$ MOST PROBLEMS WITH THIS SECTION -- ENDS $$$$$$$$$$$$$$$$$$$$$$$$$
Open gname For Append As gnum
Print #gnum, "%Mem=" & tmem
Print #gnum, "%NProcShared=" & Format(tproc)
If Me.LindaChk Then
Print #gnum, "%LindaWorkers=" & Me.LindaTxb
Print #gnum, "%UseSSH"
End If
If Me.link0 <> "" Then
murr = vardx(Me.link0.Value, Link0string)
For aiiu = 1 To murr
Print #gnum, Link0string(aiiu)
Next aiiu
End If
Print #gnum, ""
If InStr(keywordsfs(st), "Opt=(CalcAll") + InStr(keywordsfs(st), "Freq") > 0 Then
rsect = "#N"
ElseIf InStr(PapInf, "Surface") > 0 And st = nst Then 'Not (InStr(keywordsfs(st), "Opt") > 0 And ( xor uzdprim="ElSpGround") and InStr(keywordsfs(st), "Stable") = 0) Then
rsect = "#P"
ElseIf Me.submet.Value = "SAC-CI" And st = nst Then
rsect = "#P"
ElseIf Me.metodes.Value = "CASSCF" Then
rsect = "#P"
Else
rsect = "#T"
End If
If Me.UltraFineGrid Then rsect = rsect & " Integral(UltraFineGrid)"
If Me.DispersChk And Not postSCF Then
Select Case Me.metodes
Case "UHF", "RHF", "rzindo", "APFD", "wB97XD", "M11", "M062X" 'Minnesota are said by authors to be already corrected...
Case Else
rsect = rsect & " EmpiricalDispersion=" & Me.DispersBox.Value
End Select
End If ' and not (me.metodes="UHF" or me.metodes="RHF" or me.metodes="rzindo" or
rsect = RTrim(Replace(Replace(rsect, ",Read,Read", ",Read"), " ", " "))
rsect = Replace(rsect, ")Mix", ")")
Print #gnum, rsect
Print #gnum, ""
''If st = nst Then MsgBox "rsect ok"
tsect = "::: " & tingeom & " " & toutgeom & " " & lapa & " " & asubfs(st) & " " & uzdprim & " " & Format(stprim)
If uzd = "GeometryOptimization" And Me.TsChk And Me.TsOptGrp = 1 And st = 1 Then
astefst = tsect
tsect = Replace(Replace(tsect, tingeom, "0000_000"), toutgeom, "0000_000")
End If
Print #gnum, Replace(tsect, "_", "/") ' on 08.02.2018. it was found that using underscore in Title section should be avoided (acc. to the manual)
Print #gnum, ""
tlad = Me.lad
tmult = Me.mult
If uzd = "Ionization" Or uzd = "ReorganizationEnergy" Then
tlad = ladfst(st)
tmult = (2 * Abs(tlad)) \ 2 + 1
ElseIf Not Me.NotCheckLadmultChk Then
If (InStr(toutgeom, "cation") > 0 And tlad <> 1) Or (InStr(toutgeom, "anion") > 0 And tlad < -1) Or (InStr(toutgeom, "ion") = 0 And tlad <> 0) Then MsgBox "Parbaudiet ladinus!"
End If
If cinfs(st) = "h" Then
readfragments inhin, fragments()
Print #gnum, ladmult
''If st = nst Then MsgBox "tsect and ladmult ok"
readxyz gnum, inhin
Else
ladmult = tlad & " " & tmult: Print #gnum, ladmult
End If
If LenB(PapEps) + LenB(PapInf) + LenB(PapRedun) + LenB(PapReaf) + LenB(PapRW) + LenB(PapEPT) + LenB(PapCHK) + LenB(PapFCHT) + LenB(PapPop) Or InStr(rsect, "ADMP") > 0 Or Me.TsChk Or InStr(Me.baze, "Gen") > 0 Then
If LenB(PapRedun) Then
Print #gnum,
Print #gnum, PapRedun
End If
If Me.TsChk And (Me.TsOptGrp = 2 Or Me.TsOptGrp = 3) And InStr(rsect, " Opt") > 0 Then
Print #gnum,
Print #gnum, " End geometry for Q-ST-" & Me.TsOptGrp & " job"
Print #gnum,
Print #gnum, ladmult
readxyz gnum, dirnamefi(Me.geom) & Me.Qst2geom & ".hin"
If LenB(PapRedun) Then
Print #gnum,
Print #gnum, PapRedun
End If
End If
If Me.TsChk And Me.TsOptGrp = 3 And InStr(rsect, " Opt") > 0 Then
Print #gnum,
Print #gnum, " Prov. transition state geometry for Q-ST-3 job"
Print #gnum,
Print #gnum, ladmult
If Not (InStr(rsect, "CalcAll") > 0 And InStr(Me.IzlaistSolus, "1") = 0) Then readxyz gnum, dirnamefi(Me.geom) & Me.Qst3geom & ".hin" Else Print #gnum, "==GETTSQST=="
If LenB(PapRedun) Then
Print #gnum,
Print #gnum, PapRedun
End If
End If
If LenB(PapReaf) Then
Print #gnum,
Print #gnum, PapReaf
End If
If InStr(rsect, "ADMP") > 0 Then
Print #gnum,
End If
If InStr(uzd, "StateAbsorpt") + InStr(uzd, "StateEmiss") > 0 And st = 2 Then: murr = 1: aiiu = 2: Else: murr = 2: aiiu = 1
For wasithuh = murr To aiiu Step aiiu - murr
If wasithuh = 1 Then
If LenB(PapEps) Then
Print #gnum,
Print #gnum, PapEps
End If
If LenB(PapInf) Then
If LenB(PapEps) = 0 Then Print #gnum,
Print #gnum, LTrim(PapInf)
End If
Else
If InStr(Me.baze, "Gen") > 0 And Not semiEmp Then
' $$$$$$$$$$$$$$ MOST PROBLEMS WITH THIS SECTION $$$$$$$$$$$$$$$$$$$$$$$$$
If Left(Me.GenBStxb.Value, 2) = "@M" Then
Print #gnum,
If tlinux Then Print #gnum, "@" & dirnamefi(4) & "../basissets/" & Mid(Me.GenBStxb.Value, 2) Else Print #gnum, "@" & dirnamefi(4) & "..\basissets\" & Mid(Me.GenBStxb.Value, 2) & ".gbs"
Else
Dim skinkis As Integer, sviests As Integer
sviests = Me.GenSelectionLst.ListCount
Print #gnum,
For skinkis = 0 To Me.GenSelectionLst.ListCount - 1
If Left(Me.GenSelectionLst2.ItemData(skinkis), 1) = "@" Then
If tlinux Then Print #gnum, "@" & dirnamefi(4) & "../basissets/" & Mid(Me.GenSelectionLst2.ItemData(skinkis), 2) & ".gbs" Else Print #gnum, "@" & dirnamefi(4) & "..\basissets\" & Mid(Me.GenSelectionLst2.ItemData(skinkis), 2) & ".gbs"
Else
Print #gnum, Me.GenSelectionLst.ItemData(skinkis)
Print #gnum, Me.GenSelectionLst2.ItemData(skinkis)
Print #gnum, "****"
End If
On Error Resume Next
If Me.GenSelectionLst.ItemData(skinkis + 1) = "==STARTECP==" Then: sviests = skinkis + 2: Exit For
Next skinkis
End If
End If
If Me.baze = "GenECP" And Not semiEmp And Not Left(Me.GenBStxb.Value, 2) = "@M" Then
Print #gnum,
For skinkis = sviests To Me.GenSelectionLst.ListCount - 1
If Left(Me.GenSelectionLst2.ItemData(skinkis), 1) = "@" Then
If tlinux Then Print #gnum, "@" & dirnamefi(4) & "../basissets/" & Mid(Me.GenSelectionLst2.ItemData(skinkis), 2) & ".ecp" Else Print #gnum, "@" & dirnamefi(4) & "..\basissets\" & Mid(Me.GenSelectionLst2.ItemData(skinkis), 2) & ".ecp"
Else
Print #gnum, Me.GenSelectionLst.ItemData(skinkis)
Print #gnum, Me.GenSelectionLst2.ItemData(skinkis)
End If
Next skinkis
End If
If InStr(Me.baze, "Gen") > 0 And Not semiEmp Then
Print #gnum, "!"
Print #gnum, "!==GENBASISSET== " & Replace(Me.GenBStxb, "@", "")
End If
On Error GoTo 0
End If
Next wasithuh
' $$$$$$$$$$$$$$ MOST PROBLEMS WITH THIS SECTION - END $$$$$$$$$$$$$$$$$$$$$$$$$
If st > 1 Then
If asubfs(st - 1) = "Frag" Then
Print #gnum,
Print #gnum, PapFrag
End If
End If
If LenB(PapRW) Then
Print #gnum,
Print #gnum, PapRW
End If
If LenB(PapEPT) Then
Print #gnum,
Print #gnum, PapEPT
End If
If LenB(PapPop) Then
Print #gnum,
For aiiu = 1 To UBound(PapPopfs)
Print #gnum, PapPopfs(aiiu)
Next aiiu
End If
If LenB(PapFCHT) Then
Print #gnum,
Print #gnum, Trim(PapFCHT)
End If
If LenB(PapCHK) Then
Print #gnum,
Print #gnum, PapCHK
End If
Else
If st > 1 Then
If asubfs(st - 1) = "Frag" Then
Print #gnum,
Print #gnum, PapFrag
End If
End If
End If
If (Me.FormchkChk Or (uzd = "GeometryOptimization" And st = 3)) And Not lapa = "ElectronicSpectrum" Then
If Me.FormchkEveryChk Then
Print #gnum,
On Error Resume Next
Print #gnum, "!lutil formchk " & outchk & " " & toutgeom & "." & Replace(Replace(Replace(Replace(Replace(Me.metodes.Value & "_" & Me.baze.Value & "_" & Me.vide.Value, ")", ""), "(", ""), ",", ""), "=", ""), "-", "") & ".st" & st & ".fchk"
anylutil = True
On Error GoTo 0
ElseIf st = nst Then
Print #gnum,
Print #gnum, "!lutil formchk " & outchk & " " & toutgeom & "." & Replace(Replace(Replace(Replace(Replace(Me.metodes.Value & "_" & Me.baze.Value & "_" & Me.vide.Value, ")", ""), "(", ""), ",", ""), "=", ""), "-", "") & ".fchk"
anylutil = True
End If
End If
If Me.IterativeEpsilon And (Me.vide = "Generic" Or Me.vide = "SelfSolute") And st = nst Then
If Not anylutil Then Print #gnum,
Print #gnum, "!lutil getepsilon " & dirnamefi(4) & Me.outname_txb & ".out 1 " & Me.GetEpsilonThreshTxb.Value & " " & Me.eps & " " & Me.epsinf
anylutil = True
End If
''If st = nst Then MsgBox "papinfo ok, will now close file"
'### Tail jobs section
'### Tail (actually front) job GeomOpt TS (Berny)
If uzd = "GeometryOptimization" And Me.TsChk And Me.TsOptGrp = 1 And st = 1 And Not postSCF Then
Print #gnum,
Print #gnum, "--Link1--"
Print #gnum,
Print #gnum, "%Mem=" & tmem
Print #gnum, "%NProcShared=" & Format(tproc)
Print #gnum, CHKstring
Print #gnum,
rsect = ladfst
chatyp = axb(ladfst & " ", "Guess=", " ")
ladfst = Replace(Replace(Replace(Replace(ladfst, axb(ladfst, "/", " "), "ChkBasis"), " Opt", " Opt=(TS,ReadFC,MaxStep=2)"), ")=(", ","), " Guess=" & chatyp, "") & " Geom=Check"
If InStr(chatyp, "Read") = 0 Then ladfst = ladfst & " Guess=Read"
If Me.GuessMix And InStr(chatyp, "Mix") = 0 Then ladfst = Replace(ladfst, "Guess=Read", "Guess=(Read,Mix)")
Print #gnum, ladfst
Print #gnum,
Print #gnum, CStr(astefst)
Print #gnum,
Print #gnum, ladmult
If LenB(PapReaf) Then
Print #gnum,
Print #gnum, PapReaf
End If
If InStr(rsect, "ADMP") > 0 Then
Print #gnum,
End If
If LenB(PapEps) Then
Print #gnum,
Print #gnum, PapEps
End If
If LenB(PapInf) Then
If LenB(PapEps) = 0 Then Print #gnum,
Print #gnum, LTrim(PapInf)
End If
If st > 1 Then
If asubfs(st - 1) = "Frag" Then
Print #gnum,
Print #gnum, PapFrag
End If
End If
If LenB(PapRW) Then
Print #gnum,
Print #gnum, PapRW
End If
If LenB(PapEPT) Then
Print #gnum,
Print #gnum, PapEPT
End If
If LenB(PapFCHT) Then
Print #gnum,
Print #gnum, Trim(PapFCHT)
End If
If LenB(PapCHK) Then
Print #gnum,
Print #gnum, PapCHK
End If
'Print #gnum,
End If
'### Tail job GeomOpt InterGuess
If uzd = "GeometryOptimization" And st = 1 And Not postSCF Then
Print #gnum,
Print #gnum, "--Link1--"
Print #gnum,
Print #gnum, "%Mem=" & tmem
Print #gnum, "%NProcShared=" & Format(tproc)
Print #gnum, CHKstring
Print #gnum,
rsect = Replace(Replace(Replace(rsect, axb(rsect, "/", " "), "ChkBasis"), " Geom=Check", ""), " Guess=" & axb(rsect & " ", " Guess=", " "), "")
If InStr(rsect, "Opt") > 0 Then rsect = Replace(rsect, "Opt" & axb(rsect, " Opt", " "), "Stable=Opt Geom=Check Guess=(TCheck,Mix)") _
Else rsect = Replace(rsect, "SP" & axb(rsect, " Opt", " "), "Stable=Opt Geom=Check Guess=(TCheck,Mix)")
rsect = Replace(Replace(rsect, " Volume=Tight", ""), "Pop" & axb(rsect, " Pop", " "), "")
Print #gnum, rsect
Print #gnum,
Print #gnum, "::: 0000_000 0000_000 GeomOptInterGuess ItrGs SinglePoint 1" 'must be konown TaskName, otherwise sagatavots will mess TaskList selection
Print #gnum,
Print #gnum, ladmult
If LenB(PapEps) Then
Print #gnum,
Print #gnum, PapEps
End If
If LenB(PapInf) Then
If LenB(PapEps) = 0 Then Print #gnum,
Print #gnum, LTrim(PapInf)
End If
'Print #gnum,
End If
'### Tail job Natural Orbitals
If (nononono Or (natonatonato And (Me.Uzdevumi > 5 And Me.Uzdevumi < 14))) And st = nst And Not Me.FormchkChk Then
If Not anylutil Then Print #gnum,
Print #gnum, "!lutil echo 'Splitting for convenience...'"
anylutil = True
End If
If postSCF Then
If Not anylutil Then Print #gnum,
Print #gnum, "!lutil rm /work/igors/*.rwf /public/igors/*.rwf"
End If
If nononono And st = nst Then
Print #gnum,
Print #gnum, "--Link1--"
Print #gnum,
Print #gnum, "%Mem=" & tmem
Print #gnum, "%NProcShared=" & Format(tproc)
Print #gnum, CHKstring
Print #gnum,
Print #gnum, "# Guess=(Save,Only,NaturalOrbitals) Pop=None Geom=AllCheck ChkBasis"
Print #gnum,
Print #gnum, "::: 0000_000 0000_000 NaturalOrbitals Nao SinglePoint 1" 'must be konown TaskName, otherwise sagatavots will mess TaskList selection
Print #gnum,
Print #gnum, "!lutil formchk " & outchk & " " & toutgeom & "." & Replace(Replace(Replace(Replace(Replace(Me.metodes.Value & "_" & Me.baze.Value & "_" & Me.vide.Value, ")", ""), "(", ""), ",", ""), "=", ""), "-", "") & "_NBOs.fchk"
'Print #gnum,
End If
If natonatonato And st = nst And (Me.Uzdevumi > 5 And Me.Uzdevumi < 14) Then
Dim zlato As Integer, znato As Integer, natonato() As String, multerm As String
znato = vardx(Me.NaTOtxb.Value, natonato(), ",")
If sonne > 1 Then: znato = 1: natonato(1) = stavokliSS(ophiur)
For zlato = 1 To znato
Print #gnum,
Print #gnum, "--Link1--"
Print #gnum,
Print #gnum, "%Mem=" & tmem
Print #gnum, "%NProcShared=" & Format(tproc)
Print #gnum, Replace(CHKstring, "%", "%Old")
Select Case Me.IerosMult
Case 1
multerm = "S"
Case 3
multerm = "T"
Case 2
multerm = "D"
Case 4
multerm = "Q"
Case Else
multerm = "M"
End Select
Dim newCHKstring As String: newCHKstring = dirnamefi(4) & Replace(Me.InGeom, ".chk", "") & "." & Replace(Replace(Replace(Replace(Replace(Me.metodes.Value & "_" & Me.baze.Value & "_" & Me.vide.Value, ")", ""), "(", ""), ",", ""), "=", ""), "-", "") & "_" & multerm & natonato(zlato) & ".chk"
Print #gnum, "%Chk=" & newCHKstring
Print #gnum,
rsect = "# MaxDisk=" & tmaxdisk
If Me.Unrestrict Then rsect = _
rsect & " U" & Me.metodes.Value & "/ChkBasis" Else _
rsect = rsect & " " & Me.metodes.Value & "/ChkBasis"
rsect = rsect & " Guess=(Only,Read) Geom=Check Density=(Check,Transition=" & natonato(zlato) & ") Pop=(Min,SaveNTO)"
Print #gnum, rsect
Print #gnum,
Print #gnum, "::: 0000_000 0000_000 NaturalTransitionOrbitals Nao ElectronicSpectrum 1"
Print #gnum,
Print #gnum, ladmult
Print #gnum,
Print #gnum, "!lutil formchk " & newCHKstring & " " & Left(newCHKstring, Len(newCHKstring) - 4) & ".fchk"
'Print #gnum,
Next zlato
End If
'Print #gnum,
Close #gnum
End If '### (nav izlaists)
If asubfs(st) = "Frag" Then bijafrag = bijafrag + 1
nophiur2:
Next st
Next ophiur
Next multimola
Me.AtvertPapildinat = 2
sagatavots gnum
Me.SetFocus
'DoCmd.Close
End Sub