ShiBao_WorkSpacce/SubstMacros-MSExcel.wsf

<job id="SubsMacros-MSExcel">
	<script language="VBScript">
		Option Explicit
		On Error Resume Next
		Dim digitDict
		
		digitDict = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		
		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\新建文件夹\验证计划DVP&R-WFQ-R-19-008A.xlsm"
		'txtFileName = "C:\Users\cloong\Desktop\新建文件夹\变更通知单.docm.txt"
		
		Dim fs, txtFile, line, data
		Set fs = CreateObject("Scripting.FileSystemObject")
		If fs.FileExists(docFileName) = False Then
			'WScript.Echo "File " & docFileName & " doesn't exist!"
			WScript.Quit
		End If
		If Not Right(docFileName, 5) = ".xlsm" Then
			'MsgBox "数据集引用文件 " & docFileName & " 扩展名不是.xlsm, 可能出现不正确结果. 建议将扩展名改为.xlsm"
		End If			
		If fs.FileExists(txtFileName) = False Then
			'WScript.Echo "File " & txtFileName & " doesn't exist!"
			WScript.Quit
		End If
		Dim metaDic,nvpair,nv
		Set txtFile = fs.OpenTextFile(txtFileName)
		Set metaDic = CreateObject("Scripting.Dictionary")				'将dataFile第一行的数据转换为metaDic
		line = txtFile.ReadLine
		data = Split(line, "|")
		For Each nvpair In data
			nv = Split(nvpair, "=")
			If UBound(nv) > 0 Then
				If Not metaDic.Exists(nv(0)) Then
					metaDic.Add nv(0), nv(1)
				End If
			End If
		Next

		Dim excelApp, workbook, workSheet
		Set excelApp = CreateObject("Excel.Application")
		'excelApp.Visible = True
		Set workbook = excelApp.Workbooks.Open(docFileName)
		'For n=1 to workbook.Sheets.Count
			'Set workSheet = workbook.Sheets(n)
	
	
			'With workSheet
			'WScript.Echo workbook.Names.Count
			Dim NameItem,n,item,subvalue,attrName,ReferTo, Pos,subPos,col,row,range,sheetStr,pic
			For Each NameItem In workbook.Names
			'For Each NameItem in workbook.Names
				'Set NameItem = workbook.Names.item(n)
				'WScript.Echo NameItem.Name
				For Each item In data
					If item <> "" then
					subvalue = Split(item,"=")
					'WScript.Echo subvalue(0)
					If (Left(NameItem.Name, 3) = Left(subvalue(0), 3)) Then
					
					'attrName = Right(subvalue(1), Len(subvalue(1))-1)
					'WScript.Echo  subvalue(0)
					Pos = NameItem.Value
					
					subPos = Split(Pos,"$")
					'WScript.Echo Pos
					'WScript.Echo subPos(2)
					range = subPos(1) & subPos(2)
					sheetStr = Mid(subPos(0),2 ,Len(subPos(0))-2)

					
					
					if Right(subvalue(1), 4) = ".jpg" Or Right(subvalue(1), 4) = ".png" Or Right(subvalue(1), 5) = ".jpg," Or Right(subvalue(1), 5) = ".png,"Then
					Dim t,l,w,h,strs,str,Fso,i
					'WScript.Echo "插入图片"
					'Set Fso = CreateObject("Scripting.FileSystemObject")
					'WScript.Echo sheetStr
					workbook.Sheets(sheetStr).Select
					workbook.Sheets(sheetStr).Range(range).Select
					strs = Split(subvalue(1), ",")
					i=0
					On Error Resume Next 
					For Each str In strs
					if(Right(str, 1) ="g") Then
					 Set  Fso=workbook.Sheets(sheetStr).Shapes.AddPicture(str, False, True,workbook.Sheets(sheetStr).Range(range).Left+i, workbook.Sheets(sheetStr).Range(range).Top+5, 60, 65)
					
					Fso.Name="jkexcel"
					'Fso.ShapeRange.IncrementTop 5
					'Fso.ShapeRange.IncrementLeft i
					
					i=i+40
					End If	
					

			        Next	
                    
						
					excelApp.ActiveSheet.PageSetup.CenterHorizontally = 2/0.035 
					excelApp.ActiveSheet.PageSetup.CenterVertically = 2/0.035 
					Else
					'WScript.Echo subvalue(1)
					col= workbook.Sheets(sheetStr).Range(range).Column
					workbook.Sheets(sheetStr).cells(Int(subPos(2)),Int(col)).Value = subvalue(1)
					
					End if
					
					
					End if
					End if
				Next
			Next
			
		'End With	
		'Next	
'		With workSheet
'			Dim curRow, curCol, colCount,rowCount, cellValue, attrName, item, cellName, subvalue, NameItem
'			colCount = .UsedRange.Columns.count
'			rowCount = .UsedRange.Rows.count
'			Dim n
'			WScript.Echo .Names.count
'			For n= 1 To workSheet.Names.count
'				Set NameItem = workSheet.Names.item(n)
'				WScript.Echo NameItem.Name
'				WScript.Echo NameItem.Value
'			Next
'			For curRow = 1 To (rowCount+.UsedRange.Row)											'遍历题头至题尾的每一行,将该行的每一个&attrName替换为metaDic.Item(attrName)
'					For curCol = 1 To (colCount+.UsedRange.Column)
'						For Each NameItem In workbook.Names
'							If .cells(curRow,curCol).Value <> "" Then
'								For Each item In data
'									subvalue = Split(item,"=")
'									If subvalue(0) = NameItem.Name Then
'										attrName = Right(subvalue(1), Len(subvalue(1))-1)
'										.cells(curRow,curCol)= attrName
'									End if
'								Next
'							End If
'						Next
'					Next
'			Next
'		End With

			
		If Err.Number > 0 Then
			WScript.Echo "脚本执行过程中发生了错误 '" & Err.Description & "', 很可能导致了不正确的结果, 请检查相应数据."
		End If
		workbook.Save
		
		workbook.Close 
		excelApp.Quit
		'WScript.Echo "end"
		WScript.Quit				

		
		Function digitValue(hexStr)
			digitValue = InStr(digitDict, hexStr) - 1
			'WScript.Echo "Decode hex char " & hexStr & " to " & digitValue
		End Function
		
	</script>
</job>