' NX 5.0.4.1 ' Journal created by Ahrens.Ma on Wed Nov 12 10:47:13 2008 Mitteleuropäische Zeit ' Option Strict Off Imports System Imports System.Net 'Imports System.Collections Imports NXOpen Imports NXOpen.UF Imports NXOpen.UI Imports NXOpen.Assemblies 'Imports NXOpen.Sessio ' needed to get the process class Imports System.Diagnostics ' needed for the ArrayList Imports System.Collections ' Object Manager Imports NXOpen.Utilities 'imports Microsoft.Office.Interop.Excel Module NXJournal ' ---------------------------------------------- ' Declare module wide variables ' ---------------------------------------------- ' ---- General environment variables ----- Public env_UGS_SHR_DIR As String ' ---- variable for error codes of internal WS sub functions ----- Public errcode As Integer ' ---- variable for error codes of internal WS sub functions ----- Public reportlevel As Integer ' ---- variable to manage todo list ----- Public actionmode as integer Public Messages As Boolean Public ByPassSAP as Boolean ' ---- define major NX objects ----- Public theSession As Session Public ufs As UFSession Public workPart As Part ' ---- define other NX objects ----- Public CompAssy As ComponentAssembly ' ---- define other NX objects ----- Public CompParent As New ArrayList() Public CompIndiv As New ArrayList() Public CompLevel As New ArrayList() ' ---- define NX attribute arrays ----- Public CompAttrib(23) As string Public CompAttribTitle(23) As string Public CompAttribTitle2(23) As string Public CompAttribValTextSize(23) As string Public CompAttribColWidth(23) As string Public CompAttribColColor(23) As string Public CompAttribDataValidation(23) As string Public CompAttribComment(23) As string ' ---- define NX selection objects ----- Public CompGrpCol as ComponentGroupCollection Public CompGrp as ComponentGroup Public CompMasterLoaded as boolean ' ---- define NX selection parameters ----- Public CompMark as boolean Public CompMarkColor as integer Public CompMarkTransp as boolean Public CompMarkTranspValue as integer Public CompSelMode as integer Public CompSelModeSub as integer ' ---- define major EXCEL objects ----- Public oExcel As Object 'Public oExcel as Microsoft.Office.Interop.Excel.Application Public oBook As Object Public oSheet As Object Public oSheetMeta As Object Public oSheetMARC As Object Public oSheetMBEW As Object Public oSheetMARA As Object Public oSheetMAKT As Object Public oRange As Object Public oCell as Object Public CellCol() as string Public CellRow() as string Public sheetexists as boolean ' ---- define major EXCEL variables ----- Public iCellSelQty as long Public iCellSelIDX as long ' ---- define additional EXCEL formular ----- Public XLSform(6) as string Public XLSformTitle(6) as string Public XLSformType(6) as string Public XLSformSheet(6) as string Public XLSformRangeLeft(6) as string Public XLSformColOffset(6) as integer Public XLSformExt(6) as boolean Public XLSformExtended as boolean Public RefCol as integer ' ---- define SAP objects ----- Public SapConnection As Object Public SapLogonCtrl as Object Public SAPFunctionCtrl As Object Public SapFunction as Object Public SAPException as string ' ---- define SAP report objects ----- Public ListOfIDS As New ArrayList() Public MATKeys As New ArrayList() Public MARCSheetName as string Public MARCFields(4) as String Public MARCTitles(4) as String Public MARCFormats(4) as String Public MARCResult(,) as String Public MBEWSheetName as string Public MBEWFields(5) as String Public MBEWTitles(5) as String Public MBEWFormats(5) as String Public MBEWResult(,) as String Public MARASheetName as string Public MARAFields(1) as String Public MARATitles(1) as String Public MARAFormats(1) as String Public MARAResult(,) as String Public MAKTSheetName as string Public MAKTFields(2) as String Public MAKTTitles(2) as String Public MAKTFormats(2) as String Public MAKTResult(,) as String Public SAPPlant(0) as String ' ---- define SAP report parameter ----- Public SAPReportAmount as integer Public SAPReportMassKeys As New ArrayList() Public SAPReportNarrowKeys As New ArrayList() Public SAPReportResult As New ArrayList() Public BOMTraverseLimit as integer Public AttribMode as Boolean Public AttribModeDirect as Boolean Public MainRowStart as integer ' ---- define webdav ----- Public webdavhome as string Public GroupCols(2,1) as integer Sub Main ' ---------------------------------------------- ' assign major objects ' ---------------------------------------------- theSession = Session.GetSession() ufs = UFSession.GetUFSession() workPart = theSession.Parts.Display 'workPart = theSession.Parts.Work ' ---------------------------------------------- ' Open report window if required ' ---------------------------------------------- 'If reportlevel > 0 Then theSession.ListingWindow.Open() theSession.ListingWindow.Open() ' ---------------------------------------------- ' Call sub function to setup initial values ' ---------------------------------------------- ufs.Ui.SetStatus("Setup environment") errcode = setup() If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function errcode: setup() = " & errcode) ' ---------------------------------------------- ' connect to an open EXCEL session ' ---------------------------------------------- ufs.Ui.SetStatus("Check for running EXCEL application") errcode = ChkEXCELapp() If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function errcode: GetEXCELobj() = " & errcode) If errcode <> 0 then MsgBox("Unable to proceed! No Microsoft EXCEL session open!", MsgBoxStyle.Exclamation) GoTo finalized end if ' ---------------------------------------------- ' connect to an open EXCEL session ' ---------------------------------------------- ufs.Ui.SetStatus("Get EXCEL application") oExcel = GetObject(,"Excel.Application") ' ---------------------------------------------- ' change EXCEL session culture ' ---------------------------------------------- System.Threading.Thread.CurrentThread.CurrentUICulture = New System.Globalization.CultureInfo("en-US") 'oExcel.ChangeCulture("en-US") ' ---------------------------------------------- ' make EXCEL visible ' ---------------------------------------------- ufs.Ui.SetStatus("Make EXCEL application visible") oExcel.Visible = True ' ---------------------------------------------- ' get the active EXCEL workbook ' ---------------------------------------------- ufs.Ui.SetStatus("get the active EXCEL workbook") errcode = GetEXCELawb(oExcel, oBook) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function errcode: GetEXCELawb() = " & errcode) 'oBook = oExcel.Workbooks.Add 'oBook = oExcel.ActiveWorkbook If errcode <> 0 then MsgBox("Unable to proceed! No EXCEL Workbook active!", MsgBoxStyle.Exclamation) GoTo finalized end if If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - ActiveWorkbook.Name = " & oBook.Name) ' ---------------------------------------------- ' get the active worksheet ' ---------------------------------------------- ufs.Ui.SetStatus("get the active EXCEL sheet") 'oSheet = oBook.Worksheets(1) oSheet = oBook.ActiveSheet If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - ActiveSheet.Name = " & oSheet.Name) ' ---------------------------------------------- ' get the EXCEL ActiveRange ' ---------------------------------------------- ufs.Ui.SetStatus("get the active EXCEL Range") oRange = oExcel.Selection iCellSelQty = oRange.Cells.Count If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Cells Selected = " & iCellSelQty) Redim CellCol(iCellSelQty) Redim CellRow(iCellSelQty) ' ---------------------------------------------- ' cycle cells of EXCEL ActiveRange ' ---------------------------------------------- 'Dim xlReferenceStyle1 As XlReferenceStyle = XlReferenceStyle.xlR1C1 iCellSelIDX = 0 for each oCell in oRange iCellSelIDX = iCellSelIDX + 1 'CellAddress(iCellSelIDX) = oCell.Address(ReferenceStyle:=2) 'CellAddress(iCellSelIDX) = oCell.Column CellCol(iCellSelIDX) = oCell.Column CellRow(iCellSelIDX) = oCell.Row If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Cell(" & iCellSelIDX & ") = Column:" & CellCol(iCellSelIDX) & " Row:" & CellRow(iCellSelIDX) & " Value:" & oCell.Value) next oCell ' ---------------------------------------------- ' indentify action mode ' ---------------------------------------------- iCellSelIDX = 0 for each oCell in oRange if oCell.Value = "" then iCellSelIDX = iCellSelIDX + 1 next oCell actionmode = iCellSelIDX If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Action Mode = " & actionmode) ' ---------------------------------------------- ' indentify ByPassSAP mode if overwritten ' ---------------------------------------------- for each oCell in oRange if oCell.Value = "bypasssap" then ByPassSAP = true If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - ByPassSAP = " & ByPassSAP) end if next oCell ' ---------------------------------------------- ' if required connect to SAP first ' ---------------------------------------------- if ByPassSAP = False then ' ---------------------------------------------- ' if action mode > 2 connect to excel ' ---------------------------------------------- if actionmode > 2 then ' ---------------------------------------------- ' Open SAP Connection ' ---------------------------------------------- ufs.Ui.SetStatus("Connect to SAP") errcode = SAPConnect("XXX", "XXX", "", "", "EN") If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function errcode: SAPConnect() = " & errcode) end if end if ' ---------------------------------------------- ' indentify SAP plant if overwritten ' ---------------------------------------------- dim plantstr as string dim plantval as string for each oCell in oRange plantstr = mid(oCell.Value, 1,6) if plantstr = "plant=" then plantval = mid(oCell.Value, 7,len(oCell.Value)) SAPPlant(0)=plantval end if next oCell If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - SAP plant = " & SAPPlant(0)) ' ---------------------------------------------- ' indentify special formulars ' ---------------------------------------------- for each oCell in oRange if oCell.Value = "extended" then XLSformExtended = true end if next oCell If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Extended = " & XLSformExtended) ' ---------------------------------------------- ' indentify webdav root if not main ' ---------------------------------------------- for each oCell in oRange if oCell.Value = "" then webdavhome = "" end if next oCell If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - webdavhome = " & webdavhome) ' ---------------------------------------------- ' indentify Traversal BOM Level limit if overritten ' ---------------------------------------------- Dim MaxLevelStr as string Dim MaxLevelNumStr as string for each oCell in oRange MaxLevelStr = mid(oCell.Value, 1,7) if MaxLevelStr = "maxlev=" then MaxLevelNumStr = mid(oCell.Value, 8,len(oCell.Value)) BOMTraverseLimit=CInt(MaxLevelNumStr) end if next oCell If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Max Traversal level = " & BOMTraverseLimit) ' ---------------------------------------------- ' Identify Attribute overriding mode and source COLUMN ' ---------------------------------------------- Dim AttribModeStr as string Dim AttribColStr as string Dim AttribPropStr as string Dim AttribRootCol as long Dim AttribRootRow as long for each oCell in oRange AttribModeStr = mid(oCell.Value, 1,5) if AttribModeStr = "sync=" then AttribColStr = mid(oCell.Value, 6,len(oCell.Value)) AttribPropStr = mid(oCell.Value, 6,len(oCell.Value)) AttribMode= True AttribModeDirect = False AttribRootCol = oCell.Column AttribRootRow = oCell.Row end if next oCell If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Attrib. Sync. Prop. = " & AttribPropStr) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Attrib. Sync. Col. = " & AttribRootCol) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Attrib. Sync. Row. = " & AttribRootRow) ' ---------------------------------------------- ' Identify Attribute overriding mode and source Cell Value ' ---------------------------------------------- Dim AttribMode2Str as string Dim AttribStr as string Dim AttribVal as string iCellSelIDX = 0 for each oCell in oRange iCellSelIDX = iCellSelIDX + 1 AttribMode2Str = mid(oCell.Value, 1,7) if AttribMode2Str = "attrib=" then AttribStr = mid(oCell.Value, 8,len(oCell.Value)) AttribMode= True AttribModeDirect = True end if if iCellSelIDX = iCellSelQty then AttribVal = oCell.Value end if next oCell If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Attribute to Change = " & AttribStr) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Attribute Value = " & AttribVal) ' ---------------------------------------------- ' Identify component selection mode ' ---------------------------------------------- ' If length differ from 13 characters if len(oRange(1).Value) <> 13 then CompSelMode = 2 ' If first cell of range contains HANDLE use the HANDLE function if mid(oRange(1).Value, 1, 9) = "HANDLE O-" then CompSelMode = 0 ' If first character is an I then it has to be the component ItemID function if mid(oRange(1).Value, 1, 1) = "I" then CompSelMode = 3 'CompSelMode = 0 ' 0 = Handle ' 1 = SAP_ID ' 2 = Component Name ' 3 = ItemID 'CompSelModeSub = 0 ' 0 = SAP MM_MATERIAL_ID ' 1 = SAP DM_DOCUMENT_ID If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Selection Source = " & oRange(1).Value) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Selection Mode = " & CompSelMode) ' ---------------------------------------------- ' Identify component sub selection mode for SAP ID's ' ---------------------------------------------- for each oCell in oRange if oCell.Value = "select=SAP_DM_DOCUMENT_ID" then CompSelModeSub = 1 if oCell.Value = "select=SAP_MM_MATERIAL_ID" then CompSelModeSub = 0 next oCell If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Sub Selection Mode = " &CompSelModeSub) ' ---------------------------------------------- ' if action mode =2 populate display templates ' ---------------------------------------------- Dim fsize as integer Dim frot as integer fsize = 2 frot = 0 if actionmode > 1 then oSheet.Cells(1,1).Value = "color=red" oSheet.Cells(1,1).Orientation = frot oSheet.Cells(1,1).Font.Size = fsize oSheet.Cells(1,1).Font.Color = RGB(255,0,0) oSheet.Cells(1,1).Interior.Color = RGB(255,0,0) oSheet.Cells(1,2).Value = "color=blue" oSheet.Cells(1,2).Orientation = frot oSheet.Cells(1,2).Font.Size = fsize oSheet.Cells(1,2).Font.Color = RGB(0,0,255) oSheet.Cells(1,2).Interior.Color = RGB(0,0,255) oSheet.Cells(1,3).Value = "color=yellow" oSheet.Cells(1,3).Orientation = frot oSheet.Cells(1,3).Font.Size = fsize oSheet.Cells(1,3).Font.Color = RGB(255,255,0) oSheet.Cells(1,3).Interior.Color = RGB(255,255,0) oSheet.Cells(1,4).Value = "color=green" oSheet.Cells(1,4).Orientation = frot oSheet.Cells(1,4).Font.Size = fsize oSheet.Cells(1,4).Font.Color = RGB(0,255,0) oSheet.Cells(1,4).Interior.Color = RGB(0,255,0) oSheet.Cells(1,5).Value = "transparency=0" oSheet.Cells(1,5).Orientation = frot oSheet.Cells(1,5).Font.Size = fsize oSheet.Cells(1,5).Font.Color = RGB(51,51,51) oSheet.Cells(1,5).Interior.Color = RGB(51,51,51) oSheet.Cells(1,6).Value = "transparency=50" oSheet.Cells(1,6).Orientation = frot oSheet.Cells(1,6).Font.Size = fsize oSheet.Cells(1,6).Font.Color = RGB(102,102,102) oSheet.Cells(1,6).Interior.Color = RGB(102,102,102) oSheet.Cells(1,7).Value = "transparency=75" oSheet.Cells(1,7).Orientation = frot oSheet.Cells(1,7).Font.Size = fsize oSheet.Cells(1,7).Font.Color = RGB(153,153,153) oSheet.Cells(1,7).Interior.Color = RGB(153,153,153) oSheet.Cells(1,8).Value = "transparency=90" oSheet.Cells(1,8).Orientation = frot oSheet.Cells(1,8).Font.Size = fsize oSheet.Cells(1,8).Font.Color = RGB(204,204,204) oSheet.Cells(1,8).Interior.Color = RGB(204,204,204) oSheet.Cells(1,10).Value = "select=SAP_MM_MATERIAL_ID" oSheet.Cells(1,10).Orientation = frot oSheet.Cells(1,10).Font.Size = fsize oSheet.Cells(1,10).Font.Color = RGB(51,0,255) oSheet.Cells(1,10).Interior.Color = RGB(51,0,255) oSheet.Cells(1,11).Value = "select=SAP_DM_DOCUMENT_ID" oSheet.Cells(1,11).Orientation = frot oSheet.Cells(1,11).Font.Size = fsize oSheet.Cells(1,11).Font.Color = RGB(204,255,153) oSheet.Cells(1,11).Interior.Color = RGB(204,255,153) end if ' ---------------------------------------------- ' if action mode = 0 identify target color ' ---------------------------------------------- dim colmodestr as string dim colorstr as string dim transpmodestr as string dim transpstr as string if actionmode = 0 then for each oCell in oRange ' color colmodestr = mid(oCell.Value, 1,6) if colmodestr = "color=" then ' ---------------------------------------------- ' set color mark mode ' ---------------------------------------------- CompMark = True ' ---------------------------------------------- ' if Component Mark mode on identify target color ' ---------------------------------------------- colorstr = mid(oCell.Value, 7,len(oCell.Value)) ' ---------------------------------------------- ' if the colorstring is numeric ' ---------------------------------------------- If isNumeric(colorstr) = true then CompMarkColor = colorstr else ' ---------------------------------------------- ' if the colorstring is not numeric ' ---------------------------------------------- if colorstr ="red" then CompMarkColor = 186 if colorstr ="blue" then CompMarkColor = 211 if colorstr ="yellow" then CompMarkColor = 6 if colorstr ="green" then CompMarkColor = 36 if colorstr ="magenta" then CompMarkColor = 181 if colorstr ="cyan" then CompMarkColor = 181 if colorstr ="background" then CompMarkColor = 0 end if end if ' Transparency transpmodestr = mid(oCell.Value, 1,13) if transpmodestr = "transparency=" then ' ---------------------------------------------- ' set transparency mark mode ' ---------------------------------------------- CompMarkTransp = True ' ---------------------------------------------- ' if Component Mark mode on identify target color ' ---------------------------------------------- transpstr = mid(oCell.Value, 14,len(oCell.Value)) ' ---------------------------------------------- ' if the colorstring is numeric ' ---------------------------------------------- If isNumeric(transpstr) = true then CompMarkTranspValue = transpstr end if end if next oCell end if If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Color Mode string = " & colmodestr) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Component Mark = " & CompMark) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : EXCEL - C. Mark Color String = " & colorstr) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Component Mark Color = " & CompMarkColor) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Trans Mode string = " & transpmodestr) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Trans Mark = " & CompMarkTransp) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Trans Value String = " & transpstr) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - Transparency Value = " & CompMarkTranspValue) ' ---------------------------------------------- ' if action mode =2 set active cell ' ---------------------------------------------- if actionmode > 1 then ' ---------------------------------------------- ' rename current sheet and select initial cell ' ---------------------------------------------- oSheet.Cells(2,1).Select oSheet.Name = "NX CAD BOM" ' ---------------------------------------------- ' create META data sheet ' ---------------------------------------------- ufs.Ui.SetStatus("create EXCEL sheet for META data") Dim MetaSheetName as string MetaSheetName = "Report Meta" Dim sheetexists as boolean errcode = FindEXCELSheet(oBook, oSheetMeta, MetaSheetName , sheetexists) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: FindEXCELSheet() = " & errcode) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : FindEXCELSheet() = Sheet exists => " & sheetexists) if sheetexists = false then oBook.Worksheets.Add (After:=oBook.Worksheets(oBook.Worksheets.Count)).Name = MetaSheetName oSheetMeta = oBook.Worksheets(MetaSheetName) ' Select back the original sheet oSheet.Select end if ' ---------------------------------------------- ' Populate META data sheet ' ---------------------------------------------- oSheetMeta.Cells(1,1).NumberFormat = "@" oSheetMeta.Cells(1,1).Value = "USER" oSheetMeta.Cells(1,2).NumberFormat = "@" oSheetMeta.Cells(1,2).Value = Environment.GetEnvironmentVariable("USERNAME") oSheetMeta.Cells(2,1).NumberFormat = "@" oSheetMeta.Cells(2,1).Value = "DATE" oSheetMeta.Cells(2,2).NumberFormat = "@" oSheetMeta.Cells(2,2).Value = DateValue(Now) oSheetMeta.Cells(3,1).NumberFormat = "@" oSheetMeta.Cells(3,1).Value = "TIME" oSheetMeta.Cells(3,2).NumberFormat = "@" oSheetMeta.Cells(3,2).Value = TimeValue(Now) end if ' ------------------------------------------------ ' set root assembly ' ------------------------------------------------ CompAssy = workPart.ComponentAssembly ' ---------------------------------------------- ' collect all components in a single collection ' ---------------------------------------------- dim parenthandle as string CompIndiv.add(CompAssy.RootComponent) CompLevel.add("0") errcode = GetCompAttrib(CompAssy.RootComponent, "handle", parenthandle) CompParent.add(GetCompAttrib(CompAssy.RootComponent, "handle", parenthandle)) errcode = CollectAssemblyTree(CompAssy.RootComponent, 1, "", parenthandle) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: CollectAssemblyTree() = " & errcode) ' ---------------------------------------------- ' report the arraylist parameters ' ---------------------------------------------- if reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAssemblyTree() = CompIndiv.Count = " & CompIndiv.Count) if reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAssemblyTree() = CompIndiv.Capacity = " & CompIndiv.Capacity) if reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAssemblyTree() = CompLevel.Count = " & CompLevel.Count) if reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAssemblyTree() = CompLevel.Capacity = " & CompLevel.Capacity) ' ---------------------------------------------- ' dim a attribute array ' ---------------------------------------------- Dim ColQty as integer ColQty = ubound(CompAttrib) Dim BOMattrib(CompIndiv.Count, ColQty) as string ' ---------------------------------------------- ' set attribute array header ' ---------------------------------------------- 'BOMattrib(0, 0) = CompAttrib(0) 'BOMattrib(0, 1) = CompAttrib(1) For ColIDX as integer = 2 to ubound(CompAttrib) BOMattrib(0, ColIDX) = CompAttrib(ColIDX) Next ColIDX ' ---------------------------------------------- ' read additional attributes into array ' ---------------------------------------------- ufs.Ui.SetStatus("get attributes per component") Dim obj as component DIM ComCountID as long Dim valuetmp as string ComCountID = 0 dim BOMLev as String For Each obj In CompIndiv ' ---------------------------------------------- ' setup the object index ' ---------------------------------------------- ComCountID = ComCountID + 1 ' ---------------------------------------------- ' setup the status line ' ---------------------------------------------- ufs.Ui.SetStatus("get attributes for Component: " & ComCountID & "/" & CompIndiv.Count & " " & obj.name) ' ---------------------------------------------- ' store the BOM level ' ---------------------------------------------- If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: CompLevel.Item(ComCountID )= " & CompLevel.Item(ComCountID -1 )) BOMLev = CompLevel.Item(ComCountID - 1 ) BOMattrib(ComCountID,0) = BOMLev ' ---------------------------------------------- ' store the BOM level nested ' ---------------------------------------------- Dim levitenger as integer levitenger = BOMLev Dim BOMLev2 as string BOMLev2 = "" for levidx as integer = 1 to levitenger BOMLev2 = BOMLev2 & "__" next levidx BOMLev2 = BOMLev2 & BOMLev BOMattrib(ComCountID,1) = BOMLev2 ' ---------------------------------------------- ' transfer additional values ' ---------------------------------------------- for colidx as integer = 3 to ubound(CompAttrib) ' ---------------------------------------------- ' get attributes and values ' the first and the second column are reserved for LEVEL values ' ---------------------------------------------- valuetmp = "" errcode = GetCompAttrib(obj, CompAttrib(colidx), valuetmp) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: GetCompAttrib() = " & errcode) BOMattrib(ComCountID, colidx) = valuetmp next colidx ' ---------------------------------------------- ' store the parent handler ' ---------------------------------------------- BOMattrib(ComCountID, 2) = CompParent(ComCountID-1) Next obj ' ---------------------------------------------- ' print additional attributes array ' ---------------------------------------------- Dim BOMAttribLine as string For BOMattribIDX as long = 0 to ubound(BOMattrib,1) BOMAttribLine = "" for BOMattribColIDX as long = 0 to ubound(BOMattrib,2) BOMAttribLine = BOMAttribLine & BOMattrib(BOMattribIDX,BOMattribColIDX) & ";" next BOMattribColIDX If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : GetCompAttrib() - BOMAttrib = " & BOMAttribLine) Next BOMattribIDX ' ---------------------------------------------- ' Populate EXCEL if action Mode > 1 ' ---------------------------------------------- if actionmode > 1 then ' ---------------------------------------------- ' Populate EXCEL Header above Main + 2 ' ---------------------------------------------- ufs.Ui.SetStatus("Action Mode = Writing Top Header Data") for BOMattribColIDX as long = 0 to ubound(CompAttribTitle2) if CompAttribTitle2(BOMattribColIDX) <> "" then ' ---------------------------------------------- ' select initial cells to get offset from ' ---------------------------------------------- oSheet.Cells(MainRowStart-3,1).Select ' ---------------------------------------------- ' set text format for every cell ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,BOMattribColIDX).NumberFormat = "@" ' ---------------------------------------------- ' set text format for header and rest ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,BOMattribColIDX).Font.Size = 5 oExcel.ActiveCell.Offset(0,BOMattribColIDX).Orientation = 0 oExcel.ActiveCell.Offset(0,BOMattribColIDX).Font.Color = RGB(255,0,0) oExcel.ActiveCell.Offset(0,BOMattribColIDX).Interior.Color = RGB(255,0,0) ' ---------------------------------------------- ' set EXCEL cell value ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,BOMattribColIDX) = CompAttribTitle2(BOMattribColIDX) end if next BOMattribColIDX ' ---------------------------------------------- ' Populate EXCEL Header above Main + 1 ' ---------------------------------------------- ufs.Ui.SetStatus("Action Mode = Writing Top Header Data") for BOMattribColIDX as long = 0 to ubound(CompAttribTitle) if CompAttribTitle(BOMattribColIDX) <> "" then ' ---------------------------------------------- ' select initial cells to get offset from ' ---------------------------------------------- oSheet.Cells(MainRowStart-2,1).Select ' ---------------------------------------------- ' set text format for every cell ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,BOMattribColIDX).NumberFormat = "@" ' ---------------------------------------------- ' set text format for header and rest ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,BOMattribColIDX).Font.Size = 5 oExcel.ActiveCell.Offset(0,BOMattribColIDX).Orientation = 0 oExcel.ActiveCell.Offset(0,BOMattribColIDX).Font.Color = RGB(51,51,51) oExcel.ActiveCell.Offset(0,BOMattribColIDX).Interior.Color = RGB(51,51,51) ' ---------------------------------------------- ' set EXCEL cell value ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,BOMattribColIDX) = CompAttribTitle(BOMattribColIDX) end if next BOMattribColIDX ' ---------------------------------------------- ' Populate EXCEL Header and Main ' ---------------------------------------------- ufs.Ui.SetStatus("Action Mode = Writing Component Data to EXCEL") For BOMattribIDX as long = 0 to ubound(BOMattrib,1) ufs.Ui.SetStatus("EXCEL - Component Attribute Writing for: " & BOMattribIDX & "/" & ubound(BOMattrib,1) & " = " & BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "Name"))) BOMAttribLine = "" for BOMattribColIDX as long = 0 to ubound(BOMattrib,2) ' ---------------------------------------------- ' select initial cells to get offset from ' ---------------------------------------------- oSheet.Cells(MainRowStart-1,1).Select ' ---------------------------------------------- ' set text format for every cell ' ---------------------------------------------- if BOMattribColIDX <> 4 and BOMattribIDX > 0 then oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).NumberFormat = "@" end if ' ---------------------------------------------- ' set text format for header and rest ' ---------------------------------------------- if BOMattribIDX = 0 then 'oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Font.Size = 10 oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Orientation = 45 oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Interior.Color = RGB(204,204,204) 'else ' if BOMattribColIDX < 8 then oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Font.Size = 8 ' if BOMattribColIDX < 3 then oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Font.Size = 3 end if ' ---------------------------------------------- ' set text format for values ' ---------------------------------------------- if BOMattribIDX > 0 then if CompAttribValTextSize(BOMattribColIDX) <> "" then oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Font.Size = CompAttribValTextSize(BOMattribColIDX) end if end if ' ---------------------------------------------- ' set color ' ---------------------------------------------- if BOMattribIDX > 0 then If CompAttribColColor(BOMattribColIDX) = 1 then oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Interior.Color = RGB(51,51,51) end if end if ' ---------------------------------------------- ' set Data Validation ' ---------------------------------------------- Dim ListSeperator as string Dim ListTemp as string 'ListSeperator = oExcel.International(xlListSeparator) ListSeperator = oExcel.International(5) ListTemp = Replace(CompAttribDataValidation(BOMattribColIDX), "*", ListSeperator) if CompAttribDataValidation(BOMattribColIDX) <> "" and BOMattribIDX > 0 then oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.Delete oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.Add(Type:=3, AlertStyle:=1, Operator:=1, Formula1:=ListTemp) oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.IgnoreBlank = True oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.InCellDropdown = True oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.InputTitle = "" oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.ErrorTitle = "" oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.InputMessage = "" oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.ShowInput = True oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).Validation.ShowError = True end if ' ---------------------------------------------- ' set cell comment ' ---------------------------------------------- REM Dim CellRange as Object REM CellRange = oSheet.Range(oSheet.Cells(MainRowStart-1,BOMattribColIDX + 1), oSheet.Cells(MainRowStart-1,BOMattribColIDX + 1)) REM if CompAttribComment(BOMattribColIDX) <> "" and BOMattribIDX = 0 then REM 'if CellRange.Comment is nothing then CellRange.Comment.AddComment REM CellRange.Comment.AddComment REM CellRange.Comment.Text = CompAttribComment(BOMattribColIDX) REM else REM If Not (CellRange.Comment Is Nothing) Then CellRange.Comment.Delete REM end if ' ---------------------------------------------- ' set EXCEL cell value ' ---------------------------------------------- oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX) = BOMattrib(BOMattribIDX,BOMattribColIDX) ' ---------------------------------------------- ' If first row set autofilter ' ---------------------------------------------- if BOMattribIDX = 0 and BOMattribColIDX = 0 then oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).EntireRow.AutoFilter if oSheet.FilterMode = false then oSheet.FilterMode = True end if 'oSheet.AutoFilterMode = True end if ' ---------------------------------------------- ' If last row set autofit for each column by last cell ' ---------------------------------------------- if BOMattribIDX = ubound(BOMattrib,1) and BOMattribColIDX = ubound(BOMattrib,2) then 'oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).EntireColumn.AutoFit Dim AutoFitRange As Object Dim HeaderRange as Object ' Define the range for auto fit AutoFitRange = oSheet.Range(oSheet.Cells(MainRowStart,1), oSheet.Cells(BOMattribIDX + (MainRowStart-1),BOMattribColIDX + 1)) HeaderRange = oSheet.Range(oSheet.Cells(MainRowStart-1,1), oSheet.Cells(MainRowStart-1,BOMattribColIDX + 1)) ' Select the range AutoFitRange.select ' Activate autofit for columns on selected range oEXCEL.Selection.Columns.AutoFit ' Create named range in EXCEL oBook.Names.Add (Name:="Main", RefersTo:=AutoFitRange) oBook.Names.Add (Name:="Header", RefersTo:=HeaderRange) ' Select the initial cell oSheet.Cells(MainRowStart,1).Select end if next BOMattribColIDX Next BOMattribIDX ' ---------------------------------------------- ' Set Column width if required ' ---------------------------------------------- ufs.Ui.SetStatus("Action Mode = Set Column Width") for BOMattribColIDX as long = 0 to ubound(CompAttribColWidth) if CompAttribColWidth(BOMattribColIDX) <> 0 then ' ---------------------------------------------- ' select initial cells to get offset from ' ---------------------------------------------- oSheet.Cells(MainRowStart-2,1).Select ' ---------------------------------------------- ' set column width ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,BOMattribColIDX).ColumnWidth = CompAttribColWidth(BOMattribColIDX) end if next BOMattribColIDX ' ---------------------------------------------- ' Group columns ' ---------------------------------------------- For GrpColIDX as integer = 0 to ubound(GroupCols,1) 'oSheet.Range(oSheet.Cells(0,GroupCols(GrpColIDX,0)),oSheet.Cells(0,GroupCols(GrpColIDX,1))).Select Dim GroupRange as Object GroupRange = oSheet.Range(oSheet.Cells(1, GroupCols(GrpColIDX,0)),oSheet.Cells(1, GroupCols(GrpColIDX,1))) 'oSheet.Range(owStart-2,1).Select if GroupRange.Columns.OutlineLevel > 1 then GroupRange.Columns.UnGroup end if GroupRange.Columns.Group next GrpColIDX end if ' ---------------------------------------------- ' set and report component groups ' ---------------------------------------------- CompGrpCol = theSession.Parts.Display.ComponentGroups For Each CompGrp In CompGrpCol if reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : Component Group = " & CompGrp.Name()) Next ' ---------------------------------------------- ' select by selection mode ' ---------------------------------------------- Dim OperateComp As Component Dim CompMatch as boolean Dim CompareStr as string 'Dim MasterCompPart as part 'Dim partRootloadStatus As PartLoadStatus For BOMattribIDX as long = 1 to ubound(BOMattrib,1) CompMatch = False ' Compare by Handle string If CompSelMode = 0 Then CompareStr = BOMattrib(BOMattribIDX, getArrayCol(CompAttrib, "handle")) 'If CompSelMode = 0 Then CompareStr = BOMattrib(BOMattribIDX,2) ' Compare by SAP ID - SAP_MM_MATERIAL_ID If CompSelMode = 1 and CompSelModeSub = 0 Then CompareStr = BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "SAP_MM_MATERIAL_ID")) 'If CompSelMode = 1 and CompSelModeSub = 0 Then CompareStr = BOMattrib(BOMattribIDX,9) ' Compare by SAP ID - SAP_DM_DOCUMENT_ID If CompSelMode = 1 and CompSelModeSub = 1 Then CompareStr = BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "SAP_DM_DOCUMENT_ID")) 'If CompSelMode = 1 and CompSelModeSub = 1 Then CompareStr = BOMattrib(BOMattribIDX,10) ' Compare by name If CompSelMode = 2 Then CompareStr = BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "Name")) 'If CompSelMode = 2 Then CompareStr = BOMattrib(BOMattribIDX,7) ' Compare by ItemID If CompSelMode = 3 Then CompareStr = BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "DB_PART_NO")) 'If CompSelMode = 3 Then CompareStr = BOMattrib(BOMattribIDX,4) ' ---------------------------------------------- ' Compare component attribute with EXCEL selection ' ---------------------------------------------- dim CellArrayIDX as long dim CellArrayMatch as long CellArrayIDX = 0 for each oCell in oRange CellArrayIDX = CellArrayIDX + 1 if CompareStr = oCell.Value then CompMatch = True CellArrayMatch = CellArrayIDX end if next oCell ' ---------------------------------------------- ' report match status ' ---------------------------------------------- If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : Match Entry:" & BOMattribIDX & " " & CompMatch & " on Selection Mode " & CompSelMode & "/" & CompSelModeSub & " with " & CompareStr & " => " & BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "Name"))) ' ---------------------------------------------- ' operate on component ' ---------------------------------------------- ' get the component OperateComp = CType(workPart.ComponentAssembly.FindObject(BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "handle"))), Assemblies.Component) ' ---------------------------------------------- ' operate on component in action mode 0 and 1 if the array list is larger q ' ---------------------------------------------- if actionmode = 0 and CompMatch = False then ufs.Ui.SetStatus("Component Blank: " & BOMattribIDX & "/" & ubound(BOMattrib,1) & " = " & BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "Name"))) If AttribMode = False then SetVisibilityByTag(OperateComp.tag, True, 0, True, 0, false, 0, False, 0) end if end if if actionmode = 0 and CompMatch = true then ufs.Ui.SetStatus("Component Matched: " & BOMattribIDX & "/" & ubound(BOMattrib,1) & " = " & BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "Name"))) ' ---------------------------------------------- ' Call sub function to get Master component part ' ---------------------------------------------- REM ufs.Ui.SetStatus("Check if component part is loaded") REM MasterCompPart = getMasterComponentPart(OperateComp.tag) REM If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function errcode: getMasterComponentPart() - CompMasterLoaded = " & CompMasterLoaded) REM If CompMasterLoaded = False Then REM If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function errcode: getMasterComponentPart() - Compenent has to be loaded " ) REM ' ---------------------------------------------- REM ' Part Load Status for component REM ' ---------------------------------------------- REM Dim CompPartLoadStatus As PartLoadStatus REM Dim Compstatus As PartCollection.SdpsStatus REM Compstatus = theSession.Parts.SetDisplay(MasterCompPart, False, True, CompPartLoadStatus) REM End If ' ---------------------------------------------- ' after load set visibility ' ---------------------------------------------- If AttribMode = False then SetVisibilityByTag(OperateComp.tag, True, 0, True, 1, CompMark, CompMarkColor, CompMarkTransp, CompMarkTranspValue) else ' ---------------------------------------------- ' get the EXCEL value at cell A1 ' ---------------------------------------------- 'oSheet.Range("A1").Value = "Last Name" dim xlsvalue AS STRING dim xlsAttrib as string 'dim xlsCellPointerAttrib as string dim xlsCellPointerValueCol as long dim xlsCellPointerValueRow as long 'Dim Headerline as long 'Dim Valueline as long 'Headerline = MainRowStart - 1 'Valueline = BOMattribIDX + Headerline 'xlsCellPointerAttrib = AttribColStr & Headerline 'xlsCellPointerValue = AttribColStr & Valueline If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : Direct Mode: " & AttribModeDirect) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : Cell Matched: " & CellArrayMatch) ' ' Get the Attribute If AttribModeDirect = False then 'xlsAttrib = oSheet.Range(xlsCellPointerAttrib).Value xlsAttrib = AttribPropStr else xlsAttrib = AttribStr End if ' Get The Value for the new attribute If AttribModeDirect = False then 'xlsvalue = oSheet.Range(xlsCellPointerValue).Value xlsCellPointerValueCol = AttribRootCol xlsCellPointerValueRow = CellRow(CellArrayMatch) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : InDirect Source Col.: " & xlsCellPointerValueCol) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : InDirect Source Row.: " & xlsCellPointerValueRow) xlsvalue = oSheet.Cells(xlsCellPointerValueRow ,xlsCellPointerValueCol).Value else xlsvalue = AttribVal End if If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : New Component Attribute: " & xlsAttrib & "=" & xlsvalue) ' ---------------------------------------------- ' Set the new string attribute ' ---------------------------------------------- OperateComp.SetAttribute(xlsAttrib, xlsvalue) end if end if if actionmode = 1 then ' Reverse all ufs.Ui.SetStatus("Component Unblank: " & BOMattribIDX & "/" & ubound(BOMattrib,1) & " = " & BOMattrib(BOMattribIDX,getArrayCol(CompAttrib, "Name"))) SetVisibilityByTag(OperateComp.tag, True, 0, True, 1, false, 0, false, 0) end if Next BOMattribIDX ' ---------------------------------------------- ' if action mode > 2 collect MARA keys ' ---------------------------------------------- if actionmode > 2 then ufs.Ui.SetStatus("Collect SAP Material ID's") ' create a temp array with Material ID's in reference to the current BOMAttrib array Dim SAPIDStmp(ubound(BOMattrib,1)-1) as String ' transfer data into array For AttribIDX as long = 1 to ubound(BOMattrib,1) ufs.Ui.SetStatus("Check for SAP Material ID" & AttribIDX & "/" & ubound(BOMattrib,1)) SAPIDStmp(AttribIDX-1) = BOMattrib(AttribIDX,getArrayCol(CompAttrib, "SAP_MM_MATERIAL_ID")) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPIDStmp(AttribIDX-1) = " & (AttribIDX-1) & " => " & BOMattrib(AttribIDX,getArrayCol(CompAttrib, "SAP_MM_MATERIAL_ID"))) next AttribIDX If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPIDStmp Quantity = " & ubound(SAPIDStmp)) 'create an ArrayList of valid SAP ID's errcode = CollectAllSAPIDS(SAPIDStmp) MATKeys = ListOfIDS If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function errcode: CollectAllSAPIDS() = " & errcode) If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : MATKeys.Count = " & MATKeys.Count) end if ' ---------------------------------------------- ' SAP actions ' ---------------------------------------------- if ByPassSAP = False then ' ---------------------------------------------- ' if action mode > 2 connect to excel ' ---------------------------------------------- if actionmode > 2 then ' ---------------------------------------------- ' transfer Material ID's into SAPReportKey ArrayList ' ---------------------------------------------- SAPReportMassKeys.Clear SAPReportNarrowKeys.Clear SAPReportMassKeys = MATKeys.Clone SAPReportNarrowKeys.add(SAPPlant(0)) ' ---------------------------------------------- ' Report SAP request meta ' ---------------------------------------------- If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportMassKeys.Count = " & SAPReportMassKeys.Count) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportNarrowKeys.Count = " & SAPReportNarrowKeys.Count) ' ---------------------------------------------- ' SAP MARC analysis ' ---------------------------------------------- MARCResult = SAPgetDATA("plant specific production (MARC)", "MARC", "WERKS", "MATNR", MARCFields, "search", "search") If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : MARCResult = " & ubound(MARCResult)) ' ---------------------------------------------- ' transfer Material ID's into SAPReportKey ArrayList ' ---------------------------------------------- SAPReportMassKeys.Clear SAPReportNarrowKeys.Clear SAPReportMassKeys = MATKeys.Clone SAPReportNarrowKeys.add(SAPPlant(0)) ' ---------------------------------------------- ' Report SAP request meta ' ---------------------------------------------- If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportMassKeys.Count = " & SAPReportMassKeys.Count) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportNarrowKeys.Count = " & SAPReportNarrowKeys.Count) ' ---------------------------------------------- ' SAP MBEW analysis ' ---------------------------------------------- MBEWResult = SAPgetDATA("plant specific cost (BWEW)", "MBEW", "BWKEY", "MATNR", MBEWFields, "search", "search") If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : MBEWResult = " & ubound(MBEWResult)) ' ---------------------------------------------- ' transfer Material ID's into SAPReportKey ArrayList ' ---------------------------------------------- SAPReportMassKeys.Clear SAPReportNarrowKeys.Clear SAPReportMassKeys = MATKeys.Clone SAPReportNarrowKeys.add("001") ' ---------------------------------------------- ' Report SAP request meta ' ---------------------------------------------- If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportMassKeys.Count = " & SAPReportMassKeys.Count) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportNarrowKeys.Count = " & SAPReportNarrowKeys.Count) ' ---------------------------------------------- ' SAP MARA analysis ' ---------------------------------------------- MARAResult = SAPgetDATA("general (MARA)", "MARA", "MANDT", "MATNR", MARAFields, "search", "search") If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : MBEWResult = " & ubound(MBEWResult)) ' ---------------------------------------------- ' transfer Material ID's into SAPReportKey ArrayList ' ---------------------------------------------- SAPReportMassKeys.Clear SAPReportNarrowKeys.Clear SAPReportMassKeys = MATKeys.Clone SAPReportNarrowKeys.add("DE") SAPReportNarrowKeys.add("EN") 'SAPReportNarrowKeys.add("FR") ' ---------------------------------------------- ' Report SAP request meta ' ---------------------------------------------- If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportMassKeys.Count = " & SAPReportMassKeys.Count) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReportNarrowKeys.Count = " & SAPReportNarrowKeys.Count) ' ---------------------------------------------- ' SAP MAKT analysis ' ---------------------------------------------- MAKTResult = SAPgetDATA("general (MAKT)", "MAKT", "SPRAS", "MATNR", MAKTFields, "search", "search") If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : MBEWResult = " & ubound(MBEWResult)) ' ---------------------------------------------- ' Close SAP Connection ' ---------------------------------------------- ufs.Ui.SetStatus("Close SAP Connection") SapConnection.LOGOFF ' ---------------------------------------------- ' create MARC data sheet ' ---------------------------------------------- errcode = creEXCELSheet("MARC", oSheetMARC, MARCSheetName, MARCtitles, MARCResult, MARCFormats) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: creEXCELSheet() = " & errcode) ' ---------------------------------------------- ' create MBEW data sheet ' ---------------------------------------------- errcode = creEXCELSheet("MBEW", oSheetMBEW, MBEWSheetName, MBEWtitles, MBEWResult, MBEWFormats) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: creEXCELSheet() = " & errcode) ' ---------------------------------------------- ' create MARA data sheet ' ---------------------------------------------- errcode = creEXCELSheet("MARA", oSheetMARA, MARASheetName, MARAtitles, MARAResult, MARAFormats) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: creEXCELSheet() = " & errcode) ' ---------------------------------------------- ' create MAKT data sheet ' ---------------------------------------------- errcode = creEXCELSheet("MAKT", oSheetMAKT, MAKTSheetName, MAKTtitles, MAKTResult, MAKTFormats) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: creEXCELSheet() = " & errcode) ' ---------------------------------------------- ' create summary formula ' ---------------------------------------------- ' Select back the original sheet oSheet.Select 'oSheet.Cells(3,16).Select 'oSheet.Cells(3,16).Formula = "=VLOOKUP(J3,MARC,3,FALSE)" 'oSheet.Cells(3,16).Formula = "=J3" ' ---------------------------------------------- ' turn off EXCEL calucaltion ' ---------------------------------------------- ' oExcel.Calculation = xlCalculationManual = -4135 'oExcel.Calculation = -4135 'oExcel.Calculation = xlCalculationAutomatic = -4105 ' ---------------------------------------------- ' create additional formulars ' ---------------------------------------------- errcode = creEXCELFormulars() If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: creEXCELFormulars() = " & errcode) oSheet.Cells(1,18).NumberFormat = "@" oSheet.Cells(1,18).Value= SAPPlant(0) REM oSheet.Cells(2,18).Value= "Plant specific status" REM oSheet.Cells(3,18).FormulaLocal= "=SVERWEIS(L3;MARC;3;FALSCH)" REM oSheet.Cells(2,19).Value= "Procurement" REM oSheet.Cells(3,19).FormulaLocal= "=SVERWEIS(L3;MARC;4;FALSCH)" REM oSheet.Cells(2,20).Value= "Special Procurement" REM oSheet.Cells(3,20).FormulaLocal= "=SVERWEIS(L3;MARC;5;FALSCH)" REM oSheet.Cells(2,21).Value= "Price" REM oSheet.Cells(3,21).FormulaLocal= "=WENN(SVERWEIS(L3;MBEW;3;FALSCH)= ""V"";(SVERWEIS(L3;MBEW;4;FALSCH)/SVERWEIS(L3;MBEW;6;FALSCH));(SVERWEIS(L3;MBEW;5;FALSCH)/SVERWEIS(L3;MBEW;6;FALSCH)))" ' ---------------------------------------------- ' Select back the original sheet ' ---------------------------------------------- oSheet.Select oSheet.Cells(1,1).Select end if end if ' ---------------------------------------------- ' if action mode > 3 create thumbnails ' ---------------------------------------------- if actionmode > 3 then errcode = delThumbnails() If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: delThumbnails() = " & errcode) 'IsURLGood("http://X.X.X.X:7011/tc/wedav") errcode = creThumbnails() If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: creThumbnails() = " & errcode) end if ' ---------------------------------------------- ' get the EXCEL value at cell A1 ' ---------------------------------------------- 'oSheet.Range("A1").Value = "Last Name" 'dim xlsvalue AS STRING 'xlsvalue = oSheet.Range("A1").Value 'If reportlevel > 5 Then theSession.ListingWindow.WriteLine("Function : EXCEL - A1 Value = " & xlsvalue) ufs.Ui.SetStatus("Macro finished") finalized: End Sub ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to delete all shapes ' ------------------------------------------------------------------------------------------------------------ Function delThumbnails() As integer Try ' ---------------------------------------------- ' Dim additional objects ' ---------------------------------------------- Dim oXLSSheet as object Dim oShape as object ' ---------------------------------------------- ' find and select the required sheet first ' ---------------------------------------------- oXLSSheet = oBook.Worksheets("NX CAD BOM") For Each oShape In oXLSSheet.Shapes oShape.Delete Next ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- delThumbnails = 0 Catch ex As NXException delThumbnails = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to additional formular on the a sheet sheet ' ------------------------------------------------------------------------------------------------------------ Function creThumbnails() As integer 'Try ' ---------------------------------------------- ' Dim additional objects ' ---------------------------------------------- Dim oXLSSheet as object Dim oXLSRangeLeft as object Dim oXLSColLeft as object Dim UpperLeft as string Dim LowerLeft as string Dim UpperRight as string Dim LowerRight as string Dim oRange as Object Dim MyPicture As Object Dim oCell as Object Dim URL as string Dim Left as double Dim Top as double Dim Height as double Dim Width as double Dim webdavroot as string ufs.Ui.SetStatus("Create Thumbnails") ' ---------------------------------------------- ' find and select the required sheet first ' ---------------------------------------------- oXLSSheet = oBook.Worksheets("NX CAD BOM") oXLSSheet.Select oXLSSheet.Cells(1,1).Select ' ---------------------------------------------- ' select the named range ' ---------------------------------------------- 'oXLSRangeLeft(XLSformRangeLeft(FormIDX)).Select 'oBook.Names.Item(XLSformRangeLeft(FormIDX)).Select oXLSRangeLeft= oXLSSheet.Range("Main") oXLSRangeLeft.Select If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creThumbnails() - RangeAddress=" & oXLSRangeLeft.Address) ' ---------------------------------------------- ' identify cirner of the active range ' ---------------------------------------------- With oExcel.Selection UpperLeft = .Cells(1).Address(0,0) LowerLeft = .Cells(.Rows.Count,1).Address(0,0) UpperRight = .Cells(1, .Columns.Count).Address(0,0) LowerRight = .Cells(.Rows.Count,.Columns.Count).Address(0,0) End with If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creThumbnails() - UpperLeft =" & UpperLeft) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creThumbnails() - LowerLeft =" & LowerLeft) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creThumbnails() - UpperRight =" & UpperRight) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creThumbnails() - LowerRight =" & LowerRight) ' ---------------------------------------------- ' Select right colum of active range ' ---------------------------------------------- oXLSSheet.Range("O5:O" & oExcel.Selection.Rows.Count + 4).Select ' ---------------------------------------------- ' Select upper right cell of active range ' ---------------------------------------------- oRange = oExcel.Selection For Each oCell In oRange if oCell.Offset(0,-3).Value= "" then goto ThumbnailSkip if webdavhome = "" then webdavroot = "http://X.X.X.X:7001/tc/webdav" if webdavhome = "" then webdavroot = "http://X.X.X.X:7001/tc/webdav" URL = webdavroot & "/itemid-" & oCell.Offset(0,-3).Value & "/" & oCell.Offset(0,-2).Value & "/images_preview.qaf" If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creThumbnails() - create Thumbnail = " & URL) 'MyPicture = oXLSSheet.Shapes.AddShape(msoShapeRectangle, oCell.Left, oCell.Top, oCell.Width, oCell.Height) 'MyPicture = oXLSSheet.Shapes.AddShape(1, oCell.Left, oCell.Top, oCell.Width, oCell.Height) 'MyPicture = oXLSSheet.Shapes.AddShape(1, oCell.Left, oCell.Top, oCell.Width, oCell.Height) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creThumbnails() - Cell = " & oCell.Left & " / " & oCell.Top) Left = oCell.Left Top = oCell.Top Width = oCell.Width Height = oCell.Height On Error resume next If IsURLGood(URL) = True then MyPicture = oXLSSheet.Shapes.AddShape(1, Left, Top, Width, Height) 'MyPicture.Fill.UserPicture(URL) If Dir("c:\temp\downloadedFile.jpg") <> "" Then MyPicture.Fill.UserPicture("c:\temp\downloadedFile.jpg") Kill ("c:\temp\downloadedFile.jpg") End If end if ThumbnailSkip: Next oCell ' ---------------------------------------------- ' Select origin ' ---------------------------------------------- 'oXLSSheet.Cells(1,1).Select ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- creThumbnails = 0 'Catch ex As NXException 'creThumbnails = 1 'End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to check the image URL ' ------------------------------------------------------------------------------------------------------------ Function IsURLGood(url As String) As Boolean try IsURLGood = false Dim userName As String = "" Dim password As String = "" 'Dim request as object 'request = CreateObject("WinHttp.WinHttpRequest.5.1") 'Create the request Dim request As HttpWebRequest = DirectCast(System.Net.HttpWebRequest.Create(url), HttpWebRequest) 'Set the User Name and Password request.Credentials = New NetworkCredential(userName, password) 'Let the server know we want to "get" a file request.Method = WebRequestMethods.Http.Get '*** This is required for our WebDAV server *** request.SendChunked = True request.Headers.Add("Translate: f") 'Get the response from the request Dim response As HttpWebResponse = DirectCast(request.GetResponse(), HttpWebResponse) Dim destination As String = "c:\temp\downloadedFile.jpg" 'Create the buffer for storing the bytes read from the server Dim byteTransferRate As Integer = 4096 '4096 bytes = 4 KB Dim bytes(byteTransferRate - 1) As Byte Dim bytesRead As Integer = 0 'Indicates how many bytes were read Dim totalBytesRead As Long = 0 'Indicates how many total bytes were read Dim contentLength As Long = 0 'Indicates the length of the file being downloaded 'Read the content length contentLength = CLng(response.GetResponseHeader("Content-Length")) 'Create a new file to write the downloaded data to Dim fs As New IO.FileStream(destination, IO.FileMode.Create, IO.FileAccess.Write) 'Get the stream from the server Dim s As IO.Stream = response.GetResponseStream() Do 'Read from the stream bytesRead = s.Read(bytes, 0, bytes.Length) If bytesRead > 0 Then totalBytesRead += bytesRead 'Write to file fs.Write(bytes, 0, bytesRead) End If Loop While bytesRead > 0 'Close streams s.Close() s.Dispose() s = Nothing fs.Close() fs.Dispose() fs = Nothing 'Close the response response.Close() response = Nothing REM 'Validate the downloaded file. Both must be an exact match REM ' for the file to be considered a valid download. REM 'If totalBytesRead <> contentLength Then REM 'MessageBox.Show("The downloaded file did not download successfully, " & _ REM "because the length of the downloaded file " & _ REM "does not match the length of the file on the remote site.", _ REM "Download File Validation Failed", _ REM 'MessageBoxButtons.YesNo, MessageBoxIcon.Warning) REM Else 'totalBytesRead = contentLength REM 'MessageBox.Show("The file has downloaded successfully!", "Download Complete", _ REM MessageBoxButtons.OK, MessageBoxIcon.Information) REM End If 'Set request = CreateObject("WinHttp.WinHttpRequest.5.1") 'On Error GoTo error_handler 'objIE = CreateObject("InternetExplorer.Application") 'With objIE ' .Navigate("http://X.X.X.X:7001/tc/webdav") ' .Visible = True 'End With 'objIE = Nothing REM Exit function REM error_handler: REM MsgBox ("Unexpected Error, I'm quitting.") REM objIE.Quit REM objIE = Nothing ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- IsURLGood = True Catch ex As NXException IsURLGood = false End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to additional formular on the a sheet sheet ' ------------------------------------------------------------------------------------------------------------ Function creEXCELFormulars() As integer Try ' ---------------------------------------------- ' Dim additional objects ' ---------------------------------------------- Dim oXLSSheet as object Dim oXLSRangeLeft as object Dim oXLSColLeft as object Dim UpperLeft as string Dim LowerLeft as string Dim UpperRight as string Dim LowerRight as string ' ---------------------------------------------- ' create MBEW data sheet ' ---------------------------------------------- for FormIDX as integer = 0 to ubound(XLSform) ufs.Ui.SetStatus("Create Formula " & FormIDX & "/" & ubound(XLSform)) if XLSformExt(FormIDX) = True and XLSformExtended = false then goto creEXCELFormulaSkip ' ---------------------------------------------- ' find and select the required sheet first ' ---------------------------------------------- oXLSSheet = oBook.Worksheets(XLSformSheet(FormIDX)) oXLSSheet.Select oXLSSheet.Cells(1,1).Select ' ---------------------------------------------- ' select the named range ' ---------------------------------------------- 'oXLSRangeLeft(XLSformRangeLeft(FormIDX)).Select 'oBook.Names.Item(XLSformRangeLeft(FormIDX)).Select oXLSRangeLeft= oXLSSheet.Range(XLSformRangeLeft(FormIDX)) oXLSRangeLeft.Select If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creEXCELFormulars() - RangeAddress=" & oXLSRangeLeft.Address) ' ---------------------------------------------- ' identify cirner of the active range ' ---------------------------------------------- With oExcel.Selection UpperLeft = .Cells(1).Address(0,0) LowerLeft = .Cells(.Rows.Count,1).Address(0,0) UpperRight = .Cells(1, .Columns.Count).Address(0,0) LowerRight = .Cells(.Rows.Count,.Columns.Count).Address(0,0) End with If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creEXCELFormulars() - UpperLeft =" & UpperLeft) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creEXCELFormulars() - LowerLeft =" & LowerLeft) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creEXCELFormulars() - UpperRight =" & UpperRight) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creEXCELFormulars() - LowerRight =" & LowerRight) ' ---------------------------------------------- ' Select right colum of active range ' ---------------------------------------------- oXLSSheet.Range(UpperRight & ":" & LowerRight).Select ' ---------------------------------------------- ' store formular ' ---------------------------------------------- If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creEXCELFormulars() Store Formula =" & XLSform(FormIDX)) oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)).ClearFormats if XLSformType(FormIDX) = "L" then oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)).FormulaLocal = XLSform(FormIDX) end if if XLSformType(FormIDX) = "I" then 'oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)).Formula = XLSform(FormIDX) SetPropertyInternational(oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)), "Formula", XLSform(FormIDX)) end if if XLSformType(FormIDX) = "R" then 'oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)).FormulaR1C1 = XLSform(FormIDX) SetPropertyInternational(oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)), "FormulaR1C1", XLSform(FormIDX)) end if if XLSformType(FormIDX) = "V" then oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)).Value = XLSform(FormIDX) end if 'If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : creEXCELFormulars() FormulaR1C1 =" & oExcel.Selection.Offset(0, XLSformColOffset(FormIDX)).FormulaR1C1) ' ---------------------------------------------- ' Select upper right cell of active range ' ---------------------------------------------- oXLSSheet.Range(UpperRight).Select ' ---------------------------------------------- ' store the title of the formular ' ---------------------------------------------- with oExcel.Selection.Offset(-1, XLSformColOffset(FormIDX)) .Value = XLSformTitle(FormIDX) .NumberFormat = "@" .Orientation = 45 .Interior.Color = RGB(204,204,204) end with ' ---------------------------------------------- ' Select origin ' ---------------------------------------------- creEXCELFormulaSkip: oXLSSheet.Cells(1,1).Select next FormIDX ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- creEXCELFormulars = 0 Catch ex As NXException creEXCELFormulars = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to create an excel sheet ' ------------------------------------------------------------------------------------------------------------ Function creEXCELSheet(ByVal title as string, ByRef SheetXLSobj as Object, ByVal SheetName as string, ByRef ColHead() as string, ByRef Data(,) as string, ByRef DataFormat() as string) As integer Try ' ---------------------------------------------- ' create MBEW data sheet ' ---------------------------------------------- ufs.Ui.SetStatus("create EXCEL sheet for " & title & " data") errcode = FindEXCELSheet(oBook, SheetXLSobj, SheetName , sheetexists) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: FindEXCELSheet() = " & errcode) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : FindEXCELSheet() = Sheet exists => " & sheetexists) if sheetexists = false then oBook.Worksheets.Add (After:=oBook.Worksheets(oBook.Worksheets.Count)).Name = SheetName SheetXLSobj = oBook.Worksheets(SheetName) end if ufs.Ui.SetStatus("Action Mode = Writing " & title & " Header to EXCEL") errcode = populateEXCELwithArray(SheetXLSobj, ColHead, Data, DataFormat, title) If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: populateEXCELwithArray() = " & errcode) ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- creEXCELSheet = 0 Catch ex As NXException creEXCELSheet = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to populate an excel sheet with an array ' ------------------------------------------------------------------------------------------------------------ Function populateEXCELwithArray(ByRef oSheetXLS as object, ByRef titles() as string, ByRef values(,) as string, ByRef formats() as string, ByVal RangeName as string) As integer Try ' ---------------------------------------------- ' Select the new sheet ' ---------------------------------------------- oSheetXLS.Select dim numericvaltemp as double ' ---------------------------------------------- ' Populate MARC data sheet Header ' ---------------------------------------------- For ColIDX as long = 0 to ubound(titles) ' ---------------------------------------------- ' select initial cells to get offset from ' ---------------------------------------------- oSheetXLS.Cells(1,1).Select ' ---------------------------------------------- ' set text format for every cell ' ---------------------------------------------- oExcel.ActiveCell.Offset(0,ColIDX).NumberFormat = "@" oExcel.ActiveCell.Offset(0,ColIDX).Orientation = 30 oExcel.ActiveCell.Offset(0,ColIDX).Value = titles(ColIDX) next ColIDX ' ---------------------------------------------- ' Populate MARC data sheet ' ---------------------------------------------- For RowIDX as long = 0 to ubound(values,1) ufs.Ui.SetStatus("Writing " & RowIDX & "/" & ubound(values,1) & " " & RangeName & " Data to EXCEL") For ColIDX as long = 0 to ubound(values,2) ' ---------------------------------------------- ' select initial cells to get offset from ' ---------------------------------------------- oSheetXLS.Cells(2,1).Select ' ---------------------------------------------- ' set text format for every cell ' ---------------------------------------------- If formats(ColIDX) = "T" then oExcel.ActiveCell.Offset(RowIDX,ColIDX).NumberFormat = "@" end if 'oExcel.ActiveCell.Offset(0,ColIDX).Orientation = 30 ' ---------------------------------------------- ' populate cell by format ' ---------------------------------------------- numericvaltemp = 0.0 if formats(ColIDX) = "D" then numericvaltemp = Double.Parse(values(RowIDX,ColIDX),System.Globalization.CultureInfo.CreateSpecificCulture("en-us")) oExcel.ActiveCell.Offset(RowIDX,ColIDX).Value = numericvaltemp end if if formats(ColIDX) = "T" then oExcel.ActiveCell.Offset(RowIDX,ColIDX).Value = values(RowIDX,ColIDX) end if ' ---------------------------------------------- ' If first row set autofilter ' ---------------------------------------------- if RowIDX = 0 and ColIDX = 0 then oExcel.ActiveCell.Offset(RowIDX -1 ,ColIDX).EntireRow.AutoFilter if oSheetXLS.FilterMode = false then oSheetXLS.FilterMode = True end if 'oSheet.AutoFilterMode = True end if ' ---------------------------------------------- ' If last row set autofit for each column by last cell and add name to Workbook ' ---------------------------------------------- if RowIDX = ubound(values,1) and ColIDX = ubound(values,2) then 'oExcel.ActiveCell.Offset(BOMattribIDX,BOMattribColIDX).EntireColumn.AutoFit Dim AutoFitRange As Object ' Define the range for auto fit AutoFitRange = oSheetXLS.Range(oSheetXLS.Cells(2,1), oSheetXLS.Cells(RowIDX + 2,ColIDX + 1)) ' Select the range AutoFitRange.select ' Activate autofit for columns on selected range oEXCEL.Selection.Columns.AutoFit ' Create named range in EXCEL oBook.Names.Add (Name:=RangeName, RefersTo:=AutoFitRange) ' Select the initial cell oSheetXLS.Cells(2,1).Select end if next ColIDX next RowIDX ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- populateEXCELwithArray = 0 Catch ex As NXException populateEXCELwithArray = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to SAP MARC data ' ------------------------------------------------------------------------------------------------------------ Function SAPgetDATA(ByVal Title as string, ByVal Table as string, ByVal NarrowFLD as string, ByVal SearchFLD as string, ByRef ResFLD() as string, ByVal MATNRconv as string, ByVal ReduceList as string) As String(,) Try ' ---------------------------------------------- ' create temp array ' ---------------------------------------------- SAPReportResult.Clear SAPgetDATA_Loop: ufs.Ui.SetStatus("Left " & SAPReportMassKeys.Count & " - Getting SAP " & Title & " data for: " & SAPReportMassKeys.Item(0)) errcode = SAPReadTable(Table, NarrowFLD, SearchFLD, ResFLD, MATNRconv, ReduceList) 'errcode = SAPReadTable("MARC", "WERKS", "MATNR", MARCFields, "search", "search") 'errcode = SAPReadTable("MARC", "MATNR", "WERKS", MARCFields, "narrow") If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function errcode: SAPReadTable() = " & errcode) if SAPReportMassKeys.Count > 0 then goto SAPgetDATA_Loop 'if SAPReportNarrowKeys.Count > 0 then goto SAPReadTable_MARC_Loop ' ---------------------------------------------- ' report the arraylist content after cleanup ' ---------------------------------------------- If reportlevel > 8 then Dim SAPres As [Object] For Each SAPres In SAPReportResult theSession.ListingWindow.WriteLine("Function : SAP Result: " & SAPres) Next SAPres theSession.ListingWindow.WriteLine("Function : SAP SAPReportResult.Count: " & SAPReportResult.Count) end if ' ---------------------------------------------- ' Dim the temp array ' ---------------------------------------------- Dim resulttmp(SAPReportResult.Count - 1, ubound(ResFLD) ) as string Dim linearray(ubound(ResFLD)) as string ' ---------------------------------------------- ' Copy results into temp array ' ---------------------------------------------- for resIDX as long = 0 to ubound(resulttmp,1) ' Clean the line array for resCOLIDX as integer = 0 to ubound(linearray) linearray (resCOLIDX) = "" next resCOLIDX linearray = Split(SAPReportResult.Item(resIDX), ";") ' copy line array for resCOLIDX as integer = 0 to ubound(linearray) IF resCOLIDX <> 0 then resulttmp(resIDX,resCOLIDX) = linearray (resCOLIDX) else resulttmp(resIDX,resCOLIDX) = SAP2ID(linearray (resCOLIDX)) end if next resCOLIDX next resIDX ' ---------------------------------------------- ' report the array ' ---------------------------------------------- If reportlevel > 9 then dim tempstr as string for resIDX as long = 0 to ubound(resulttmp,1) tempstr = "" for resCOLIDX as integer = 0 to ubound(linearray) tempstr = tempstr & "<>" & resulttmp(resIDX,resCOLIDX) next resCOLIDX theSession.ListingWindow.WriteLine("Function : SAP resulttmp(" & resIDX & ") = " & tempstr) next resIDX end if ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- SAPgetDATA = resulttmp Catch ex As NXException 'SAPgetMARC = "error" End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to read an SAP table via an existing connection ' ------------------------------------------------------------------------------------------------------------ Function SAPReadTable(ByVal SAPtable As String, ByVal NARROW As String, ByVal SEARCH as string, ByRef FIELDS() as string, ByVal convMATNR as string, ByVal ArrayListReduce as string) As integer Try ' ------------------------------------------------ ' setup function object ' ------------------------------------------------ Dim Result As Boolean Dim intRow as integer Dim DELIM as string Dim NarrowValtmp as string Dim SearchValtmp as string Dim Query as string Dim QueryNarrow as string Dim QuerySearch as string DELIM =";" SAPFunctionCtrl = CreateObject("SAP.Functions") SAPFunctionCtrl.Connection = SapConnection If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - Create Function" ) ' ------------------------------------------------ ' use RFC_READ_TABLE ' ------------------------------------------------ SAPFunction = SAPFunctionCtrl.Add("RFC_READ_TABLE") ' ------------------------------------------------ ' setup required object ' ------------------------------------------------ Dim oParam1 As Object Dim oParam2 As Object Dim oParam3 As Object Dim oParam4 As Object Dim oParam5 As Object oParam1 = SAPFunction.exports("QUERY_TABLE") oParam2 = SAPFunction.exports("DELIMITER") oParam3 = SAPFunction.Tables("OPTIONS") oParam4 = SAPFunction.Tables("DATA") oParam5 = SAPFunction.Tables("FIELDS") ' ------------------------------------------------ ' setup table an seperator ' ------------------------------------------------ oParam1.Value = SAPtable If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - Add Table " & SAPtable) oParam2.Value = DELIM ' ------------------------------------------------ ' setup the query NARROW part ' ------------------------------------------------ QueryNarrow = "(" for NarrowIDX as integer = 0 to SAPReportNarrowKeys.Count - 1 if SAPReportNarrowKeys.Count > 0 then ' COnvert SAP Material ID if required if convMATNR = "narrow" then SearchValtmp = ID2SAP(SAPReportNarrowKeys.Item(NarrowIDX)) else SearchValtmp = SAPReportNarrowKeys.Item(NarrowIDX) end if ' build the Narrow option if NarrowIDX = 0 then QueryNarrow = QueryNarrow & NARROW & " EQ '" & SearchValtmp & "'" else QueryNarrow = QueryNarrow & " OR " & NARROW & " EQ '" & SearchValtmp & "'" end if if ArrayListReduce = "narrow" then SAPReportNarrowKeys.RemoveAt(0) end if end if next NarrowIDX QueryNarrow = QueryNarrow & ")" If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - QueryNarrow =" & QueryNarrow) ' ------------------------------------------------ ' setup the query SEARCH part ' ------------------------------------------------ if convMATNR = "search" then SearchValtmp = ID2SAP(SAPReportMassKeys.Item(0)) else SearchValtmp = SAPReportMassKeys.Item(0) end if 'QuerySearch = " AND " & SEARCH & " EQ '" & ID2SAP(SAPReportMassKeys.Item(0)) & "'" QuerySearch = " AND " & SEARCH & " EQ '" & SearchValtmp & "'" ' reduce list of interest objects if ArrayListReduce = "search" then SAPReportMassKeys.RemoveAt(0) end if If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - QuerySearch =" & QuerySearch) ' ------------------------------------------------ ' the entire query ' ------------------------------------------------ Query = QueryNarrow + QuerySearch ' ------------------------------------------------ ' populate the query ' ------------------------------------------------ oParam3.AppendRow 'oParam3(1, "TEXT") = "WERKS EQ 'XXXX' AND MATNR LIKE '000%'" oParam3(1, "TEXT") = QUERY If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - Add Query " & QUERY) ' ------------------------------------------------ ' add return fields ' ------------------------------------------------ Dim FQTY as integer for FQTY = 0 to ubound(FIELDS) oParam5.AppendRow oParam5((FQTY + 1), "FIELDNAME") = FIELDS(FQTY) If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - Add Field " & FIELDS(FQTY)) next FQTY ' ------------------------------------------------ ' call the query ' ------------------------------------------------ Result = SAPFunction.CALL ' ------------------------------------------------ ' I call OK populate result ' ------------------------------------------------ Dim ColIdx as integer Dim ColRest as string Dim ColPos as integer If Result = True Then If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - RowCount " & oParam4.RowCount) For intRow = 1 to oParam4.RowCount If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() - Row: " & oParam4(intRow, "WA")) SAPReportResult.add(oParam4(intRow, "WA")) next intRow SAPReadTable = 0 Else SAPException = SAPFunction.EXCEPTION If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : SAPReadTable() " & SAPException) SAPReadTable = 1 End If ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- Catch ex As NXException SAPReadTable = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to create an inital collection of SAP ID's ' ------------------------------------------------------------------------------------------------------------ Function CollectAllSAPIDS(ByRef AttribArray() as string) As integer Try ' ------------------------------------------------ ' set temporarely objects ' ------------------------------------------------ 'Dim ListOfIDS as new ArrayList() ListOfIDS.Clear() ' ------------------------------------------------ ' transfer array into array list ' ------------------------------------------------ for ArrayIDX as long = 0 to ubound(AttribArray) ListOfIDS.Add(AttribArray(ArrayIDX)) next ArrayIDX ' ---------------------------------------------- ' cleanup the array list: Remove dublicates ' ---------------------------------------------- Dim count As long Dim i As long ListOfIDS.Sort() count = ListOfIDS.Count For i = count - 1 To 1 Step -1 If (ListOfIDS(i).ToString() = ListOfIDS(i - 1).ToString()) Then ListOfIDS.RemoveAt(i) End If Next i ' ---------------------------------------------- ' cleanup the array list: Remove invalid SAP Material Strings ' ---------------------------------------------- ListOfIDS.Sort() count = ListOfIDS.Count For i = count - 1 To 1 Step -1 If (ChkSAPIDLogic(ListOfIDS(i).ToString()) <> 0) Then ListOfIDS.RemoveAt(i) End If Next i ' ---------------------------------------------- ' report the arraylist meta ' ---------------------------------------------- If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAllSAPIDS(): Array after cleanup: ") If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAllSAPIDS(): ListOfIDS.Count = " & ListOfIDS.Count) If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAllSAPIDS(): ListOfIDS.Capacity = " & ListOfIDS.Capacity) ' ---------------------------------------------- ' report the arraylist content after cleanup ' ---------------------------------------------- If reportlevel > 7 then Dim obj As [Object] For Each obj In ListOfIDS If reportlevel > 7 Then theSession.ListingWindow.WriteLine("Function : CollectAllSAPIDS(): SAP ID Conform: " & obj) Next obj end if ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- CollectAllSAPIDS = 0 Catch ex As NXException CollectAllSAPIDS = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to check the SAP Material ID logic ' ------------------------------------------------------------------------------------------------------------ Function ChkSAPIDLogic(ByVal SAPIDstr As String) As Integer Try ' ------------------------------------------------ ' set initial check value ' ------------------------------------------------ Dim IDOK as boolean IDOK = True ' ------------------------------------------------ ' check length of string ' ------------------------------------------------ if len(SAPIDstr) <> 13 then IDOK = false ' ------------------------------------------------ ' check the 5. character ' ------------------------------------------------ if mid(SAPIDstr, 5, 1) <> "-" then IDOK = false ' ------------------------------------------------ ' check the 5. character ' ------------------------------------------------ if mid(SAPIDstr, 10, 1) <> "-" then IDOK = false ' ------------------------------------------------ ' check the first 4 digits ' ------------------------------------------------ Const digits As String = "0123456789" Dim i As Integer Dim chkstr as string chkstr = mid(SAPIDstr, 1, 4) Dim ContainsNumeric As Boolean ContainsNumeric = true For i = 1 To Len(chkstr) If Instr(digits,mid(chkstr, i, 1))<>0 Then 'theSession.ListingWindow.WriteLine("digit " & mid(chkstr, i, 1)) else 'theSession.ListingWindow.WriteLine(" non digit " & mid(chkstr, i, 1)) ContainsNumeric = false End If Next i If ContainsNumeric = False then IDOK = false ' ------------------------------------------------ ' check the second 4 digits ' ------------------------------------------------ chkstr = mid(SAPIDstr, 6, 4) ContainsNumeric = true For i = 1 To Len(chkstr) If Instr(digits,mid(chkstr, i, 1))<>0 Then 'theSession.ListingWindow.WriteLine("digit " & mid(chkstr, i, 1)) else 'theSession.ListingWindow.WriteLine(" non digit " & mid(chkstr, i, 1)) ContainsNumeric = false End If Next i If ContainsNumeric = False then IDOK = false ' ------------------------------------------------ ' check the second 4 digits ' ------------------------------------------------ chkstr = mid(SAPIDstr, 11, 3) ContainsNumeric = true For i = 1 To Len(chkstr) If Instr(digits,mid(chkstr, i, 1))<>0 Then 'theSession.ListingWindow.WriteLine("digit " & mid(chkstr, i, 1)) else 'theSession.ListingWindow.WriteLine(" non digit " & mid(chkstr, i, 1)) ContainsNumeric = false End If Next i If ContainsNumeric = False then IDOK = false ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- If IDOK = True ChkSAPIDLogic = 0 Else ChkSAPIDLogic = 1 end if Catch ex As NXException ChkSAPIDLogic = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to launch the SAP connection dialog ' ------------------------------------------------------------------------------------------------------------ Function SAPConnect(ByVal SAPsystem As String, ByVal SAPClient As String, ByVal SAPuser As String, ByVal SAPpass As String, ByVal SAPLANG As String) As integer Try ' ------------------------------------------------ ' setup connection object ' ------------------------------------------------ SapLogonCtrl = CreateObject("SAP.Logoncontrol.1") SapConnection = SapLogonCtrl.NewConnection SapConnection.System = SAPsystem SapConnection.Client = SAPClient SapConnection.User = SAPuser SapConnection.Password = SAPpass SapConnection.Language = SAPLANG ' ------------------------------------------------ ' start connection ' ------------------------------------------------ If SapConnection.Logon(0, FALSE) <> True Then return 1 End If ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- SAPConnect = 0 Catch ex As NXException SAPConnect = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to create an SAP internal ID ' ------------------------------------------------------------------------------------------------------------ Function ID2SAP(ByVal ID As String) As string Try ' ------------------------------------------------ ' setup temp strings ' ------------------------------------------------ Dim SAPint as string Dim SAPintPre as string SAPintPre = "0000000" ' ------------------------------------------------ ' build SAP internal ID ' ------------------------------------------------ SAPint = SAPintPre & mid(ID, 1, 4) & mid(ID, 6, 4) & mid(ID, 11, 3) ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- ID2SAP = SAPint Catch ex As NXException ID2SAP = "No SAP ID coneverting possible" End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to create an normal ID from a SAP internal ID ' ------------------------------------------------------------------------------------------------------------ Function SAP2ID(ByVal SAPint As String) As string Try ' ------------------------------------------------ ' setup temp strings ' ------------------------------------------------ Dim ID as string ' ------------------------------------------------ ' build SAP internal ID ' ------------------------------------------------ ID = mid(SAPint, 8, 4) & "-" & mid(SAPint, 12, 4) & "-" & mid(SAPint, 16, 3) ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- SAP2ID = ID Catch ex As NXException SAP2ID = "No SAP ID coneverting possible" End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to get component attributes into array ' ------------------------------------------------------------------------------------------------------------ Function GetCompAttrib(ByRef comp as component, ByRef Attrib As String, ByRef ReturnValue as string) As integer Try ' ---------------------------------------------- ' dim temp variable ' ---------------------------------------------- Dim children As Component() Dim valuetmp as string Dim valuearraytmp(2) as string valuetmp ="" ' ---------------------------------------------- ' get Item ID and Revision ' ---------------------------------------------- if Attrib = "handle" then errcode = GetHandleByTag(comp.Tag, valuearraytmp) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function errcode: GetHandleByTag() = " & errcode) valuetmp = "HANDLE O-" valuetmp = valuetmp + valuearraytmp(1) ReturnValue = valuetmp Return 0 end if ' ---------------------------------------------- ' get schilds quantity ' ---------------------------------------------- if Attrib = "childs" then children = comp.GetChildren() ReturnValue = ubound(children) + 1 Return 0 end if ' ---------------------------------------------- ' get suppressed status ' ---------------------------------------------- if Attrib = "Suppressed" then if comp.IsSuppressed = True then valuetmp = "1" else valuetmp ="" end if ReturnValue = valuetmp Return 0 end if ' ---------------------------------------------- ' get the component name ' ---------------------------------------------- if Attrib = "Name" then valuetmp = comp.Name ReturnValue = valuetmp Return 0 end if ' ---------------------------------------------- ' get NX BOM CALLOUT ' ---------------------------------------------- if attribchkComp(comp, Attrib) = True then valuetmp = comp.GetStringAttribute(Attrib) else valuetmp ="" end if ReturnValue = valuetmp ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- GetCompAttrib = 0 Catch ex As NXException GetCompAttrib = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to check if an attribute in an other component ' ------------------------------------------------------------------------------------------------------------ Function attribchkComp(ByRef comp as component, ByVal name As String) As Boolean Try Dim tempval As String tempval = comp.GetStringAttribute(name) ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- attribchkComp = True Catch ex As NXException attribchkComp = False End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' Highlight by tag and make visible (unblank) ' ------------------------------------------------------------------------------------------------------------ Function SetVisibilityByTag(ByRef tag As Tag, ByVal Highlight as boolean, ByVal HighlightMode as integer, ByVal UnBlank as boolean, ByVal UnBlankMode as integer, ByVal CompColor as Boolean, ByVal CompColorValue as integer, ByVal Trans as Boolean, ByVal TransValue as integer) As Integer Try ' ------------------------------------------------ ' collect inidivual component ' ------------------------------------------------ Dim objlist(0) As DisplayableObject Dim objlist2(0) As DisplayableObject Dim obj As DisplayableObject obj = CType(NXObjectManager.Get(tag), DisplayableObject) ' ------------------------------------------------ ' Manage Highlight visibility ' ------------------------------------------------ if Highlight = True then If HighlightMode = 1 then obj.Highlight() end if If HighlightMode = 0 then obj.Unhighlight() end if end if ' ------------------------------------------------ ' Manage UnBlank visibility ' ------------------------------------------------ if UnBlank = True then If UnBlankMode = 1 then obj.Unblank() end if If UnBlankMode = 0 then obj.Blank() end if end if ' ------------------------------------------------ ' Manage color assignment ' ------------------------------------------------ dim handle as string dim file_data as string dim sub_file_id as long dim version as long handle = ufs.Tag.AskHandleOfTag(obj.Tag) ufs.Tag.DecomposeHandle(handle, file_data, sub_file_id, version) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : SetVisibilityByTag() - DisplayableObject Handle = " & file_data & " <> " & sub_file_id & " <> " & version) if CompColor = True then Dim displayModification As DisplayModification displayModification = theSession.DisplayManager.NewDisplayModification() displayModification.ApplyToAllFaces = False displayModification.NewColor = CompColorValue objlist(0) = obj displayModification.Apply(objlist) end if ' ------------------------------------------------ ' Manage transparency assignment ' ------------------------------------------------ if Trans = True then Dim displayModification2 As DisplayModification displayModification2 = theSession.DisplayManager.NewDisplayModification() displayModification2.ApplyToAllFaces = False displayModification2.NewTranslucency = TransValue objlist2(0) = obj displayModification2.Apply(objlist2) end if ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- SetVisibilityByTag = 0 Catch ex As NXException SetVisibilityByTag = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to get the session handle information ' ------------------------------------------------------------------------------------------------------------ Function GetHandleByTag(ByRef tag As Tag, ByRef handlestr() as string) As Integer Try ' ------------------------------------------------ ' get readable handle information ' ------------------------------------------------ dim handle as string handle = ufs.Tag.AskHandleOfTag(tag) ' ------------------------------------------------ ' write handle into array ' ------------------------------------------------ ufs.Tag.DecomposeHandle(handle, handlestr(0), handlestr(1), handlestr(2)) ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- GetHandleByTag = 0 Catch ex As NXException GetHandleByTag = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to drill down the entire assembly structure ' ------------------------------------------------------------------------------------------------------------ Function CollectAssemblyTree(ByVal c As Component, ByVal Level as integer, ByVal leafTree As String, ByVal parenthandle as string) As Integer Try ' ------------------------------------------------ ' collect inidivual component ' ------------------------------------------------ Dim handle as string handle = "" Dim children As Component() = c.GetChildren() Dim newLeafName As String For Each child As Component In children ' Store parent handle string CompParent.add(parenthandle) ' Create leafname If leafTree.Length = 0 Then newLeafName = Level & ":" & child.Name Else newLeafName = Level & ":" & leafTree & "/" & child.Name End If If reportlevel > 8 Then theSession.ListingWindow.WriteLine("Function : CollectAssemblyTree() - BOM = " & newLeafName) ' ---------------------------------------------- ' store item ID ' ---------------------------------------------- 'CompIndiv.add(child.GetStringAttribute("SAP_MM_MATERIAL_ID")) CompIndiv.add(child) CompLevel.add(Convert.ToString(Level)) ' ---------------------------------------------- ' start transversal ' ---------------------------------------------- errcode = GetCompAttrib(child, "handle", handle) ' Limit Traversal analysis if Level < BOMTraverseLimit then errcode = CollectAssemblyTree(child, Level +1, newLeafName, handle) end if If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function errcode: CollectAssemblyTree() = " & errcode) Next ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- CollectAssemblyTree = 0 Catch ex As NXException CollectAssemblyTree = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to create an SAP internal ID ' ------------------------------------------------------------------------------------------------------------ Function GetEXCELawb(ByRef oXLS As Object, ByRef oXLSwb As Object) As integer Try ' ------------------------------------------------ ' get the open EXCEL application object ' ------------------------------------------------ oXLSwb = oXLS.ActiveWorkbook ' ---------------------------------------------- ' provide return code base on connection success ' ---------------------------------------------- if oXLSwb is Nothing then 'if oXLS = Nothing then GetEXCELawb = 1 else GetEXCELawb = 0 end if Catch ex As NXException GetEXCELawb = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to check if EXCEL application is running ' ------------------------------------------------------------------------------------------------------------ Function getArrayCol(ByRef array() As string, ByVal Field as string) As integer Try ' ------------------------------------------------ ' check for field in Array ' ------------------------------------------------ Dim colTarget as integer Dim colIDX as integer colTarget = - 1 for colIDX = 0 to ubound(array) if array(colIDX) = Field then colTarget = colIDX next colIDX ' ---------------------------------------------- ' provide return code base on connection success ' ---------------------------------------------- getArrayCol = colTarget Catch ex As NXException getArrayCol = -1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to check if EXCEL application is running ' ------------------------------------------------------------------------------------------------------------ Function ChkEXCELapp() As integer Try ' ------------------------------------------------ ' check for open EXCEL application ' ------------------------------------------------ Dim Process as Process If Process.GetProcessesByName("Excel").Length > 0 Then ChkEXCELapp = 0 Else ChkEXCELapp = 1 end if Catch ex As NXException ChkEXCELapp = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to delete and create a sheet ' ------------------------------------------------------------------------------------------------------------ Function FindEXCELSheet(ByRef workbook as object, ByRef sheet as object, ByVal sheetname as string, ByRef sheetexists as boolean) As integer Try ' ------------------------------------------------ ' create EXCEL objects ' ------------------------------------------------ Dim sheetfound as boolean Dim sheetcollection as object Dim sheettemp as object sheetcollection = workbook.Sheets ' ------------------------------------------------ ' check all existing EXCEL sheets ' ------------------------------------------------ sheetfound = false for each sheettemp in sheetcollection if sheettemp.name = sheetname then sheetfound = true sheet = workbook.Sheets(sheetname) end if next sheettemp ' ------------------------------------------------ ' provide return code and object ' ------------------------------------------------ sheetexists = sheetfound FindEXCELSheet = 0 Catch ex As NXException FindEXCELSheet = 1 End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to get the part of the Master component ' ------------------------------------------------------------------------------------------------------------ Function getMasterComponentPart(ByVal CompTag as NXOpen.Tag) As Part Try ' ---------------------------------------------- ' this application makes only sense if only one sheet exist per part file ' ---------------------------------------------- Dim theSession As Session theSession = Session.GetSession() Dim ufs As UFSession ufs = UFSession.GetUFSession() Dim CompMasterObject as Component Dim CompMasterPart as Part Dim CompMasterPartTag as NXOpen.Tag ' ---------------------------------------------- ' check if Master component is loaded ' ---------------------------------------------- If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - Start") CompMasterObject = NXObjectManager.Get(CompTag) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - Get Master Object") If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - DisplayName = " & CompMasterObject.DisplayName) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - IsSuppressed = " & CompMasterObject.IsSuppressed) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - ReferenceSet = " & CompMasterObject.ReferenceSet) ' ---------------------------------------------- ' check load status of Master component and get part if load ' ---------------------------------------------- CompMasterPartTag = NXOpen.Tag.Null CompMasterPartTag = ufs.Assem.AskPrototypeOfOcc(CompTag) If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - Get Master Part Tag") if CompMasterPartTag = NXOpen.Tag.Null then CompMasterLoaded = false else CompMasterLoaded = true CompMasterPart = CompMasterObject.Prototype If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - Get Master Part") end if If reportlevel > 9 Then theSession.ListingWindow.WriteLine("Function : getMasterComponentPart() - CompMasterLoaded = " & CompMasterLoaded) ' ---------------------------------------------- ' provide return errorcode ' ---------------------------------------------- if CompMasterLoaded = False then getMasterComponentPart = Nothing else getMasterComponentPart = CompMasterPart end if Catch ex As Exception getMasterComponentPart = Nothing End Try End Function ' ------------------------------------------------------------------------------------------------------------ ' international properties for EXCEL objects (especially formula) ' ------------------------------------------------------------------------------------------------------------ Function SetPropertyInternational( ByVal target As Object, ByVal name As String, ByVal ParamArray parameters() As Object) As Object Return target.GetType.InvokeMember(name, Reflection.BindingFlags.Instance Or Reflection.BindingFlags.SetProperty, Nothing, target, parameters, System.Globalization.CultureInfo.GetCultureInfo(1033)) End Function ' ------------------------------------------------------------------------------------------------------------ ' This sub function is called to setup intial values ' ------------------------------------------------------------------------------------------------------------ Function setup() As Integer Try ' ------------------------------------------------ ' initial environment setup ' ------------------------------------------------ env_UGS_SHR_DIR = Environment.GetEnvironmentVariable("UGS_SHR_DIR") ' ------------------------------------------------ ' general action mode ' ------------------------------------------------ actionmode = 0 ' 0 = Seletc by EXCEL ' 1 = Reverse all ' 2 = write to EXCEL ' ------------------------------------------------ ' define the component color ' ------------------------------------------------ CompMark = false CompMarkColor = 186 CompMarkColor = 35 ' ------------------------------------------------ ' define the component transaparency ' ------------------------------------------------ CompMarkTransp = false CompMarkTranspValue = 75 ' ---------------------------------------------- ' set attribute array header ' ---------------------------------------------- CompAttrib(0) = "Level" CompAttrib(1) = "Level2" CompAttrib(2) = "parenthandle" CompAttribValTextSize(2) = 5 CompAttribColWidth(2) = 2 CompAttrib(3) = "handle" CompAttribValTextSize(3) = 5 CompAttribColWidth(3) = 2 CompAttribColColor(3) = 1 CompAttrib(4) = "childs" CompAttrib(5) = "CALLOUT" CompAttribTitle(5) = "sync=CALLOUT" CompAttribTitle2(5) = "attrib=CALLOUT" CompAttribColWidth(5) = 4 CompAttrib(6) = "PLME_POSTYPE" CompAttribTitle(6) = "sync=PLME_POSTYPE" CompAttribTitle2(6) = "attrib=PLME_POSTYPE" CompAttribDataValidation(6) = "D*I*J*K*N*R*T*X*Y*Z" CompAttribComment(6)= "Controls the Position type inside SAP" CompAttribColWidth(6) = 2 CompAttrib(7) = "PLME_CUST1" CompAttribTitle(7) = "sync=PLME_CUST1" CompAttribTitle2(7) = "attrib=PLME_CUST1" CompAttribDataValidation(7) = "0*1*2*3*4*5*6*7*8*9" CompAttribColWidth(7) = 2 CompAttrib(8) = "PLME_CUST2" CompAttribTitle(8) = "sync=PLME_CUST2" CompAttribTitle2(8) = "attrib=PLME_CUST2" CompAttribDataValidation(8) = "0*9" CompAttribColWidth(8) = 2 CompAttrib(9) = "PLME_CUST3" CompAttribTitle(9) = "sync=PLME_CUST3" CompAttribTitle2(9) = "attrib=PLME_CUST3" CompAttribColWidth(9) = 2 CompAttrib(10) = "PLME_ALTQUANT" CompAttribTitle(10) = "sync=PLME_ALTQUANT" CompAttribTitle2(10) = "attrib=PLME_ALTQUANT" CompAttribColWidth(10) = 2 CompAttrib(11) = "DB_PART_NO" CompAttrib(12) = "DB_PART_REV" CompAttrib(13) = "Suppressed" CompAttribColWidth(13) = 2 CompAttrib(14) = "Thumbnail" CompAttribColWidth(14) = 4 CompAttrib(15) = "Name" CompAttrib(16) = "DB_REV_RELEASE_STATUS" CompAttribColWidth(16) = 4 CompAttrib(17) = "DB_REV_SPECIAL" CompAttribColWidth(17) = 4 CompAttrib(18) = "SAP_MM_MATERIAL_ID" CompAttrib(19) = "SAP_DM_DOCUMENT_ID" CompAttrib(20) = "SAP_MM_NAME_EN" CompAttrib(21) = "SAP_MM_NAME_DE" CompAttrib(22) = "SAP_MM_NAME_FR" CompAttrib(23) = "SAP_MM_SIZE_DIMENSION" ' ---------------------------------------------- ' set the columns, which have to be grouped ' ---------------------------------------------- GroupCols(0,0) = 2 GroupCols(0,1) = 5 GroupCols(1,0) = 15 GroupCols(1,1) = 16 GroupCols(2,0) = 22 GroupCols(2,1) = 23 ' ---------------------------------------------- ' set component selection mode ' ---------------------------------------------- CompSelMode = 1 ' 0 = Handle ' 1 = SAP_ID ' 2 = C0mponent Name ' 3 = ItemID CompSelModeSub = 0 ' 0 = SAP MM_MATERIAL_ID ' 1 = SAP DM_DOCUMENT_ID ' ---------------------------------------------- ' Set plant for SAP data by default ' ---------------------------------------------- SAPPlant(0) = "XXXX" ' ---------------------------------------------- ' Set the webdav home ' ---------------------------------------------- webdavhome = "" ' ---------------------------------------------- ' Required SAP data MARC part ' ---------------------------------------------- MARCSheetName = "Report SAP MARC" MARCFields(0) = "MATNR" MARCFields(1) = "WERKS" MARCFields(2) = "MMSTA" MARCFields(3) = "BESKZ" MARCFields(4) = "SOBSL" MARCTitles(0) = "Material" MARCTitles(1) = "Plnt" MARCTitles(2) = "MS" MARCTitles(3) = "ProcType" MARCTitles(4) = "SPT" MARCFormats(0) = "T" MARCFormats(1) = "T" MARCFormats(2) = "T" MARCFormats(3) = "T" MARCFormats(4) = "T" ' ---------------------------------------------- ' Required SAP data MBEW part ' ---------------------------------------------- MBEWSheetName = "Report SAP MBEW" MBEWFields(0) = "MATNR" MBEWFields(1) = "BWKEY" MBEWFields(2) = "VPRSV" MBEWFields(3) = "VERPR" MBEWFields(4) = "STPRS" MBEWFields(5) = "VMPEI" MBEWTitles(0) = "Material" MBEWTitles(1) = "ValA" MBEWTitles(2) = "Pr." MBEWTitles(3) = "MovAvgPrice" MBEWTitles(4) = "Standard price" MBEWTitles(5) = "PrUn" MBEWFormats(0) = "T" MBEWFormats(1) = "T" MBEWFormats(2) = "T" MBEWFormats(3) = "D" MBEWFormats(4) = "D" MBEWFormats(5) = "D" MARASheetName = "Report SAP MARA" MARAFields(0) = "MATNR" MARAFields(1) = "GROES" MARATitles(0) = "Material" MARATitles(1) = "Size Dimension" MARAFormats(0) = "T" MARAFormats(1) = "T" MAKTSheetName = "Report SAP MAKT" MAKTFields(0) = "MATNR" MAKTFields(1) = "SPRAS" MAKTFields(2) = "MAKTX" MAKTTitles(0) = "Material" MAKTTitles(1) = "Language" MAKTTitles(2) = "Material Description" MAKTFormats(0) = "T" MAKTFormats(1) = "T" MAKTFormats(2) = "T" ' ---------------------------------------------- ' additional EXCEL formular on the main sheet ' ---------------------------------------------- 'XLSform(0) = "=SVERWEIS(L3;MARC;3;FALSCH)" ' R[0]C[-6] is column offset to SAP_MM_ATERIAL_ID RefCol = -6 'XLSform(0) = "=VLOOKUP(N3,MARC,3,FALSE)" XLSform(0) = "=VLOOKUP(R[0]C["& RefCol &"],MARC,3,FALSE)" 'XLSform(0) = "=R[1]C[-4]" 'XLSform(1) = "=SVERWEIS(L3;MARC;4;FALSCH)" RefCol = -7 XLSform(1) = "=VLOOKUP(R[0]C[" & RefCol &"],MARC,4,FALSE)" 'XLSform(2) = "=SVERWEIS(L3;MARC;5;FALSCH)" RefCol = -8 XLSform(2) = "=VLOOKUP(R[0]C[" & RefCol &"],MARC,5,FALSE)" RefCol = -9 'XLSform(3) = "=WENN(SVERWEIS(L3;MBEW;3;FALSCH)= ""V"";(SVERWEIS(L3;MBEW;4;FALSCH)/SVERWEIS(L3;MBEW;6;FALSCH));(SVERWEIS(L3;MBEW;5;FALSCH)/SVERWEIS(L3;MBEW;6;FALSCH)))" 'XLSform(3) = "=IF(VLOOKUP(N3,MBEW,3,FALSE)=""v"",(VLOOKUP(N3,MBEW,4,FALSE)/VLOOKUP(N3,MBEW,6,FALSE)),(VLOOKUP(N3,MBEW,5,FALSE)/VLOOKUP(N3,MBEW,6,FALSE)))" XLSform(3) = "=IF(VLOOKUP(R[0]C[" & RefCol &"],MBEW,3,FALSE)=""v"",(VLOOKUP(R[0]C[" & RefCol &"],MBEW,4,FALSE)/VLOOKUP(R[0]C[" & RefCol &"],MBEW,6,FALSE)),(VLOOKUP(R[0]C[" & RefCol &"],MBEW,5,FALSE)/VLOOKUP(R[0]C[" & RefCol &"],MBEW,6,FALSE)))" 'XLSform(4) = "=WENN(B2= ""V"";""V angezogen"";""S angezogen""" 'XLSform(4) = "=SUMMEWENN(C:C;""="" & D3;U:U)" XLSform(4) = "=SUMIF(C:C,""="" & D3,V:V)" XLSform(4) = "=SUMIF(C[-26],""="" & R[0]C[-25],C[-1])" XLSform(5) = "=IF(LOOKUP(2,1/('Report SAP MAKT'!A:A & 'Report SAP MAKT'!B:B = N3 & ""E""), 'Report SAP MAKT'!C:C)=O3,1,0)" XLSform(6) = "=IF(LOOKUP(2,1/('Report SAP MAKT'!A:A & 'Report SAP MAKT'!B:B = N3 & ""D""), 'Report SAP MAKT'!C:C)=P3,1,0)" XLSformType(0) = "R" XLSformType(1) = "R" XLSformType(2) = "R" XLSformType(3) = "R" XLSformType(4) = "R" XLSformType(5) = "I" XLSformType(6) = "I" XLSformTitle(0) = "Plant specific status" XLSformTitle(1) = "Procurement" XLSformTitle(2) = "Special Procurement" XLSformTitle(3) = "SAP Cost" XLSformTitle(4) = "Component Cost (estimated)" XLSformTitle(5) = "SAP Name EN OK" XLSformTitle(6) = "SAP Name EN OK" XLSformSheet(0) = "NX CAD BOM" XLSformSheet(1) = "NX CAD BOM" XLSformSheet(2) = "NX CAD BOM" XLSformSheet(3) = "NX CAD BOM" XLSformSheet(4) = "NX CAD BOM" XLSformSheet(5) = "NX CAD BOM" XLSformSheet(6) = "NX CAD BOM" XLSformRangeLeft(0) = "MAIN" XLSformRangeLeft(1) = "MAIN" XLSformRangeLeft(2) = "MAIN" XLSformRangeLeft(3) = "MAIN" XLSformRangeLeft(4) = "MAIN" XLSformRangeLeft(5) = "MAIN" XLSformRangeLeft(6) = "MAIN" XLSformColOffset(0) = 1 XLSformColOffset(1) = 2 XLSformColOffset(2) = 3 XLSformColOffset(3) = 4 XLSformColOffset(4) = 5 XLSformColOffset(5) = 6 XLSformColOffset(6) = 7 XLSformExt(0) = False XLSformExt(1) = False XLSformExt(2) = False XLSformExt(3) = False XLSformExt(4) = False XLSformExt(5) = true XLSformExt(6) = true XLSformExtended = False MainRowStart = 5 ' ---------------------------------------------- ' Do not start SAP related actions ' ---------------------------------------------- ByPassSAP = false SAPReportAmount = 1 BOMTraverseLimit = 100 ' ---------------------------------------------- ' Override Component attributes instead of changing colors or hid and unhide components ' ---------------------------------------------- AttribMode= false ' ---------------------------------------------- ' Set report level of script ' ---------------------------------------------- reportlevel = 0 ' 0 = No reports ' 2 = fully detailed reports Messages = True ' ---------------------------------------------- ' needed to revers highlight ' ---------------------------------------------- ' ---------------------------------------------- ' provide return code ' ---------------------------------------------- setup = 0 Catch ex As NXException setup = 1 End Try End Function End Module