![Board logo](images/default/logo.gif)
标题: [原创] 学习vbs后的练习代码 [打印本页]
作者: weichenxiehou 时间: 2013-8-4 07:31 标题: 学习vbs后的练习代码
前段时间学习了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
自从转了linux之后,才觉得像是vbs和批处理的缺点是不能跨平台,就我个人而言,推荐python。
python太强大了..嘛..当然在windows下批处理和python各有各的好处。
作者: mayz1994@qq.com 时间: 2014-1-25 13:24
干嘛用的这个?
欢迎光临 批处理之家 (http://www.bathome.net/) |
Powered by Discuz! 7.2 |