Code:
' Cable List (Excel)
'
' Changes:
' 17.02.2000 CIM-Team Initial Version
' 27.07.2001 CIM-Team Including length information
' 26.07.2002 CIM-Team Added shield connections and multi language
' Only the first two shield symbols of each shield will be used
' 18.08.2004 CIM-Team Added control of internal/external execution
' 04.04.2005 CIM-Team Added portuguese strings
' 28.07.2005 CIM-Team added strings for chinese and russian
' 13.11.2006 CIM-Team [8b] Scout-1001: Changing of Messages Routine
' 12.03.2007 CIM-Team Added japanese version
' 10.10.2007 CIM-Team[rk] rewritten to use new methods
' 29.11.2007 CIM-Team[1rk] star-00017: Filename with extension _CAB
' 17.01.2008 CIM-Team [rk] sun-00223: for use in viewplus
' 10.04.2008 CIM-Team [2rk] sun-00703: numeric project names are displayed as ####
' 09.07.2009 CIM-Team Added Turkish Translation [jl]
' 15.03.2010 Zuken E3[rk] storm-02418: CIM-Team changed to Zuken
' 13.12.2010 Zuken E3[4rk] sam-01138: optimize write to excel
' 02.08.2013 Zuken E3[5S] slim-01918: wrong format
' 29.03.2017 Zuken E3[6ps] Spring-02530: Add columns for wireseals
'
' - EOH -
'... Option Explicit
' ---------------------------------------------------------------------------------------------------
' Global variables ( for customization )
' ---------------------------------------------------------------------------------------------------
' Trailer
Dim Trailer: Trailer = "***** Created by Zuken " & e3.GetName & " *****"
' ---------------------------------------------------------------------------------------------------
' Global Variables internal
' ---------------------------------------------------------------------------------------------------
Dim ExcelApp
Dim Excel, ExcelName
Dim txtCableList, txtCable, txtTyp, txtDevice, txtPin, txtConPin, txtCore, txtLength, txt_CAB, txtWireseal, txtvariableText
Dim startline, startcol, itemcnt, columnscnt, num, tmparr ' [4rk]
Dim xlContinuous, xlDiagonalDown, xlDiagonalUp
Dim xlEdgeBottom, xlEdgeLeft, xlEdgeRight, xlEdgeTop
Dim xlInsideHorizontal, xlInsideVertical, xlNone
Dim xlThin, xlThick, xlDouble, xlAutomatic, xlLandscape, xlCenter, xlLeft
xlContinuous = 1
xlDiagonalDown = 5
xlDiagonalUp = 6
xlEdgeBottom = 9
xlEdgeLeft = 7
xlEdgeRight = 10
xlEdgeTop = 8
xlInsideHorizontal = 12
xlInsideVertical = 11
xlNone = -4142
xlThin = 2
xlDouble = -4119
xlAutomatic = -4105
xlThick = 4
xlLandscape = 2
xlCenter = -4108
xlLeft = -4131
' ---------------------------------------------------------------------------------------------------
' InitColumnText
'
Sub InitColumnText
Select Case language
Case "01"
txtCableList = "Cable List:"
txtCable = "Cable"
txtTyp = "Type"
txtDevice = "Device Name"
txtPin = "Pin"
txtConPin = "Connector Pin Terminal"
txtCore = "Conductor"
txtLength = "Length (mm)"
txt_CAB = "_CAB"
txtWireseal = "Wireseal"
txtvariableText = "Text - variabel"
Case "44"
txtCableList = "Cable List:"
txtCable = "Cable"
txtTyp = "Type"
txtDevice = "Device Name"
txtPin = "Pin"
txtConPin = "Connector Pin Terminal"
txtCore = "Core"
txtLength = "Length (mm)"
txt_CAB = "_CAB"
txtWireseal = "Wireseal"
Case "49"
txtCableList = "Kabelliste:"
txtCable = "Kabel"
txtTyp = "Typ"
txtDevice = "Betriebsmittel"
txtPin = "Anschluss"
txtConPin = "Anschlagteil"
txtCore = "Ader"
txtLength = "Länge (mm)"
txt_CAB = "_KAB"
txtWireseal = "Einzeladerabdichtung"
txtvariableText = "Text - variabel"
Case "33"
txtCableList = "Liste des Câbles :"
txtCable = "Câble"
txtTyp = "Type"
txtDevice = "Nom d'appareil"
txtPin = "Broche"
txtConPin = "Pièce de raccordement"
txtCore = "Fil"
txtLength = "Longeur (mm)"
txt_CAB = "_CAB"
txtWireseal = "Wireseal"
Case "34"
txtCableList = "Lista de Mangueras:"
txtCable = "Manguera"
txtTyp = "Tipo"
txtDevice = "Nombre Dispositivo"
txtPin = "Pin"
txtConPin = "Pieza fijación"
txtCore = "Hilo"
txtLength = "Longitud (mm)"
txt_CAB = "_CAB"
txtWireseal = "Junta de Cable"
Case "39"
txtCableList = "Lista cavi:"
txtCable = "Cavo"
txtTyp = "Tipo"
txtDevice = "Sigla dispositivo"
txtPin = "Pin"
txtConPin = "Contatto"
txtCore = "conduttore"
txtLength = "Lunghezza (mm)"
txt_CAB = "_CAB"
txtWireseal = "Guarnizione Filo"
Case "55"
txtCableList = "Lista de Cabos:"
txtCable = "Cabo"
txtTyp = "Tipo"
txtDevice = "Nome de Dispositivo"
txtPin = "Pino"
txtConPin = "Terminal"
txtCore = "Condutor"
txtLength = "Comprimento (mm)"
txt_CAB = "_CABO"
txtWireseal = "Wireseal"
Case "07"
txtCableList = "Кабельный журнал:"
txtCable = "Кабель"
txtTyp = "Марка кабеля"
txtDevice = "Позиционное обозначение"
txtPin = "Вывод"
txtConPin = "Наконечник"
txtCore = "Жила"
txtLength = "Длина (мм)"
txt_CAB = "_CAB"
txtWireseal = "Wireseal"
Case "86"
txtCableList = "电缆列表:"
txtCable = "电缆"
txtTyp = "类型"
txtDevice = "设备名称"
txtPin = "针脚"
txtConPin = "路 "
txtCore = "芯线"
txtLength = "长度 (mm)"
txt_CAB = "_CAB"
txtWireseal = "Wireseal"
Case "90"
txtCableList = "Kablo Listesi:"
txtCable = "Kablo"
txtTyp = "Tip"
txtDevice = "Cihaz Adı"
txtPin = "Pin"
txtConPin = "Montaj Parçası"
txtCore = "Damar"
txtLength = "Uzunluk (mm)"
txt_CAB = "_KAB"
txtWireseal = "Wireseal"
Case "81"
txtCableList = "ケーブルリスト:"
txtCable = "ケーブル"
txtTyp = "タイプ"
txtDevice = "デバイス名"
txtPin = "ピン"
txtConPin = "取り付け部品"
txtCore = "コア"
txtLength = "長さ(mm)"
txt_CAB = "_CAB"
txtWireseal = "Wireseal"
Case else
txtCableList = "Cable List:"
txtCable = "Cable"
txtTyp = "Type"
txtDevice = "Device Name"
txtPin = "Pin"
txtConPin = "Connector Pin Terminal"
txtCore = "Core"
txtLength = "Length (mm)"
txt_CAB = "_CAB"
txtWireseal = "Wireseal"
End Select
End Sub
Sub OutputExcel ( list ) ' sorted list with Listelements
Dim nLine
Debug "OutputExcel started "
InitColumnText
CreateExcelSheet txtCore, txt_CAB ' [1rk]
nLine = 2
WriteTitle
' WriteListElements list, nLine ' [4rk] disabled
WriteListElementsArray list, nLine ' [4rk]
FinishExcelSheet nLine ' draw lines around the columns
nLine = nLine + 2
ExcelApp.Visible = True ' [4rk] open EXCEL
Excel.Range("A"&nLine&":E"&nLine).Select
ExcelApp.Selection.Font.Bold = True
ExcelApp.Selection.Font.Italic = True
ExcelApp.Selection.Font.ColorIndex = 3
Excel.Cells(nLine,2).Value = Trailer ' trailer
Excel.Range("A4").Select
ExcelApp.ActiveWindow.FreezePanes = True
Excel.Cells(1,1).Select
ExcelApp.ActiveWorkbook.SaveAs ExcelName
Set ExcelApp = Nothing
Set Excel = Nothing
End Sub
' [4rk] >
Function CountListElements ( list )
' loop for all Listelements
Dim e, le, c, cle, corlist
Dim i: i = 0
For Each e In list ' output listelements...
Set le = list(e)
i = i + 4 ' for each cable title 4 lines
Set corlist = le.Cores
i = i + corlist.Count
Next
CountListElements = i
End Function
Sub WriteListElementsArray ( list, line )
Dim e, le, c, cle, corlist
Dim cnt
Dim i: i = -1
Dim IsLimit: IsLimit = False
startline = line+2
startcol = 1
itemcnt = CountListElements ( list )
columnscnt = 10
num = 50000
If itemcnt < num Then
cnt = itemcnt
Else
cnt = num
End If
ReDim tmparr(cnt,columnscnt)
' loop for all Listelements
For Each e In list ' output listelements...
Set le = list(e)
line = line + 2
i = i+1 ' blank line between cables
If line >= excellimit - 5 Then
IsLimit = True
cnt = i
Exit For
End If
WriteCableHeaderArray tmparr, i
FinishCableHeaderArray line
i = RedimArray ( i, line, cnt )
line = line + 1
WriteCableArray tmparr, i, le
i = RedimArray ( i, line, cnt )
line = line + 1
WriteCoreHeaderArray tmparr, i
FinishCoreHeaderArray line
i = RedimArray ( i, line, cnt )
Set corlist = le.Cores
For Each c In corlist
Set cle = corlist(c)
line = line + 1
WriteCoreArray tmparr, i, cle
i = RedimArray ( i, line, cnt )
Next
Next
Excel.Range(Excel.Cells(startline, startcol), Excel.Cells(startline + cnt, columnscnt+startcol)).NumberFormat = "@" ' [5S]
Excel.Range(Excel.Cells(startline, startcol), Excel.Cells(startline + cnt, columnscnt+startcol)).value2 = tmparr
If IsLimit Then
line = line + 1
Excel.Cells(line,1).Value = GetExcelMessage ( excelmsglimit ) ' error
line = line + 1
message excelmsglimit, 1
End If
End Sub
Sub WriteCableHeaderArray ( arr, i )
arr(i,0) = ""
arr(i,1) = ""
arr(i,2) = ""
arr(i,4) = txtCable
arr(i,5) = txtTyp
arr(i,6) = ""
arr(i,7) = ""
arr(i,9) = txtLength
End Sub
Sub FinishCableHeaderArray ( line )
Excel.Range("A"&line&":J"&line).Select ' Define the size, color, font, ...
ExcelApp.Selection.Font.Bold = True
ExcelApp.Selection.Interior.ColorIndex = 44
ExcelApp.Selection.Interior.Pattern = 1
ExcelApp.Selection.Font.ColorIndex = 1
End Sub
Sub WriteCoreHeaderArray ( arr, i )
arr(i,0) = txtDevice
arr(i,1) = txtPin
arr(i,2) = txtConPin
arr(i,3) = txtWireseal
arr(i,4) = txtCore
arr(i,5) = txtDevice
arr(i,6) = txtPin
arr(i,7) = txtConPin
arr(i,8) = txtWireseal
arr(i,9) = txtLength
arr(i,11)=txtvariableText
End Sub
Sub FinishCoreHeaderArray ( line )
Excel.Range("A"&line&":J"&line).Select
ExcelApp.Selection.Font.Bold = True
ExcelApp.Selection.Interior.ColorIndex = 6
ExcelApp.Selection.Interior.Pattern = 1
ExcelApp.Selection.Font.ColorIndex = 1
End Sub
Sub WriteCableArray ( arr, i, cab )
arr(i,4) = "'" & cab.cablename
arr(i,5) = cab.cabletype
arr(i,9) = cab.length
End Sub
Sub WriteCoreArray ( arr, i, core )
arr(i,0) = "'" & core.dest1
arr(i,1) = core.dest1pin
arr(i,2) = core.FittingPart1
arr(i,3) = core.Wireseal1
arr(i,4) = core.corename
arr(i,5) = "'" & core.dest2
arr(i,6) = core.dest2pin
arr(i,7) = core.FittingPart2
arr(i,8) = core.Wireseal2
arr(i,9) = core.length
End Sub
Function RedimArray ( nr, line, ByRef cnt )
Dim ret
If nr < cnt Then
ret = nr+1
Else
ret = 0
Excel.Range(Excel.Cells(startline, startcol), Excel.Cells(startline + cnt, columnscnt+startcol)).value2 = tmparr
startline = startline + cnt +1
If itemcnt > num Then
itemcnt = itemcnt - num -1
End If
If itemcnt > num Then
If (line+num) < (excellimit-5) Then
cnt = num
Else
cnt = excellimit - line - 6
End If
Else
cnt = itemcnt
End If
ReDim tmparr(cnt,columnscnt)
End If
RedimArray = ret
End Function
' < [4rk]
Sub WriteTitle
Excel.Columns("A:J").Select ' Define the size, color, font, ...
ExcelApp.Selection.ColumnWidth = 14
ExcelApp.Selection.HorizontalAlignment = xlLeft
Excel.Columns("E").HorizontalAlignment = xlCenter
Excel.Range("E2").Select
ExcelApp.Selection.NumberFormat = "@" ' Text
ExcelApp.Selection.HorizontalAlignment = xlLeft
Excel.Range("A2:H2").Select ' Define head line
ExcelApp.Selection.Font.Size = 24
Excel.Cells(2,1).Value = txtCableList
Excel.Cells(2,4).Value = prj.GetName
End Sub
Sub WriteCableHeader ( line )
Excel.Range("A"&line&":J"&line).Select ' Define the size, color, font, ...
ExcelApp.Selection.Font.Bold = True
ExcelApp.Selection.Interior.ColorIndex = 44
ExcelApp.Selection.Interior.Pattern = 1
ExcelApp.Selection.Font.ColorIndex = 1
Excel.Cells(line,5).Value = txtCable ' Define head line
Excel.Cells(line,6).Value = txtTyp
Excel.Cells(line,10).Value = txtLength
End Sub
Sub WriteCoreHeader ( line )
Excel.Range("A"&line&":J"&line).Select ' Define the size, color, font, ...
ExcelApp.Selection.Font.Bold = True
ExcelApp.Selection.Interior.ColorIndex = 6
ExcelApp.Selection.Interior.Pattern = 1
ExcelApp.Selection.Font.ColorIndex = 1
Excel.Cells(line,1).Value = txtDevice ' Define head line
Excel.Cells(line,2).Value = txtPin
Excel.Cells(line,3).Value = txtConPin
Excel.Cells(line,4).Value = txtWireseal
Excel.Cells(line,5).Value = txtCore
Excel.Cells(line,6).Value = txtDevice
Excel.Cells(line,7).Value = txtPin
Excel.Cells(line,8).Value = txtConPin
Excel.Cells(line,9).Value = txtWireseal
Excel.Cells(line,10).Value = txtLength
excel.cells(line,11).value = txtvariableText
End Sub
Sub FinishExcelSheet ( line )
Excel.Range("A4:J"&line).Select ' draw lines around the columns
ExcelApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
ExcelApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
ExcelApp.Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlEdgeLeft).Weight = xlThin
ExcelApp.Selection.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
ExcelApp.Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlEdgeRight).Weight = xlThin
ExcelApp.Selection.Borders(xlEdgeRight).ColorIndex = xlAutomatic
ExcelApp.Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlEdgeTop).Weight = xlThin
ExcelApp.Selection.Borders(xlEdgeTop).ColorIndex = xlAutomatic
ExcelApp.Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlEdgeBottom).Weight = xlThin
ExcelApp.Selection.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
ExcelApp.Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlInsideHorizontal).Weight = xlThin
ExcelApp.Selection.Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
Excel.Range("B4:D"&line).Select
ExcelApp.Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlInsideVertical).Weight = xlThin
ExcelApp.Selection.Borders(xlInsideVertical).ColorIndex = xlAutomatic
Excel.Range("D4:F"&line).Select
ExcelApp.Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlInsideVertical).Weight = xlThick
ExcelApp.Selection.Borders(xlInsideVertical).ColorIndex = xlAutomatic
Excel.Range("G4:J"&line).Select
ExcelApp.Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
ExcelApp.Selection.Borders(xlInsideVertical).Weight = xlThin
ExcelApp.Selection.Borders(xlInsideVertical).ColorIndex = xlAutomatic
End Sub
' ---------------------------------------------------------------------------------------------------
' [4rk] disabled ----------------------------------------------------------------------------------------------
Sub WriteListElements ( list, line )
' loop for all Listelements
Dim e, le, c, cle, corlist
Dim GetLength
For Each e In list ' output listelements...
Set le = list(e)
line = line + 2
WriteCableHeader line
line = line + 1
WriteCable line, le
line = line + 1
WriteCoreHeader line
Set corlist = le.Cores
For Each c In corlist
Set cle = corlist(c)
line = line + 1
WriteDest1 line, cle
Excel.Cells(line,5).Value = cle.corename
WriteDest2 line, cle
Excel.Cells(line,10).Value = cle.length
Next
Next
End Sub
' [4rk] disabled ----------------------------------------------------------------------------------------------
Sub WriteCable( line, cab )
Excel.Cells(line,5).Value = "'" & cab.cablename
Excel.Cells(line,6).Value = cab.cabletype
Excel.Cells(line,10).Value = cab.length
End Sub
' [4rk] disabled ----------------------------------------------------------------------------------------------
Sub WriteDest1( line, dest )
Excel.Cells(line,1).Value = "'" & dest.dest1
Excel.Cells(line,2).Value = dest.dest1pin
Excel.Cells(line,3).Value = dest.FittingPart1
Excel.Cells(line,4).Value = dest.Wireseal1
End Sub
' [4rk] disabled ----------------------------------------------------------------------------------------------
Sub WriteDest2( line, dest )
Excel.Cells(line,6).Value = "'" & dest.dest2
Excel.Cells(line,7).Value = dest.dest2pin
Excel.Cells(line,8).Value = dest.FittingPart2
Excel.Cells(line,9).Value = dest.Wireseal2
End Sub
' ----------------------------------------------------------------------------------------------