Кто-нибудь сталкивался со следующей проблемой: код VBA, который записывает в текстовый файл, открывая и закрывая файл несколько раз в процессе (потому что иногда ему также необходимо прочитать один и тот же файл), пропускает фактическую запись в файл внекоторые части кода (в основном внутри блоков If).Более того, код работает хорошо, если его запускать для одного файла, но когда код помещается в цикл для многократного выполнения одной и той же вещи (с набором различных входных параметров), иногда происходит пропуск.Более того, если я добавлю дополнительные открытия / записи / комментарии в строке комментариев, код иногда будет работать так, как задумано (эти строки комментариев не записываются в текстовый файл).Наконец, если я вставлю точки останова в код и просто последовательно нажму кнопку «Выполнить» в VBEditor, код также будет работать абсолютно так, как задумано.И один из моих коллег тоже испытал это с его кодом, на другом ПК.
Решение (кажется) для описанной проблемы было следующим:
Iпонял, что открытие / закрытие файла много раз, вероятно, не лучший вариант.Поскольку я переписал код, чтобы переместить все части «Открыть для ввода» перед теперь единственной частью «Открыть для добавления», все снова работает нормально.Поэтому сама проблема решена, но я спрашиваю из интереса: почему это произошло? Может быть, это также будет актуально для других пользователей.
Эта проблемапроизошло сначала через некоторое время после обновления до Windows 10 и Office 2013. Возможно, это связано с некоторыми установленными обновлениями.Может ли это иметь отношение к модификациям / дополнениям алгоритма чтения / записи в VBA?
Код с извлеченными не относящимися к делу материалами находится здесь (части, которые испытывают частую проблему не пишется , включены в"$$$$$$$$$$$$$$ НАИБОЛЕЕ ПРОБЛЕМЫ С ЭТИМ РАЗДЕЛЕМ $$$$$$$$$$$$$$$$$$$$$$$$$" строки):
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