com.connor.ldy/SubstMacros-MSWord.wsf

<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)
		
		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) = ".docx" 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 word, name, value, startPos, endPos,preword
		Set wordApp = CreateObject("Word.Application")
		'wordApp.Visible = True
		Set doc = wordApp.Documents.Open( docFileName )	
	
		'检查所有的客户化属性，赋初值
		Dim intProp, cusProp
		For intProp = 1 To doc.CustomDocumentProperties.Count
			If doc.CustomDocumentProperties(intProp).Value = ""  Then
				doc.CustomDocumentProperties(intProp).Value = " "
			End If
		Next
		
		'更新属性值
		
		Dim t, dataName, dataVal ,pic,strs,str,pim
		Dim ObjSelection,wordRange
		On Error Resume Next
		For Each t In data  '每个each以|区分，不是日期就是图片地址，都是“属性=值”的形式，其中dataName是属性，data(dataName)是值
			On Error Resume Next
			dataName = t
        '如果是以图片格式结尾的数据，data(dataName)大致就是取=以后的值
			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)
			
			strs = Split(data(dataName), ",")
			Set wordRange =wordApp.selection.Goto( , , ,dataName)  'selection.goto定位到某个书签
			    Set ObjSelection=wordApp.selection
			if err.number=0 Then
			For Each str In strs
				On Error Resume Next
				if(Right(str, 1) ="g") Then
			    Set  pim =ObjSelection.InlineShapes.AddPicture(str) '书签插入图片
				pim.Title="jkword" '?jkword是给签入的图片去个名字,下次可以根据名称删除
				End If	
			
			Next	
			End if 
			err.Clear
			
        '针对签名可能有多人的情况
			Dim lenght
			If doc.Bookmarks.Exists(dataName & "1")=True Then
			For lenght=1 to 40 
			On Error Resume Next
				If doc.Bookmarks.Exists(dataName & lenght)=True Then
				  Set wordRange =wordApp.selection.Goto( , , ,(dataName & lenght))
				  Set ObjSelection=wordApp.selection			   
			      if err.number=0 Then
			        For Each str In strs
				      On Error Resume Next
				      if(Right(str, 1) ="g") Then
			          Set pim =ObjSelection.InlineShapes.AddPicture(str)
				       pim.Title="jkword"
				      End If	
			         Next	
			      End if 
				End if
			Next
			End if
			err.Clear
			
			
			'如果不是以图片格式结尾，获得所有域,匹配名称,设值
			Else  
			For Each cusProp In doc.CustomDocumentProperties
			        
				If cusProp.Name = dataName Then
					
			       'WScript.Echo "插入" & dataName
					cusProp.Value = data(dataName)	'插入时间
					'WScript.Echo "cusProp.Value = data(dataName)"	
				
					Exit For
					
				End If		
			Next
			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
		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>