[原创] 学习vbs后的练习代码

weichenxiehou

前段时间学习了vbs，我的习惯是学习一门新的语言之后，得想方设法用它完成一个比较困难的任务，于是写了一个工作中可以用到的脚本，已经在部门内分发，反响不错。代码没什么通用性，大致是完成一些Excel表格的制作和文本文件与Excel的比对，与工作相关了。贴出来的目的，有作秀的成分，也有与vbs同学共勉的成分，最想的还是鼓励大家写一些较大型的程序，这样我们会接触到更多关于代码规范性和结构化的东西。本人仅菜鸟一枚，不必膜拜。

option explicit
'On Error Resume Next
dim strPrompt             	'function table string
dim intFunction				'holds user's choice
dim strChoices				'characters user can enter
dim objShell				'WScript shell object
dim fso						'File system object
dim setupfile				'setup file for this script
const ForReading=1			'ForWriting=2, ForAppending=8
dim i,item					'variables to walk through an array or loop
 
strPrompt="Choose a function from the table:" & vbNewLine &vbNewLine &_
			"1. Generate CIS Pre-BOM." & vbNewLine &_
			"2. Compare CIS and PDM BOMs." & vbNewLine &_
			"3. Generate HDL Pre-BOM." & vbNewLine &_
			"4. Compare HDL and PDM BOMs." & vbNewLine &_
			"5. Compare two PDM BOMs." & vbNewLine
strChoices="12345"
set objShell=CreateObject("WScript.Shell")
set fso=CreateObject("scripting.FileSystemObject")
setupfile=objShell.CurrentDirectory & "\setup.ini"
 
'function table
do
	intFunction=InputBox(strPrompt,"Function Table",1)
	if intFunction="" then WScript.Quit
loop until InStr(strChoices,Left(intFunction,1))
select case CInt(Left(intFunction,1))
	case 1
		call preBOM(1)
	case 2
		call Compare(1)
	case 3
		call preBOM(2)
	case 4
		call Compare(2)
	case 5
		call Compare(3)
	case else
		MsgBox "Runtime error, program will exit.", _
				vbOKOnly+vbExclamation,"error"
		WScript.Quit
