You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
222 lines
6.3 KiB
222 lines
6.3 KiB
<job id="SubsMacros-MSWord">
|
|
<reference guid="{00020905-0000-0000-C000-000000000046}"/>
|
|
<script language="VBScript">
|
|
Option Explicit
|
|
On Error Resume Next
|
|
Dim digitDict
|
|
digitDict = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
|
|
|
Dim fs, WshShell
|
|
Set fs = CreateObject("Scripting.FileSystemObject")
|
|
Set WshShell = WScript.CreateObject("WScript.Shell")
|
|
|
|
Dim docFileName, txtFileName
|
|
If WScript.Arguments.Count < 2 Then
|
|
MsgBox "Usage: SubsMacros-MSWord <doc file> <data file>"
|
|
WScript.Quit
|
|
End If
|
|
docFileName = WScript.Arguments(0)
|
|
txtFileName = WScript.Arguments(1)
|
|
'docFileName = "C:\Users\cloong\Desktop\新建文件夹\新品立项报告书-WFQ-R-19-002A.docm"
|
|
'txtFileName = "C:\Users\cloong\Desktop\新建文件夹\变更通知单.docm.txt"
|
|
Dim wordApp
|
|
'Do
|
|
' Set wordApp = Nothing
|
|
' Set wordApp = GetObject(, "Word.Application")
|
|
' wordApp.Quit
|
|
'Loop Until wordApp Is Nothing
|
|
'Err.Clear
|
|
'On Error Resume Next
|
|
|
|
Dim docFilePath, pathLen
|
|
For pathLen = Len(docFileName) To 1 Step -1
|
|
If Mid(docFileName, pathLen, 1) = "\" Then
|
|
docFilePath = Left(docFileName, pathLen)
|
|
Exit For
|
|
End If
|
|
Next
|
|
'WshShell.Run "cmd.exe /c del /f /ah " & docFilePath & "~*.doc"
|
|
|
|
Dim txtFile, line, data
|
|
If fs.FileExists(docFileName) = False Then
|
|
'WScript.Echo "File " & docFileName & " doesn't exist!"
|
|
WScript.Quit
|
|
End If
|
|
If Not Right(docFileName, 4) = ".doc" Then
|
|
If Not Right(docFileName, 5) = ".docm" Then
|
|
'MsgBox "数据集引用文件 " & docFileName & " 扩展名不是.docm或doc, 可能出现不正确结果. 建议将扩展名改为.doc.docm"
|
|
End If
|
|
End If
|
|
If fs.FileExists(txtFileName) = False Then
|
|
'WScript.Echo "File " & txtFileName & " doesn't exist!"
|
|
WScript.Quit
|
|
End If
|
|
|
|
Set txtFile = fs.OpenTextFile(txtFileName)
|
|
line = txtFile.ReadLine()
|
|
txtFile.Close
|
|
Set data = ReadObject(line)
|
|
|
|
Dim doc
|
|
Dim docVar, varIndex
|
|
Dim pages
|
|
'Dim word, name, value, startPos, endPos,preword
|
|
Set wordApp = CreateObject("Word.Application")
|
|
'wordApp.Visible = True
|
|
Set doc = wordApp.Documents.Open( docFileName )
|
|
pages = doc.Windows(1).Panes(1).Pages.Count
|
|
'WScript.Echo pages
|
|
'检查所有的客户化属性，赋初值
|
|
Dim intProp, cusProp
|
|
For intProp = 1 To doc.CustomDocumentProperties.Count
|
|
If doc.CustomDocumentProperties(intProp).Value = "" Then
|
|
doc.CustomDocumentProperties(intProp).Value = " "
|
|
End If
|
|
Next
|
|
|
|
'更新属性值
|
|
|
|
Dim oShape
|
|
Dim t, dataName, dataVal ,pic,str,pim,i,pageName
|
|
Dim ObjSelection,wordRange
|
|
On Error Resume Next
|
|
For Each t In data
|
|
On Error Resume Next
|
|
dataName = t
|
|
If Right(data(dataName), 4) =".jpg" Or Right(data(dataName), 4) =".png" Or Right(data(dataName), 5) =".jpg," Or Right(data(dataName), 5) =".png," Then
|
|
'WScript.Echo "插入图片"
|
|
'WScript.Echo data(dataName)
|
|
|
|
str = data(dataName)
|
|
'WScript.Echo dataName
|
|
Set wordRange =wordApp.selection.Goto( , , ,dataName)
|
|
Set ObjSelection=wordApp.selection
|
|
if err.number=0 Then
|
|
On Error Resume Next
|
|
if(Right(str, 1) ="g") Then
|
|
Set pim = ObjSelection.InlineShapes.AddPicture(str)
|
|
pim.Title="wfword"
|
|
Set oShape = pim.ConvertToShape
|
|
'oShape.WrapFormat.Type = WdWrapType.wdWrapTopButtom
|
|
oShape.WrapFormat.Type = 3
|
|
oShape.ZOrder 4
|
|
oShape.WrapFormat.AllowOverlap = False
|
|
End If
|
|
End if
|
|
'If (pages > 1) Then
|
|
'For i = 1 to pages-1
|
|
'pageName = dataName & i
|
|
'WScript.Echo pageName
|
|
'Set wordRange =wordApp.selection.Goto( , , ,pageName)
|
|
'Set ObjSelection=wordApp.selection
|
|
'if err.number=0 Then
|
|
'On Error Resume Next
|
|
'if(Right(str, 1) ="g") Then
|
|
'Set pim =ObjSelection.InlineShapes.AddPicture(str)
|
|
'pim.Title="wfword"
|
|
'End If
|
|
'End if
|
|
'Next
|
|
'End If
|
|
err.Clear
|
|
End If
|
|
Next
|
|
|
|
|
|
|
|
Dim aStory, aField
|
|
For Each aStory In doc.StoryRanges
|
|
For Each aField In aStory.Fields
|
|
aField.Update
|
|
Next
|
|
Next
|
|
|
|
|
|
Dim sh
|
|
dim l1
|
|
dim n1
|
|
dim n2
|
|
|
|
On Error Resume Next
|
|
For Each sh in doc.Shapes
|
|
startPos = -1 : endPos = -1
|
|
name=trim(sh.TextFrame.TextRange.text)
|
|
|
|
If left(name, 2) = "&[" and mid(name,len(name)-1,1) = "]" then
|
|
l1=len(name)
|
|
n1=right(name,l1-2)
|
|
n2=left(n1,l1-4)
|
|
name=n2
|
|
|
|
If data.Exists(name) Then
|
|
value = data(name)
|
|
|
|
sh.TextFrame.TextRange.Text=value
|
|
wordApp.Selection.Find.Execute wdReplaceAll
|
|
'WScript.Echo "wordApp.Selection.Find.Execute wdReplaceAll"
|
|
Else
|
|
|
|
value = "(?)"
|
|
'WScript.Echo "(?)"
|
|
'doc.Range(startPos-2, endPos+1).Text = value
|
|
End If
|
|
|
|
' WScript.Echo "Substituting " & doc.Range(startPos, endPos).Text & " to " & value
|
|
startPos = -1 : endPos = -1
|
|
End If
|
|
Next
|
|
'On Error Goto 0
|
|
'Err.Clear
|
|
doc.Save
|
|
'WScript.Echo "插入图片成功"
|
|
doc.Close
|
|
|
|
wordApp.Quit
|
|
'WshShell.Run "cmd.exe /c del /f /ah " & docFilePath & "~*.doc"
|
|
'WScript.Echo "end"
|
|
|
|
If Err.Number > 0 Then
|
|
' WScript.Echo "脚本执行过程中发生了错误 '" & Err.Description & "', 很可能导致了不正确的结果, 请检查相应数据."
|
|
End If
|
|
|
|
Function ReadObject(dataline)
|
|
Dim data, nvpair, nv
|
|
Set ReadObject = CreateObject("Scripting.Dictionary")
|
|
data = Split(dataline, "|")
|
|
For Each nvpair In data
|
|
nv = Split(nvpair, "=")
|
|
If UBound(nv) >= 1 Then
|
|
If Not ReadObject.Exists(nv(0)) Then
|
|
ReadObject.Add nv(0), SubstEscSeq(nv(1))
|
|
End If
|
|
End If
|
|
Next
|
|
End Function
|
|
|
|
Function digitValue(hexStr)
|
|
digitValue = InStr(digitDict, hexStr) - 1
|
|
'WScript.Echo "Decode hex char " & hexStr & " to " & digitValue
|
|
End Function
|
|
|
|
Function SubstEscSeq(str)
|
|
Dim startPos, tokenPos, strLen
|
|
SubstEscSeq = ""
|
|
strLen = Len(str)
|
|
startPos = 1
|
|
Do While startPos < strLen
|
|
tokenPos = InStr(startPos, str, "%")
|
|
If tokenPos < 1 Then
|
|
Exit Do
|
|
End If
|
|
SubstEscSeq = SubstEscSeq + Mid(str, startPos, tokenPos - startPos)
|
|
'WScript.Echo "Hex token " & Mid(str, tokenPos, 3) & " decoded to asc value: " & digitValue(Mid(str, tokenPos+1, 1)) * 16 + digitValue(Mid(str, tokenPos+2, 1))
|
|
SubstEscSeq = SubstEscSeq + Chr(digitValue(Mid(str, tokenPos+1, 1)) * 16 + digitValue(Mid(str, tokenPos+2, 1)))
|
|
startPos = tokenPos + 3
|
|
Loop
|
|
SubstEscSeq = SubstEscSeq + Mid(str, startPos, strLen - startPos + 1)
|
|
'WScript.Echo "Decoded string from " & str & " to " & SubstEscSeq
|
|
End Function
|
|
|
|
</script>
|
|
</job>
|