Hot News:

Mit Unterstützung durch:

  Foren auf CAD.de (alle Foren)
  E3.series
  Kabelliste Excel erweitern

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
Autor Thema:  Kabelliste Excel erweitern (528 mal gelesen)
Feuerblitz
Mitglied



Sehen Sie sich das Profil von Feuerblitz an!   Senden Sie eine Private Message an Feuerblitz  Schreiben Sie einen Gästebucheintrag für Feuerblitz

Beiträge: 29
Registriert: 07.10.2020

Solidworks 2012 Professional
Windows 10 Pro
E3 2018

erstellt am: 06. Nov. 2020 13:01    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo zusammen

Ich habe bei den Kabel in E3 Projekten einen variablen Text hinzugefügt, quasi als Kommentar zum Kabel. Ich würde diesen Text gerne beim Export in ein Excel Blatt mitausgeben lassen. Ich habe mal versucht den Code anzupassen:

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
' ----------------------------------------------------------------------------------------------



Könnt ihr mir helfen die Variable mit dem richtigen Text zu füllen? Ich wäre richtig froh drum.
Vielen Dank im Vorraus.

Feuerblitz

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz