经常打开/关闭文本文件时，VBA会跳过对该文件的写入_Vba_File Writing

经常打开/关闭文本文件时，VBA会跳过对该文件的写入

vba

经常打开/关闭文本文件时，VBA会跳过对该文件的写入,vba,file-writing,Vba,File Writing,是否有人遇到过以下问题：VBA代码写入文本文件，在这个过程中多次打开和关闭文件（因为有时它还需要读取同一个文件），在代码的某些部分（主要在“If”块内）跳过了对文件的实际写入。此外，如果为一个文件启动代码，那么代码工作得很好，但如果将代码放入循环中多次执行相同的操作（使用一组不同的输入参数），则偶尔会发生跳过。更重要的是，如果我包括额外的打开/注释行写入/关闭，代码有时会按预期工作（这些注释行不会写入文本文件）。最后，如果我在代码中放置断点，然后在VBEditor中按“Run”按钮，代码也会完全

是否有人遇到过以下问题：VBA代码写入文本文件，在这个过程中多次打开和关闭文件（因为有时它还需要读取同一个文件），在代码的某些部分（主要在“If”块内）跳过了对文件的实际写入。此外，如果为一个文件启动代码，那么代码工作得很好，但如果将代码放入循环中多次执行相同的操作（使用一组不同的输入参数），则偶尔会发生跳过。更重要的是，如果我包括额外的打开/注释行写入/关闭，代码有时会按预期工作（这些注释行不会写入文本文件）。最后，如果我在代码中放置断点，然后在VBEditor中按“Run”按钮，代码也会完全按照预期运行。我的一位同事也曾在不同的PC机上使用过他的代码

所述问题的解决方案（似乎）如下：

我意识到多次打开/关闭文件可能不是最好的选择。由于我重新编写了代码，将所有“openforinput”部分移动到现在唯一的“openforappend”部分前面，所以一切又正常了。因此问题本身就解决了，但我出于兴趣问：为什么会发生这种情况？也许这也会与其他用户相关
此问题在升级到Windows 10和Office 2013后的一段时间内首次出现。然后可能会与安装的一些更新连接。这是否与VBA中的读/写算法修改/扩充相关
这里是提取了不相关内容的代码（经常出现未写入问题的部分包含在“$$$$$$$$$$$$本节的大多数问题中，$$$$$$$”行中）：

Private Sub ok\u Click（） "##########: dirnamefi=Array（，“Z:\HIN\u Files\，“Z:\Ad\u HIN\u Files\，”，tlocdisk） Dim ladfst作为变量，astefst作为变量，stprim作为整数，rsect作为字符串，ladmult作为字符串，tlad作为字符串，tmult作为字符串，tsect作为字符串'NoSave作为布尔值 Dim oldCHKstring作为字符串、CHKstring作为字符串、Link0string（）作为字符串、outchk作为字符串、darbachk作为字符串、wasithuh作为整数、anylutil作为布尔值、multiadd作为字符串、inhinfs（）作为字符串 Dim murr为整数，aiiu为整数，vibtrue为布尔值，cnames为字符串，tingeom为字符串，toutgeom为字符串，postSCF为布尔值，semiEmp为布尔值，ophiur为整数，sonne为整数 Dim SCFmod作为字符串，chatyp作为字符串，gnum作为整数，gname作为字符串，absem作为字符串，geomcheck作为字符串，uzdprim作为字符串，stavokliSS（）作为字符串，multimol作为整数，multimola作为整数如果InStr（Me.baze，“Gen”）>0且（Me.GenBStxb.Value=”“或为null（Me.GenBStxb.Value）），则：Me.GenBStxb.BackColor=RGB（255，200，200）：MsgBox“请填写Gen基本集名称！”：退出子：否则：Me.GenBStxb.BackColor=RGB（255，255） SCFmod=“”：anylutil=False postSCF=（仪表（仪表板）仪表（仪表板）仪表（仪表板）仪表（仪表板）仪表（仪表板）仪表（仪表板）仪表（仪表板）选择Case Me.metodes.Value 案例“AM1”、“PM3”、“PM6”、“PDDG”、“PM3MM”、“CNDO”、“INDO”、“MINDO”、“MINDO3”、“ZIndo” semiEmp=True:postSCF=False 案件“MP2”、“MP4（DQ）”、“CCSD”、“CCSD（T）”、“EPT”、“CASSCF”、“MP4” semiEmp=False:postSCF=True 其他情况 semiEmp=False:postSCF=False 结束选择如果Me.InGeom=“”，则：MsgBox“导航noradita izmantojama Geometricja！”：退出潜艇如果Me.FragmCkB和IsNull（Me.FragmTxtBx.Value），则：MsgBox“Nav noradits dalijums fragmentos！”：退出Sub 如果Me.frguessckb和IsNull（Me.IzlaistSolus.Value）=False，那么：如果LenB（Me.IzlaistSolus.Value）>0，那么MsgBox“Parbaudiet CHK rindas ievadfailaa！Vel nav ielabots，lai fragmenti strada kopa ar izlaistajiem。” gname=tdisk&“\”Me.outname\u txb&“.gjf” UzdPar“unum”，Me.Uzdevumi'从数据库读取输入 Dim nononono为布尔值，NATONATO为布尔值：nononono=False:natonatonato=False:sonne=1 如果lapa=“ElectronicSpectrum”，则sonne=vardx（Me.istate.Value，statovkliss（），“，”）如果Me.NaTO.Value和LenB（Me.NaTOtxb.Value）>0且lapa=“电子频谱”，则：natonato=True 如果Me.spinnotural.Value或Me.NOck.Value或Me.NOAB.Value，则nononono=True 如果Me.NBOcheck.Value或nononno或natonato，则使用FormchkChk.Value=True'或ESPcharge.Value Dim bjaka作为整数如果（uzd=“激发态吸收”或uzd=“激发态发射”）和vide=“真空”，则：MsgBox“Nevar veikt sho aprekinu vakuumaa！”：退出子系统 “可见”从访问表单读取 “多重初始化”################################################# multimol=1 ReDim保留inInfs（1到multimol）如果InStr（Me.InGeom.Value，“.chk”）>0，则 inhinfs（1）=Me.InGeom.Value 其他的 inhinfs（multimol）=Dir（dirnamefi（Me.geom）和Me.InGeom.Value&“.hin”）做多摩尔=多摩尔+1 reDim保留inInfs（1到multimol） inhinfs（multimol）=Dir（）循环直到LenB（inhinfs（multimol））=0 multimol=multimol-1 ReDim保留inInfs（1到multimol）如果结束如果IsNull（Me.OutGeom），则Me.OutGeom.Value=“” 如果InStr（Me.OutGeom，“*”）+InStr（Me.OutGeom，“？”）=0，则multiadd=Me.OutGeom.Value，否则multiadd=“” 如果multimol>1，则Me.OutGeom.Value=“” 对于multimola=1到multimol “多元文化”开始了################################################# Me.InGeom.Value=Replace（Replace（inhinfs（multimola），dirnamefi（Me.geom），“”），“.hin”，“”）如果Me.OutGeom.Value=“”和multimol=1，则 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