循环在Windows 10中不起作用

Question

我很难搞清楚这一点，代码适用于Windows XP和7循环以及复制和清理.hml代码的顺序，但是在获得Windows 10后循环或复制和粘贴的顺序。 hml文件总是出错。从第一个文件复制的代码将粘贴到其他文件上，而不是仅从同一文件复制和粘贴。

Private Sub pather_Click()

Dim npad As Double
Dim npadd As String
Dim AltKey As String
Dim CtrlKey As String
Dim pather As String
Dim filer As Integer

filer = 0
AltKey = "%"
CtrlKey = "^"

pather = TextBox18.Value & "\"
npadd = pather & filer & ".htm"
sdir = Dir$(npadd, vbNormal)

If TextBox18.Value = "" Then
MsgBox "Input path"
ElseIf LenB(sdir) = 0 Then
MsgBox "Incorrect path"
Else
Do Until LenB(sdir) = 0
npad = Shell("notepad.exe" & " " & pather & filer & ".htm", vbNormalFocus)
SendKeys CtrlKey & "(a)", True
SendKeys CtrlKey & "(c)", True
Documents.Add DocumentType:=wdNewBlankDocument

Selection.Paste
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Options.AutoFormatAsYouTypeReplaceQuotes = False

With Selection.Find
.Text = "\<A (*)\>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

With Selection.Find
.Text = "\</A\>*<DIV (*)\>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

Selection.WholeStory
Selection.Cut

ActiveDocument.Close savechanges:=False

SendKeys CtrlKey & "(v)", True
SendKeys AltKey & "(fs)", True
SendKeys AltKey & "(fx)", True

filer = filer + 1
npadd = pather & filer & ".htm"
sdir = Dir$(npadd, vbNormal)
Loop

MsgBox "DONE"

End If
End Sub