end select
 
 
'****************function and subroutine area***************
'sub to read text bom file to generate pre-Bom
'CISorHDL identify the type of the text BOM, 1=CIS and 2=HDL
sub preBOM(CISorHDL)
	dim StartLine,PartNumber,Quantity, _
		IsPOP,NPOP,HeaderLine,Location, _
		SmdPN,DipPN,PcbPN						'values read from setup.ini
	dim dictSetup								'dictionary holding setup information
	dim arrCheckSetup							'holds all needed setup strings
	dim bomFile                                 'points to the bom file
	dim dictParts								'dictionary holds all parts, keys are part numbers
												'and items are class part objects
	dim strBegin								'identify the beginning of information scope
	dim strEnd									'idenfity the end of information scope
	
	'veriry preBOM type
	if CISorHDL=1 then
		strBegin="<CIS_preBOM>"
		strEnd="</CIS_preBOM>"
	elseif CISorHDL=2 then
		strBegin="<HDL_preBOM>"
		strEnd="</HDL_preBOM>"
	end if
	
	'check if all necessary information is aquired from setup.ini
	arrCheckSetup=Array("StartLine","PartNumber","Quantity","IsPOP", _
		"Location","NPOP","HeaderLine","SmdPN","DipPN","PcbPN")
	set dictSetup=ReadSetup(setupfile,strBegin,strEnd)
	for each item in arrCheckSetup
		if not dictSetup.Exists(item) then
			MsgBox "No """ & item & """ value found in " &_
				setupfile & ", please check your file.", _
				vbOkOnly+vbCritical,"Error"
		end if
		Execute(item & "=dictSetup.item(""" & item & """)")
	next
	
	'let user choose bom file
	'if user clicks CANCEL, program exists
	bomFile=BrowseForFile()
	if bomFile="" then
		WScript.Quit
	end if
	
	'begin to read parts
	set dictParts=CreateObject("scripting.Dictionary")
	set dictParts=ReadTextParts(bomFile,HeaderLine,StartLine,PartNumber,Quantity,IsPOP,Location,NPOP,",")
	
	'write part dictionary to Excel
	call WriteToExcel(dictParts,SmdPN,DipPN,PcbPN)
end sub
 
'sub to compare text bom file with excel bom or two excel boms
'CompareType identify the comparision, 1=CIS_PDM and 2=HDL_PDM and 3=twoPDM
sub Compare(CompareType)
	dim StartLine,PartNumber,Quantity, _
		IsPOP,NPOP,HeaderLine,Location,ExcelHeaderLine, _
		ExcelStartLine,ExcelPartNumber,_
		ParentPN,ExcelQuantity,	_
		ExcelLocation,ExcelLevel				'values read from setup.ini
	dim dictSetup								'dictionary holding setup information
	dim arrCheckSetup							'holds all needed setup strings
	dim FirstFile                               'points to the first bom file
	dim SecondFile								'points to the second bom file
	dim dictFirstParts							'dictionary holds the first part dictionary
	dim dictSecondParts							'dictionary holds the first part dictionary
												'and items are class part objects
	dim strBegin								'identify the beginning of information scope
	dim strEnd									'idenfity the end of information scope
	dim strPrompt								'string shown on MsgBox or InputBox
	
	'veriry preBOM type
	if CompareType=1 then
		strBegin="<CIS_PDM>"
		strEnd="</CIS_PDM>"
		arrCheckSetup=Array("StartLine","PartNumber","Quantity","IsPOP", _
		"Location","NPOP","HeaderLine","ExcelHeaderLine", _
		"ExcelStartLine","ExcelPartNumber","ParentPN","ExcelQuantity",	_
		"ExcelLocation","ExcelLevel")
	elseif CompareType=2 then
		strBegin="<HDL_PDM>"
		strEnd="</HDL_PDM>"
		arrCheckSetup=Array("StartLine","PartNumber","Quantity","IsPOP", _
		"Location","NPOP","HeaderLine","ExcelHeaderLine", _
		"ExcelStartLine","ExcelPartNumber","ParentPN","ExcelQuantity",	_
		"ExcelLocation","ExcelLevel")
	elseif CompareType=3 then
		strBegin="<twoPDM>"
		strEnd="</twoPDM>"
		arrCheckSetup=Array("ExcelHeaderLine", _
		"ExcelStartLine","ExcelPartNumber","ParentPN","ExcelQuantity",	_
		"ExcelLocation","ExcelLevel")
	else
		Err.Raise 104,"BomKit check error.","BomKit doesn't support this kind of comparison: " & CompareType
	end if
	
	'check if all necessary information is aquired from setup.ini
	set dictSetup=ReadSetup(setupfile,strBegin,strEnd)
	for each item in arrCheckSetup
		if not dictSetup.Exists(item) then
			MsgBox "No """ & item & """ value found in " &_
				setupfile & ", please check your file.", _
				vbOkOnly+vbCritical,"Error"
		end if
		Execute(item & "=dictSetup.item(""" & item & """)")
	next
	
	'let user choose 2 bom files
	'if user clicks CANCEL, program exists
	select case CompareType
		case 1
			strPrompt="You are going to choose the BOM file generated by Allegro CIS."
		case 2
			strPrompt="You are going to choose the BOM file generated by Allegro HDL."
		case 3
			strPrompt="You are going to choose the excel file downloaded from PDM."
	end select
	MsgBox strPrompt,vbInformation,"Note"
	FirstFile=BrowseForFile()
	if FirstFile="" then
		WScript.Quit
	end if
	'begin to read first bom
	set dictFirstParts=CreateObject("scripting.Dictionary")
	set dictSecondParts=CreateObject("scripting.Dictionary")
	if CompareType=1 or CompareType=2 then
		set dictFirstParts=ReadTextParts(FirstFile,HeaderLine,StartLine,PartNumber,Quantity,IsPOP,Location,NPOP,",")
	else
		set dictFirstParts=ReadExcelParts(FirstFile,ExcelHeaderLine,ExcelStartLine,ExcelPartNumber, _
			ParentPN,ExcelQuantity,ExcelLocation,ExcelLevel)
	end if
	
	strPrompt="You are going to choose the excel file downloaded from PDM."
	MsgBox strPrompt,vbInformation,"Note"
	SecondFile=BrowseForFile()
	if SecondFile="" then
		WScript.Quit
	end if
	'begin to read second bom
	set dictSecondParts=ReadExcelParts(SecondFile,ExcelHeaderLine,ExcelStartLine,ExcelPartNumber, _
			ParentPN,ExcelQuantity,ExcelLocation,ExcelLevel)
	'begin to compare the two dictionaries
	dim arrCompare
	arrCompare=CompareDicts(dictFirstParts,dictSecondParts)
	
	dim fso,objTextStream,objShell,re
	set re=new RegExp
	re.Pattern="[\n\r]+$"
	set fso=CreateObject("scripting.FileSystemObject")
	set objShell=CreateObject("WScript.Shell")
	set objTextStream=fso.OpenTextFile(objShell.CurrentDirectory & "\compare.txt",2,true)
	objTextStream.WriteLine "Comparision results generated by BomKit"
	objTextStream.WriteLine Date & " " & Time & vbNewLine
	objTextStream.WriteLine "Below items exist only in " & FirstFile & vbNewLine & String(80,"=")
	objTextStream.Write re.Replace(arrCompare(0),"") & vbNewLine & String(80,"=") & vbNewLine & vbNewLine & vbNewLine
	objTextStream.WriteLine "Below items exist only in " & SecondFile & vbNewLine & String(80,"=")
	objTextStream.Write re.Replace(arrCompare(1),"") & vbNewLine & String(80,"=") & vbNewLine & vbNewLine & vbNewLine
	objTextStream.WriteLine "Below are mismatched items" & vbNewLine & String(80,"=")
	objTextStream.Write re.Replace(arrCompare(2),"") & vbNewLine & String(80,"=") & vbNewLine & vbNewLine & vbNewLine
	objTextStream.Close
	objShell.Run(objShell.CurrentDirectory & "\compare.txt")
end sub
 
'function to let user choose a file
function BrowseForFile()
    dim shell : set shell = CreateObject("WScript.Shell")
    dim fso : set fso = CreateObject("Scripting.FileSystemObject")
    dim tempFolder : set tempFolder = fso.GetSpecialFolder(2)
    dim tempName : tempName = fso.GetTempName()
    dim tempFile : set tempFile = tempFolder.CreateTextFile(tempName & ".hta")
    tempFile.Write _
    "<html>" & _
    "<head>" & _
    "<title>Browse</title>" & _
    "</head>" & _
    "<body>" & _
    "<input type='file' id='f' />" & _
    "<script type='text/javascript'>" & _
    "var f = document.getElementById('f');" & _
    "f.click();" & _
    "var shell = new ActiveXObject('WScript.Shell');" & _
    "shell.RegWrite('HKEY_CURRENT_USER\\Volatile Environment\\MsgResp', f.value);" & _
    "window.close();" & _
    "</script>" & _
    "</body>" & _
    "</html>"
    tempFile.Close
    shell.Run tempFolder & "\" & tempName & ".hta", 0, true
    BrowseForFile = shell.RegRead("HKEY_CURRENT_USER\Volatile Environment\MsgResp")
    shell.RegDelete "HKEY_CURRENT_USER\Volatile Environment\MsgResp"
end function
 
'read configuration information from the file specified by strSetupfile
'strBegin and strEnd identify the information scope
'returns a dictionary containing configuration information
function ReadSetup(strSetupfile,strBegin,strEnd)
	dim objTextStream,strLine,IsReading,fso    'For reading setup file
	const ForReading=1			   			   'ForWriting=2, ForAppending=8
	dim re	    							   'regular expression
	dim dictSetup,arrLine					   'dictionary holding setup information
	
	set fso=CreateObject("scripting.FileSystemObject")
	set objTextStream=fso.OpenTextFile(strSetupfile,ForReading,false,-2)
	set dictSetup=CreateObject("scripting.Dictionary")
	IsReading=false
	strLine=Empty
	set re=new RegExp
	re.Pattern="=([^\t]+)\t+'.*$"
	do
		strLine=objTextStream.ReadLine
		if UCase(strLine)=UCase(strEnd) then IsReading=false
		if IsReading then
			strLine=re.Replace(strLine,"=$1")
			arrLine=split(strLine,"=")
			dictSetup.Add arrLine(0),arrLine(1)
		end if
		if UCase(strLine)=UCase(strBegin) then IsReading=true
	loop until strLine=strEnd or objTextStream.AtEndOfStream
	objTextStream.Close
	set ReadSetup=dictSetup
end function
 
'sub to write specific information to setup.ini
'strBegin and strEnd identify the information scope
'strKey and strValue identify where and what
sub WriteSetup(strSetupfile,strBegin,strEnd,strKey,strValue)
	dim objTextStream,strLine,IsReading,arrLine,fso,item
	const ForReading=1,ForWriting=2
	dim re
	
	set fso=CreateObject("scripting.FileSystemObject")
	set objTextStream=fso.OpenTextFile(strSetupFile,ForReading,false,-2)
	strLine=objTextStream.ReadAll
	objTextStream.Close
	arrLine=Split(strLine,vbNewLine)
	set objTextStream=fso.OpenTextFile(strSetupFile,ForWriting)
	IsReading=false
	set re=new RegExp
	re.Pattern="^" & strKey & "=[^\t]*(\t+'.*$)"
	re.IgnoreCase=true
	for each item in arrLine
		strLine=item
		if UCase(item)=UCase(strEnd) then IsReading=false
		if IsReading and UCase(Left(strLine,Len(strKey)))=UCase(strKey) then
			strLine=re.Replace(strLine,strKey & "=" & strValue & "$1")
		end if
		if UCase(item)=UCase(strBegin) then IsReading=true
		objTextStream.WriteLine strLine
	next
	objTextStream.Close
end sub
 
'function to read parts to a dictionary from the file specified by strFile
'HeaderLine identifies the header line number
'StartLine identifies the first line to start to read
'dictColumn contains column numbers of PartNumber,Quantity,IsPOP,Location
'PartNumber,Quantity,IsPOP,Location refers to column names
'strNPOP contains those values make a part NPOP
'chrSepar specifies location separator
function ReadTextParts(strFile,HeaderLine,StartLine,PartNumber,Quantity,IsPOP,Location,strNPOP,chrSepar)
	dim fso,objTextStream,arrLine,strLine,i,dictParts,strPrompt
	set dictParts=CreateObject("scripting.Dictionary")
	set fso=CreateObject("scripting.FileSystemObject")
	set objTextStream=fso.OpenTextFile(strFile,ForReading,false,-2)
	'check bom file format
	'skip useless lines
	for i=2 to HeaderLine
		objTextStream.SkipLine
	next
	strLine=objTextStream.ReadLine
	for each item in Array(PartNumber,Quantity,IsPOP,Location)
		if not IncludesItemOf(strLine,item) then
			MsgBox "BOM file format check failed." & vbNewLine &_
				"Expect """ & Join(Split(item,","),""" or """) & """ on line " & HeaderLine &_
				" of " & strFile & "." & vbNewLine &vbNewLine &_
				"Solutions:" & vbNewLine &_
				"1.Check value of ""HeaderLine"" in setup.ini;" &_
				vbNewLine & "2.Check your bom file " & strFile & ".", _
				vbOkOnly+vbCritical,"Error"
			WScript.Quit
		end if
	next
	
	'get column numbers to a dictionary
	'dictColumn.Item("NPOP") coantains all NPOP column numbers, separated by comma
	dim dictColumn		'dictionary to hold column numbers(0-based), keys are column name strings
	set dictColumn=CreateObject("scripting.Dictionary")
	arrLine=split(strLine,vbTab)
	for i=0 to UBound(arrLine)
		select case arrLine(i)
			case PartNumber
				dictColumn.Add PartNumber,i
			case Quantity
				dictColumn.Add Quantity,i
			case Location
				dictColumn.Add Location,i
			case else
				if IncludesItemOf(arrLine(i),IsPOP) then
					if not dictColumn.Exists("NPOP") then
						dictColumn.Add "NPOP",Cstr(i)
					else
						dictColumn.Item("NPOP")=dictColumn.Item("NPOP") & "," & CStr(i)
					end if
				end if
		end select
	next
	
	'skip useless lines	
	for i=1 to StartLine-HeaderLine-1
		objTextStream.SkipLine
	next
	
	'begin to read
	do until objTextStream.AtEndOfStream
		strLine=objTextStream.ReadLine
		dim currentPN	'current part number
		dim objPart		'a 'part' object to hold each part's information
		arrLine=split(strLine,vbTab)
		if not PartIsNPOP(arrLine,dictColumn.Item("NPOP"),strNPOP) then
		'if this part is not NPOP
			if not arrLine(dictColumn.item(PartNumber))="" then
			'if part number column is not empty
				currentPN=arrLine(dictColumn.item(PartNumber))
				if not dictParts.Exists(currentPN) then
				'if current part number is new
					set objPart=new part
					objPart.PartNumber=arrLine(dictColumn.item(PartNumber))
					objPart.Quantity=arrLine(dictColumn.item(Quantity))
					objPart.Location=arrLine(dictColumn.item(Location))
					dictParts.Add currentPN,objPart
				else
				'if current part number is old
					dictParts.item(currentPN).Quantity= _
						dictParts.item(currentPN).Quantity+ _
						arrLine(dictColumn.item(Quantity))
					dictParts.item(currentPN).Location= _
						dictParts.item(currentPN).Location & "," & _
						arrLine(dictColumn.item(Location))
				end if
			else
				'if part number column is empty
				'append location string
				if not IsEmpty(currentPN) then 
					dictParts.item(currentPN).Location= _
						dictParts.item(currentPN).Location &_
						arrLine(dictColumn.item(Location))
				end if
			end if
		else
		'if part is NPOP, clear currentPN
			currentPN=Empty
		end if
	loop
	
	'delete ZZ and empty part numbers from the dictionary
	'and check repeated locations
	dim strAllLocations                 'string to hold all locations
	for each item in dictParts.Items
		if item.IsBadPN() then
			dictParts.Remove(item.PartNumber)
		else
			strAllLocations=strAllLocations & "," & item.Location
		end if
	next
	dim dictRepeat						'dictionary to hold repeated items and times
	set dictRepeat=CreateObject("scripting.Dictionary")
	set dictRepeat=CheckRepeat(strAllLocations,",")
	if dictRepeat.Count>0 then
		strPrompt=Empty
		strPrompt="BomKit detects repeated locations:" & vbNewLine &_
			vbNewLine & "Location" & vbTab & vbTab & "Repeat Times" & vbNewLine
		for each item in dictRepeat.Keys
			strPrompt=strPrompt &_
				item & vbTab & vbTab & dictRepeat.Item(item) & vbNewLine
		next
		MsgBox strPrompt,vbOkOnly+vbCritical,"Error"
		WScript.Quit
	end if
	
	'check partnumber quantities' correctness
	strPrompt=Empty
	for each item in dictParts.Items
		if not item.CheckQty then
			strPrompt=strPrompt & item.PartNumber & String(2,vbTab) &_
				item.Quantity & vbTab & item.RealQty() & vbNewLine
			item.CorrectQty
		end if
	next
	if not IsEmpty(strPrompt) then
		strPrompt="BomKit detects wrong quantities, modified automatically:" & vbNewLine &_
			vbNewLine & "Part number" & String(2,vbTab) & "Read" & vbTab &_
			"Real" & vbNewLine & strPrompt
		MsgBox strPrompt,vbInformation,"Wrong Quantity"
	end if
	
	objTextStream.Close
	set ReadTextParts=dictParts
end function
 
'function to check repeated items, separated by strSepar, in string specified by strTest
'return a dictionary to hold these items, keys are items, items are repeating times
function CheckRepeat(strTest,strSepar)
	dim strToCheck
	strToCheck=strTest
	if not Left(strToCheck,1)=strSepar then strToCheck=strSepar & strToCheck
	if not Right(strToCheck,1)=strSepar then strToCheck=strToCheck & strSepar
	dim dictRepeat
	set dictRepeat=CreateObject("scripting.Dictionary")
	for each item in split(strToCheck,strSepar)
		if InStr(strToCheck,strSepar & item & strSepar)<> _
		   InStrRev(strToCheck,strSepar & item & strSepar) then
			if dictRepeat.Exists(item) then
				dictRepeat.Item(item)=dictRepeat.Item(item)+1
			else
				dictRepeat.Add item,1
			end if
		end if
	next
	set CheckRepeat=dictRepeat
end function
 
'function to check if strA(Tab as delimiter) includes any items of strB, which are separated by comma
function IncludesItemOf(strA,strB)
	IncludesItemOf=false
	dim item,strLine
	strLine="," & Join(Split(strA,vbTab),",") & ","
	for each item in Split(strB,",")
		if Instr(strLine,"," & item & ",") then 
			IncludesItemOf=true
			exit for
		end if
	next
end function
 
'function to check if part is NPOP
'NPOPColumns contains related NPOP column numbers
'arrLine contains the split columns
function PartIsNPOP(arrLine,NPOPColumns,strNPOP)
	dim item
	PartIsNPOP=false
	for each item in Split(NPOPColumns,",")
		if IncludesItemOf(arrLine(CInt(item)),strNPOP) then
			PartIsNPOP=true
			exit for
		end if
	next
end function
 
'function to write part dictionary to Excel
'SmdPN,DipPN,PcbPN identify the part numbers read rom setup.ini
sub WriteToExcel(dictParts,SmdPN,DipPN,PcbPN)
	dim strInput								'hold the string returned from InputBox
	dim arrInput								'array to hold split input string
	dim arrLine
	'get smd/dip/pcb part numbers from user
	strInput=InputBox("Please enter SMD/DIP/PCB part numbers, separated by semicolons. Like:" &_
		vbNewLine & vbNewLine &_
		"55.5R101.S01G;55.5R101.D01G;48.5R101.0SA", _
		"Enter PNs",SmdPN & ";" & DipPN & ";" & PcbPN)
	if strInput="" then WScript.Quit
	arrInput=Split(strInput,";")
	dim newSmdPN,newDipPN,newPcbPN
	newSmdPN=UCase(Trim(arrInput(0)))
	newDipPN=UCase(Trim(arrInput(1)))
	newPcbPN=UCase(Trim(arrInput(2)))
	if not UCase(SmdPN & DipPN & PcbPN)=(newSmdPN & newDipPN & newPcbPN) then
	'if these part numbers are new, update and write them to setup.ini
		SmdPN=newSmdPN
		DipPN=newDipPN
		PcbPN=newPcbPN
		call WriteSetup(setupfile,strBegin,strEnd,"SmdPN",SmdPN)
		call WriteSetup(setupfile,strBegin,strEnd,"DipPN",DipPN)
		call WriteSetup(setupfile,strBegin,strEnd,"PcbPN",PcbPN)
	end if
	
	'open excel to generate pre-BOM
	dim objExcel,objWorkbook,objWorksheet
	set objExcel=CreateObject("Excel.Application")
	set objWorkbook=objExcel.Workbooks.Add
	set objWorksheet=objWorkbook.Sheets(1)
	objExcel.Visible=True
	'Add header line
	arrLine=Array("Assembly P/N","Assembly Class","Part Number", _
		"Priority","Mount Type","Quantity","Location")
	for i=1 to UBound(arrLine)+1
		objWorksheet.Cells(1,i)=arrLine(i-1)
	next
	'add each part
	dim row,IfExistsRed
	row=2
	IfExistsRed=false
	for each item in dictParts.Items
		objWorksheet.Cells(row,1)=SmdPN
		objWorksheet.Cells(row,2)="EE"
		objWorksheet.Cells(row,3)=item.PartNumber
		objWorksheet.Cells(row,4)=1
		objWorksheet.Cells(row,5)="S"
		objWorksheet.Cells(row,6)=item.Quantity
		objWorksheet.Cells(row,7)=item.Location
		if item.PNmayDip then
		'if part may be Dip, mark with red
			IfExistsRed=true
			objWorksheet.Cells(row,1).Interior.ColorIndex=3
			objWorksheet.Cells(row,5).Interior.ColorIndex=3
		end if
		row=row+1
	next
	'sort by part numbers
	dim objRange,objC1
	const Ascending=1,Descending=2,HeaderLineYes=1
	set objRange=objWorksheet.UsedRange
	set objC1=objExcel.Range("C1")
	objRange.Sort objC1,Ascending,,,,,,HeaderLineYes
	'Insert two lines
	objWorksheet.Rows(2).Insert
	arrLine=Array(SmdPN,"EE",PcbPN, _
		1,"S","1")
	for i=1 to UBound(arrLine)+1
		objWorksheet.Cells(2,i)=arrLine(i-1)
		objWorksheet.Cells(2,i).Font.ColorIndex=5
	next
	objWorksheet.Rows(2).Insert
	arrLine=Array(DipPN,"EE",SmdPN, _
		1,"D","1")
	for i=1 to UBound(arrLine)+1
		objWorksheet.Cells(2,i)=arrLine(i-1)
		objWorksheet.Cells(2,i).Font.ColorIndex=5
	next
	'auto filter
	objRange.EntireColumn.AutoFilter
	'Auto fit
	objRange.EntireColumn.AutoFit()
	if IfExistsRed then MsgBox "pre-BOM has been generated. Please check those values marked by red."
end sub
 
'function to read parts from excel
'strFile points to the Excel file
'HeaderLine and StartLine identify the header line and first useful line
'PartNumber,ParentPN,Quantity,Location,Level are column names
function ReadExcelParts(strFile,HeaderLine,StartLine,PartNumber,ParentPN,Quantity,Location,Level)
	dim objExcel,objWorkbook,objWorksheet
	set objExcel=CreateObject("Excel.Application")
	set objWorkbook=objExcel.Workbooks.Open(strFile)
	set objWorksheet=objWorkbook.Sheets(1)
	dim dictParts
	set dictParts=CreateObject("scripting.Dictionary")
	
	'Get column numbers to a dictionary
	dim dictColumn,i,item,found
	set dictColumn=CreateObject("scripting.Dictionary")
	for each item in Array(PartNumber,ParentPN,Quantity,Location,Level)
		found=false
		for i=1 to objWorkSheet.UsedRange.Columns.Count
			if UCase(objWorksheet.Cells(HeaderLine,i))=UCase(item) then
				found=true
				dictColumn.Add item,i
				exit for
			end if
		next
		if found=false then
			MsgBox "Excel BOM format check failed." & vbNewLine &_
				"Expect """ & item & """ on line " & HeaderLine &_
				" of " & strFile & "." & vbNewLine &vbNewLine &_
				"Solutions:" & vbNewLine &_
				"1.Check value of ""HeaderLine"" in setup.ini;" &_
				vbNewLine & "2.Check your Excel file " & strFile & ".", _
				vbOkOnly+vbCritical,"Error"
			WScript.Quit
		end if
	next
	
	'begin to read parts
	dim objPart,PreviousPN        'PreviousPN refers to the last main source part number
	for i=StartLine to objWorkSheet.UsedRange.Rows.Count
		if Instr(UCase("12A"),UCase(objWorksheet.Cells(i,dictColumn.Item(Level)))) then
		'if the row is useful
			set objPart=new part
			objPart.PartNumber=objWorksheet.Cells(i,dictColumn.item(PartNumber))
			objPart.Quantity=objWorksheet.Cells(i,dictColumn.item(Quantity))
			objPart.Location=objWorksheet.Cells(i,dictColumn.item(Location))
			objPart.strSepar=" "
			objPart.ParentPN=objWorksheet.Cells(i,dictColumn.item(ParentPN))
			objPart.boolIsSecond=(UCase(objWorksheet.Cells(i,dictColumn.item(Level)))="A")
			if objPart.boolIsSecond then
			'if this part is a second source
				objPart.MainSource=PreviousPN
				dictParts.Add objPart.PartNumber & "-" & objPart.MainSource,objPart
			else
			'if this part is a main source
				dictParts.Add objPart.PartNumber,objPart
				PreviousPN=objPart.PartNumber
			end if
		end if
	next
	objExcel.Quit
	Set ReadExcelParts=dictParts
end function
 
'function to compare two part dictionary specified by dictFirstParts,dictSecondParts
'returns an array, which:
'array(0):a string including part numbers only in the first dictionary
'array(1):a string including part numbers only in the second dictionary
'array(2):a string including mismatched locations
function CompareDicts(dictFirstParts,dictSecondParts)
	dim arrCompare,dictCompared,item
	arrCompare=Array("","","")
	'based on dictFirstParts to compare dictSecondParts
	dim arrLack
	for each item in dictFirstParts.Keys
		if dictSecondParts.Exists(item) then
		'if dictSecondParts contains the part number with the same IsSecond property
			if not dictFirstParts.Item(item).boolIsSecond then
			'if this part is not second source, for there is no need to compare 2nd source
				arrLack=CompareLocation( _
					Split(dictFirstParts.Item(item).Location, _
					dictFirstParts.Item(item).strSepar), _
					Split(dictSecondParts.Item(item).Location, _
					dictSecondParts.Item(item).strSepar))
				if not Join(arrLack)=" " then
				'if mismatch is found
					arrCompare(2)=arrCompare(2) & "Part Number:" & dictFirstParts.Item(item).PartNumber & vbNewLine &_
					 "1st  Quantity:" & dictFirstParts.Item(item).Quantity & vbNewLine &_
					 "1st  Location:" & dictFirstParts.Item(item).Location & vbNewLine &_
					 "2nd  Quantity:" & dictSecondParts.Item(item).Quantity & vbNewLine &_
					 "2nd  Location:" & dictSecondParts.Item(item).Location & vbNewLine &_
					 "Is 2nd Source:" & dictFirstParts.Item(item).boolIsSecond & vbNewLine
					 if not dictFirstParts.Item(item).ParentPN="Unknown" then
					 	arrCompare(2)=arrCompare(2) & "Parent PN:" & dictFirstParts.Item(item).ParentPN & vbNewLine
					 elseif not dictSecondParts.Item(item).ParentPN="Unknown" then
					 	arrCompare(2)=arrCompare(2) & "Parent PN:" & dictSecondParts.Item(item).ParentPN & vbNewLine
					 else
					 	arrCompare(2)=arrCompare(2) & "Parent PN:" & dictFirstParts.Item(item).ParentPN & vbNewLine
					 end if
					 	
					 if not arrLack(0)="" then
					 	arrCompare(2)=arrCompare(2) & "Only in 1st:" & arrLack(0) & vbNewLine
					 end if
					 if not arrLack(1)="" then
					 	arrCompare(2)=arrCompare(2) & "Only in 2nd:" & arrLack(1) & vbNewLine
					 end if
					 arrCompare(2)=arrCompare(2) & vbNewLine
				end if
			end if
		else
		'if dictSecondParts doesn't contain part number with the same IsSecond property
			arrCompare(0)=arrCompare(0) & "Part Number:" & dictFirstParts.Item(item).PartNumber & vbNewLine &_
					 "Quantity:" & dictFirstParts.Item(item).Quantity & vbNewLine &_
					 "Location:" & dictFirstParts.Item(item).Location & vbNewLine &_
					 "Parent PN:" & dictFirstParts.Item(item).ParentPN & vbNewLine &_
					 "Is 2nd Source:" & dictFirstParts.Item(item).boolIsSecond & vbNewLine
			if dictFirstParts.Item(item).boolIsSecond then
				arrCompare(0)=arrCompare(0) & "Main Source:" &_
				 dictFirstParts.Item(item).MainSource & vbNewLine 
			end if
			arrCompare(0)=arrCompare(0) & vbNewLine
		end if
	next
	
	'based on dictFirstParts to compare dictSecondParts
	for each item in dictSecondParts.Keys
		if not dictFirstParts.Exists(item) then
		'if dictFirstParts doesn't contain part number with the same IsSecond property
			arrCompare(1)=arrCompare(1) & "Part Number:" & dictSecondParts.Item(item).PartNumber & vbNewLine &_
					 "Quantity:" & dictSecondParts.Item(item).Quantity & vbNewLine &_
					 "Location:" & dictSecondParts.Item(item).Location & vbNewLine &_
					 "Parent PN:" & dictSecondParts.Item(item).ParentPN & vbNewLine &_
					 "Is 2nd Source:" & dictSecondParts.Item(item).boolIsSecond & vbNewLine
			if dictSecondParts.Item(item).boolIsSecond then
				arrCompare(1)=arrCompare(1) & "Main Source:" &_
				 dictSecondParts.Item(item).MainSource & vbNewLine
			end if
			arrCompare(1)=arrCompare(1) & vbNewLine
		end if
	next
	CompareDicts=arrCompare
end function
 
'function to check the difference between two arrays
'return an array to hold the results, which:
'array(0):only in the first array
'array(1):only in the second array
function CompareLocation(arrayA,arrayB)
	dim arrLack,strA,strB,item
	arrLack=Array("","")
	strA="," & Join(arrayA,",") & ","
	strB="," & Join(arrayB,",") & ","
	for each item in arrayA
		if Instr(strB,item)=0 then arrLack(0)=arrLack(0) & "," & item
	next
	for each item in arrayB
		if Instr(strA,item)=0 then arrLack(1)=arrLack(1) & "," & item
	next
	arrLack(0)=Mid(arrLack(0),2)
	arrLack(1)=Mid(arrLack(1),2)
	CompareLocation=arrLack
end function
 
'****************class area***************
class part
	private PN,Qty,Loc    		'PartNumber,Quantity,IsPOP,Location
	private boolNormalPN	  	'If Part Number is normal
	public strSepar				'separator to separate locations
	public boolIsSecond			'if this pard is 2nd source
	public ParentPN				'parent part number
	public MainSource			'Main source when it's 2nd source
	
	'Part Number property
	property let PartNumber(strPartNumber)
		if strPartNumber="" then
			Err.Raise 101,"BomKit check error","Detected empty part number " & strPartNumber
		end if
		PN=strPartNumber
		call CheckPN()
	end property
	property get PartNumber()
		PartNumber=PN
	end property
	
	'Quantity property
	property let Quantity(intQuantity)
		Qty=CInt(intQuantity)
		if Qty<0 then
			Err.Raise 102,"BomKit check error","Negative Quantity " & Qty
		end if
	end property
	property get Quantity()
		Quantity=Qty
	end property
	
	'Location property
	property let Location(strLocation)
		Loc=strLocation
	end property
	property get Location()
		Location=Loc
	end property
	
	'sub to check if part number is 253/354 type
	private sub CheckPN()
		dim re
		set re=new RegExp
		re.Pattern="^(\w{2}\.\w{5}\.\w{3}|\w{3}\.\w{5}\.\w{4})$"
		if re.Test(PN) then
			boolNormalPN=true
		else
			boolNormalPN=false
		end if
	end sub
	
	'class initialize event
	private sub Class_Initialize
		boolNormalPN=false
		PN=""
		Qty=0
		Loc=""
		strSepar=","
		boolIsSecond=false
		ParentPN="Unknown"
		MainSource="N/A"
	end sub
	
	'function to check if Quantity is equal to the real length
	public function CheckQty()
		CheckQty=(Qty=UBound(Split(Loc,strSepar))+1)
	end function
	
	'sub to correct wrong quantity
	public sub CorrectQty()
		Qty=RealQty()
	end sub
	
	'function to return real quantity
	public function RealQty()
		RealQty=UBound(Split(Loc,strSepar))+1
	end function
	
	'function to show whether pn is normal
	public function IsNormalPN()
		IsNormalPN=boolNormalPN
	end function
	
	'function to check if part number is ZZ
	public function IsBadPN()
		IsBadPN=false
		if Left(PN,2)="ZZ" then IsBadPN=true
		dim re
		set re=new RegExp
		re.Pattern="^\s*$"
		if re.Test(PN) then
			IsBadPN=true
		end if
	end function
	
	'function to check if part number may be dip
	public function PNmayDip()
		dim arrPN
		if boolNormalPN then
			arrPN=Split(PN,".")
			PNmayDip=(20<=CInt(arrPN(0)) and CInt(arrPN(0))<=60)
		else
			PNmayDip=true
		end if
	end function
end classCOPY

canyuexiaolang

自从转了linux之后，才觉得像是vbs和批处理的缺点是不能跨平台，就我个人而言，推荐python。
python太强大了..嘛..当然在windows下批处理和python各有各的好处。

mayz1994@qq.com

干嘛用的这个？