wps word vba修改 提取Wingdings 2打钩字体

wojoy

希望论坛大神可以帮忙修改一下提取出来是原表是如框框内这样的打钩

提取出来的大部分无论打没打钩都是如图“（”这样的

多日研究终未解决，只有求论坛大神了。。。。

wojoy

1. Sub 提取word表格1()
   
2. 
   
3.     Dim wApp, myfile, t
   
4.     mypath = ThisWorkbook.Path & ""
   
5.     myname = Dir(mypath & "*.doc")
   
6.     m = 1
   
7.         Do While myname <> ""
   
8.         Set mydoc = GetObject(mypath & myname)
   
9.         With mydoc
   
10.             m = m + 1
    
11.             mydoc.Content.Find.Execute findtext:=ChrW(163), ReplaceWith:="□", Replace:=2
    
12.             With .Tables(1)
    
13.                 Cells(m, 1) = m - 1
    
14.                 Cells(m, 2) = "'" & myname
    
15.                 Range("A1:F1") = Array("序号", "文件名", "报告编号", "住址", "A级", "B级")
    
16.                 Cells(m, 3) = Replace(.cell(2, 4).Range.Text, "", "")
    
17.                 Cells(m, 4) = Replace(.cell(5, 2).Range.Text, "", "")
    
18.                 Cells(m, 5) = Replace(.cell(25, 1).Range.Text, "(", "R")
    
19.                 Cells(m, 5) = Replace(Cells(m, 5).Text, "", "")
    
20.                 Cells(m, 5).Characters(Start:=1, Length:=1).Font.Name = "Wingdings 2"
    
21.                 Cells(m, 5).Characters(Start:=2, Length:=30).Font.Name = "宋体"
    
22.                 Cells(m, 6) = Replace(.cell(25, 2).Range.Text, "(", "R")
    
23.                 Cells(m, 6) = Replace(Cells(m, 6).Text, "", "")
    
24.                 Cells(m, 6).Characters(Start:=1, Length:=1).Font.Name = "Wingdings 2"
    
25.                 Cells(m, 6).Characters(Start:=2, Length:=30).Font.Name = "宋体"
    
26.             End With
    
27.             .Close False
    
28.         End With
    
29.         myname = Dir()
    
30.         Loop
    
31.         Set mydoc = Nothing
    
32.         MsgBox "提取完成"
    
33. 
    
34. End Sub
    

复制代码

zmj9151

Selection.Find.Text = ChrW(254) 或者是其它值，录宏可见

wojoy

zmj9151 发表于 2020-4-17 18:23
Selection.Find.Text = ChrW(254) 或者是其它值，录宏可见

小白不懂，可否帮我改一下

zmj9151

好象每个文档编码不一样,你试试