fehlende bibliotheken
08.10.2007 15:45:23
schnierle
ich hab mal eine allgemeine Frage. Ich habe mit eurer Hilfe ein kleines Programm erstellt. In diesem Programm kann man unter anderm aus der Tabelle3 Objekte in Tabelle1 einfügen. Bei mir klappt das auch wunderbar, nur habe ich es jetzt an einem anderen Laptop getestet und nun bekomme ich die Fehlermeldung, dass Befehle nicht ausgeführt werden können weil Bibliotheken fehlen. Unten mal der Code. Ist da drin irgendetwas, was nicht standardmäßig in excel dabei ist?
Meine Vermutung ist, dass er den format-befehl nicht kennt. den benutze ich, um die eingefügten objekte zu nummerieren.
Danke schon mal
Sub ObjekteEinfügen()
Application.ScreenUpdating = False
password = "MlfBTest"
Dim zeile As Long, anzahl As Integer, n As Integer
Dim wksBilder As Worksheet, wksziel As Worksheet, wksListe As Worksheet
Dim BildNeu As Shape, Bild As Shape, zelle As Range
Dim BilderproZeile%, BildAbstand%, BildSpalte1%, BildZeile1%, BildSpalte%, BildZeile%
Set wksListe = Worksheets("Stückliste")
Set wksziel = Worksheets("Schaltplan")
Set wksBilder = Worksheets("Tabelle3")
Sheets("Stückliste").Unprotect (password)
Sheets("Schaltplan").Activate
Sheets("Schaltplan").Unprotect (password)
Sheets("Schaltplan").Shapes("Schaltfläche 1").Select
If Selection.Characters.Text "1.Leitungen zeichnen aktivieren" Then
Selection.Characters.Text = "1.Leitungen zeichnen aktivieren"
Selection.Characters(Start:=1, Length:=31).Font.ColorIndex = 0
End If
dPosTop1 = 0
bAktiv = False
BilderproZeile = 5
BildAbstand = 3 'ZeilenAbstand zwischen Bildern
BildZeile1 = 1 '1. Zeile in die ein Bild eingefügt werden soll
BildSpalte1 = 1 '1. Spalte in die ein Bild eingefügt werden soll
BildZeile = BildZeile1
BildSpalte = BildSpalte1
wksListe.Activate
On Error GoTo Fehler
With wksListe
For zeile = 2 To 14 '.Cells(.Rows.count, 2).End(xlUp).Row 'letzte Zeile, in der _
eine Beschreibung steht
anzahl = .Cells(zeile, 1).Value
If anzahl > 0 Then
Set Bild = wksBilder.Shapes("Group_" & .Cells(zeile, 2))
GoTo weiter01
With wksBilder
Select Case zeile
Case 2
Set Bild = .Shapes("Group_CU310")
Case 3
Set Bild = .Shapes("Group_CU320")
Case 4
Set Bild = .Shapes("Group_SimotionD")
Case 5
Set Bild = .Shapes("Group_Einspeisung")
Case 6
Set Bild = .Shapes("Group_SMM")
Case 7
Set Bild = .Shapes("Group_DMM")
Case 8
Set Bild = .Shapes("Group_Motor")
Case 9
Set Bild = .Shapes("Group_SMC")
Case 10
Set Bild = .Shapes("Group_TM")
Case 11
Set Bild = .Shapes("Group_CUA31")
Case 12
Set Bild = .Shapes("Group_DMC")
Case 13
Set Bild = .Shapes("Group_Kupplung")
Case 14
Set Bild = .Shapes("Group_Durchführung")
Case Else
MsgBox "Für Zeile fehlt noch eine Case-Anweisung" 'Testzeile
End Select
End With
weiter01: If Not Bild Is Nothing Then
Bild.Copy
For n = 1 To anzahl
Set zelle = .Cells(BildZeile, BildSpalte) 'Einfügezelle für Bild
zelle.Select
Worksheets("Schaltplan").Unprotect (password)
wksziel.Paste
'Bild umbenennen und positionieren
Set BildNeu = wksziel.Shapes(wksziel.Shapes.count)
With BildNeu
.name = wksListe.Cells(zeile, 2).Value & "_" _
& Format(wksListe.Cells(zeile, 3) + 1, "00")
.Top = zelle.Top
.Left = zelle.Left
End With
'Zählnummer für Bild erhöhen
wksListe.Cells(zeile, 3) = wksListe.Cells(zeile, 3) + 1
'Position fürs nächste Bild
BildSpalte = BildSpalte + 1
If (BildSpalte = 5) Then ' BilderproZeile
BildSpalte = BildSpalte1
BildZeile = BildZeile + BildAbstand
End If
Next n
Set Bild = Nothing
End If
End If
Next zeile
If zeile = 15 Then GoTo Beenden
zelle.Select
End With
Worksheets("Schaltplan").Protect (password)
wksListe.Activate
GoTo Beenden
Fehler: MsgBox "Fehler Nr: " & Err.Number & " ist aufgetreten" & vbLf & vbLf & Err.Description _
_
_
& "Fehler vemutlich beim Einfügen von Bild für " & ActiveSheet.Cells(zeile, 2) & " in _
_
Zeile " _
& zeile
Beenden:
ActiveSheet.Range("a2:a14").Select
Selection.Value = ""
ActiveSheet.Range("A2").Select
Set wksziel = Nothing
Set wksBilder = Nothing
Set wksListe = Nothing
Set Bild = Nothing
Set zelle = Nothing
Set BildNeu = Nothing
Worksheets("Schaltplan").Unprotect (password)
Sheets("Schaltplan").Select
ActiveSheet.Range("A1:K27").Select
End Sub