学习vbs后的练习代码

weichenxiehou · 发表于 2013-8-4 07:31:24

前段时间学习了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 class

复制代码

canyuexiaolang · 发表于 2013-8-4 09:51:38

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

mayz1994@qq.com · 发表于 2014-1-25 13:24:00

干嘛用的这个？

		自动登录	找回密码
密码			注册

[新手上路]批处理新手入门导读	[视频教程]批处理基础视频教程	[视频教程]VBS基础视频教程	[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动	[批处理精品]CMD命令50条不能说的秘密	[在线下载]第三方命令行工具	[在线帮助]VBScript / JScript 在线参考

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

浏览过的版块