Sourcecode: Activity Relationship Diagramme
Hier finden Sie das Plus an Quellcode zum Artikel Systematische Layoutplanung: Der Weg zum optimalen Fabriklayout mit dem Activity Relationship Diagram.
Option Explicit
'Eigene Typen definieren
Type DepartmentInsertType
department As String
description As String
insertStep As Integer
End Type
Type RatingLineStyleType
weight As Double
color As Long
End Type
'Modulvariablen definieren
Dim step As Integer
Dim stepCaption As Variant
Dim departments() As DepartmentInsertType
Dim listRatings() As RatingType
Dim ratingLineStyles(6) As RatingLineStyleType
'Aktion beim Klicken auf den Button "STARTEN"
Sub StartActivityRelationshipDiagram()
If MsgBox("Neues Activity Relationship Diagramm starten und Anordnungoptimierung beginnen?", vbYesNoCancel, "Neues Activity Relationship Diagram") <> vbYes Then Exit Sub
'Vorbereitungen
step = 1
stepCaption = Array("", "Arbeitsplätze *A* einfügen", "Arbeitsplätze *E* einfügen", "Arbeitsplätze *X* einfügen", "Arbeitsplätze *I* einfügen", "Arbeitsplätze *O* einfügen", "Restliche Arbeitsplätze einfügen")
ActiveSheet.Buttons("ButtonNext").text = stepCaption(step)
Call CreateDepartmentRatingsList
'Definitionen für die Verbindungslinien mit Liniendicke und Linienfarbe für die Bewertungstypen
ratingLineStyles(1).weight = 10: ratingLineStyles(1).color = RGB(255, 0, 0) 'A
ratingLineStyles(2).weight = 6: ratingLineStyles(2).color = RGB(255, 192, 0) 'E
ratingLineStyles(3).weight = 3: ratingLineStyles(3).color = RGB(146, 208, 80) 'I
ratingLineStyles(4).weight = 2: ratingLineStyles(4).color = RGB(0, 112, 192) 'O
ratingLineStyles(5).weight = 1: ratingLineStyles(5).color = RGB(130, 130, 130) 'U
ratingLineStyles(6).weight = 8: ratingLineStyles(6).color = RGB(139, 90, 43) 'X
End Sub
'Aktion beim Klicken auf den Button "... einfügen"
Sub NextStepOfActivityRelationshipDiagram()
'nur weiter ausführen, wenn auch STARTEN angeklickt wurde
If step = 0 Then Exit Sub
'Arbeitsplätze entsprechenden dem "step" einfügen
Call InsertIntoLayout(step)
'nächster Schritt oder Abschluss der Methode
step = step + 1
If step > 6 Then
Call MsgBox("Alle Arbeitsplätze sind eingefügt. Das Activity Relationship Diagramm ist abgeschlossen und kann weiter optimiert werden.", vbOK, "Activity Relationship Diagramm")
step = 0
End If
'Neuen Text im Button anzeigen
ActiveSheet.Buttons("ButtonNext").text = stepCaption(step)
End Sub
'Auswertungsmatrix erstellen
Private Sub CreateDepartmentRatingsList()
Dim i As Integer
Dim j As Integer
Dim dc As Integer
Dim rc As Integer
Dim rt As RatingType
Dim r As Integer
Dim rtArr As Variant
'Reihenfolge der Einfügung in die Planungsumgebung, der erste Wert (0) bleibt leer und ohne Auswirkung
rtArr = Array("", "A", "E", "X", "I", "O")
'Arbeitsplätze ermitteln und Bezeichnungen einlesen in Array
dc = DepartmentsCount()
ReDim departments(dc)
For i = 1 To dc
departments(i).department = Sheets(SHEET_INPUT).Cells(i + ROW_INPUT_START - 1, COL_DEPARTMENT)
departments(i).description = Sheets(SHEET_INPUT).Cells(i + ROW_INPUT_START - 1, COL_DEPARTMENT + 1)
departments(i).insertStep = 6
Next
'Bewertungen einlesen
rc = RatingsCount()
ReDim listRatings(rc)
For i = 1 To rc
listRatings(i) = GetRating(i)
Next
'Einfügeschritt für jeden Arbeitsplatz ermitteln
For r = 1 To 5 'Reihenfolge AEXIO aus rtArr
For i = 1 To rc 'alle Bewertungen durchlaufen
If listRatings(i).type = rtArr(r) Then 'wenn Bewertungstyp übereinstimmt, dann
For j = 1 To dc 'alle Arbeitsplätze durchlaufen
If listRatings(i).department1 = departments(j).department Or listRatings(i).department2 = departments(j).department Then
'Arbeitsplatz stimmt, wenn dieser noch nicht eingefügt wurde, dann Schritt speichern
If departments(j).insertStep > r Then departments(j).insertStep = r
End If
Next
End If
Next
Next
End Sub
'Arbeitsplatz Shape mit Verbindungslinien-Shapes einfügen und verbinden
Private Sub InsertIntoLayout(insertStep As Integer)
Dim shp As Shape
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim top As Double
Dim left As Double
Dim rt As RatingType
Dim relationTo As String
Dim rc As Integer
Dim dc As Integer
Dim valid As Boolean
rc = RatingsCount()
dc = DepartmentsCount()
'Startpunkt für die ersten Einfügungen
top = 80
left = 100
'Arbeitsplatz-Shapes einfügen
For i = 1 To dc
'wenn der ermittelte Schritt des Arbeitsplatzes zum aktuellen Schritt passt, dann weiter
If departments(i).insertStep = insertStep Then
'falls das Arbeitsplatz Shape schon auf der Planungsumgebung vorhanden ist, dann dieses verwenden, sonst neu einfügen
If ShapeExists(ActiveSheet.name, "D-" & departments(i).department) = True Then
Set shp = ActiveSheet.Shapes("D-" & departments(i).department)
Else
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, left, top, 80, 60)
End If
left = left + shp.width * 1.2
'Code und Bezeichnung des Arbeitsplatzes einfügen im Shape Text und ein wenig formatieren
shp.TextFrame2.TextRange.Characters.text = departments(i).department & " " & departments(i).description
shp.name = "D-" & departments(i).department
shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
shp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
End If
Next
'Verbindungslinien einfügen
For i = 1 To dc 'alle Arbeitsplätze durchlaufen
'wenn der Arbeitsplatz zum aktuellen Schritt passt, dann
If departments(i).insertStep = insertStep Then
For j = 1 To rc 'alle Bewertungen durchlaufen und schauen, ob einer der Arbeitsplätze gleich ist
If departments(i).department = listRatings(j).department1 Or departments(i).department = listRatings(j).department2 Then
'den Gegenpart zum Arbeitsplatz finden und in der Variablen relationTo speichern
If departments(i).department = listRatings(j).department1 Then
relationTo = listRatings(j).department2
Else
relationTo = listRatings(j).department1
End If
'wenn es das Verbindungs-Shape schon gibt, dann dieses auswählen, sonst neu anlegen
If ShapeExists(ActiveSheet.name, "D-" & departments(i).department) = True And ShapeExists(ActiveSheet.name, "D-" & relationTo) = True Then
'beim Bewertungstype U oder keinem wird keine Linie gezeichnet
If Not (listRatings(j).type = "U" Or listRatings(j).type = "") Then 'für U oder unbewertet keine Verbindungslinien zeichnen
If ShapeExists(ActiveSheet.name, "R-" & departments(i).department & "-" & relationTo) = True Then
Set shp = ActiveSheet.Shapes("R-" & departments(i).department & "-" & relationTo)
Else
Set shp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 100, 100)
shp.name = "R-" & departments(i).department & "-" & relationTo
End If
'Verbindungspunkte festlegen, beim Rechteck 1=oben, 2=rechts, 3=unten, 4=links
shp.ConnectorFormat.BeginConnect ActiveSheet.Shapes("D-" & departments(i).department), 3
shp.ConnectorFormat.EndConnect ActiveSheet.Shapes("D-" & relationTo), 3
'Formatierung des Linien-Shapes nach den festgelegten Voreinstellungen
k = RatingSymbolPosition(listRatings(j).type) + 1
shp.Line.weight = ratingLineStyles(k).weight
shp.Line.ForeColor.RGB = ratingLineStyles(k).color
End If
End If
End If
Next
End If
Next
'Arbeitsplatz-Shapes in den Vordergrund bringen (so ist das Neuanordnen einfacher)
For i = 1 To dc
If departments(i).insertStep <= insertStep Then
ActiveSheet.Shapes("D-" & departments(i).department).ZOrder msoBringToFront
End If
Next
End Sub
Zurück zum Artikel Systematische Layoutplanung: Der Weg zum optimalen Fabriklayout mit dem Activity Relationship Diagram
Der Sourcecode basiert auf dem ARC-Generator. Um zu funktionieren, muss er dort als Modul eingefügt werden. Mehr wird im obigen Artikel erklärt.