AW: Bilder positionieren & beschriften
03.03.2007 17:02:00
Veit
Hallo, ich nochmal.
Vielleicht fällt es ja leichter meinen Fehler zu finden, wenn Ihr "ihn" seht...
Ich habe den betreffenden Code hier mal ausgegliedert, so dass er auch in einem Modul funktioniert... naja bis zum Fehler eben.
Sub cmb_print_Click()
Dim wb1 As Workbook
Dim ws1 As Worksheet
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Worksheets("Tabelle2")
'pfad='Pfad zum Bilderverzeichnis (Achtung: letztes Zeichen "\")
'wort='name des Bildes ohne Dateiendung
pfad = "J:\Dieter\Bilder\"
wort = "ab"
'normalerweise sind das viele verschieden Bilder, aber damit Ihr das besser testen könnt
'geht es hier mit dem gleichen Bild 30 x hintereinander
zaehler = 1
ersteswort = True
bildbreite = 150
bildhoehe = 214
Do While zaehler < 30
If Dir(pfad & wort & ".jpg") <> "" Then
If ersteswort = True Then
On Error GoTo neues_workbook
ActiveWorkbook.Sheets.Add before:=ActiveWorkbook.Sheets(1)
GoTo weiter
neues_workbook:
Application.Workbooks.Add
weiter:
On Error GoTo 0
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets(1)
ws1.Name = "Druckausgabe " & wb1.Worksheets.Count
ws1.Cells.ColumnWidth = 1
ws1.Cells.RowHeight = 10
'Kontrolle der maximalen Breite der seite
'Testobjekt schrittweise solange breiter machen bis es einen Seitenumbruch gibt
'das habe ich noch nicht gemacht... aus vielleicht verständlichen Gründen ;-) :-(
'Bild einfügen
ws1.Pictures.Insert(pfad & wort & ".jpg").ShapeRange.Name = "Bild_" & zaehler
Set objPicture = ws1.Shapes("Bild_" & zaehler)
'(?)Breite und Höhe festlegen (?)
'da die Bilder unterschiedliche Abmessungen haben, bringe ich die hier auf gleiche Größe
'normalerweise wird das berechnet, um die Seitenverhältnisse zu behalten. Hier habe ich das _
rausgenommen
objPicture.Width = bildbreite
objPicture.Height = bildhoehe
'nächste Position (left/top) ermitteln
spalte = ws1.Shapes(zaehler).Left + objPicture.Width
zeile = ws1.Shapes(zaehler).Top '+ objPicture.Height
'text (wenn Text gewünscht) rein
'If opt_ja.Value = True Then
ws1.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 10, 10).Name = "Bescheibung_" _
& _
zaehler
'Set objTextbox = ws1.Shapes("Bescheibung_" & zaehler)
ws1.Shapes("Bescheibung_" & zaehler).Select
With Selection
.Text = wort
.HorizontalAlignment = xlCenter
.AutoSize = True
.ShapeRange.ZOrder msoBringToFront
.ShapeRange.Left = (objPicture.Left + (objPicture.Width / 2)) - .Width / 2
.ShapeRange.Top = objPicture.Top + objPicture.Height - .Height
End With
'End If
ersteswort = False
Else
ws1.Cells(1, 1).Select
ws1.Pictures.Insert(pfad & wort & ".jpg").ShapeRange.Name = "Bild_" & zaehler
'Set objPicture = ws1.Shapes("Bild_" & zaehler)'das funktioniert überhaupt nicht, deshalb das _
SELECT
ws1.Shapes("Bild_" & zaehler).Select
'(?)Breite und Höhe festlegen (?)
Selection.Width = bildbreite
Selection.Height = bildhoehe
'vorläufige Position festlegen
Selection.Left = spalte
Selection.Top = zeile
'Test ob es einen Seitenumbruch gibt
'Leider kann ich auf diese Art nur die erste "Seitenspalte" bis runter nutzen
'das sollte zwar eigentlich reichen (die Anzahl der Bilder wäre auch schon enorm) aber es ist _
eben nicht _
perfekt
cFull = 0
For Each pbv In ws1.VPageBreaks
If pbv.Extent = xlPageBreakFull Then cFull = cFull + 1
Next
If cFull > 0 Then 'wenn rechts eine neue Seite begonnen wurde
zeile = zeile + bildhoehe
Selection.Top = zeile
Selection.Left = ws1.Shapes("Bild_1").Left
cFull = 0
ws1.Cells(1, 1).Select
'For Each pbh In ws1.HPageBreaks
' If pbh.Extent = xlPageBreakFull Then cFull = cFull + 1
'Next
If seitenumbruchzaehler <> ws1.HPageBreaks.Count Then
seitenumbruchzaehler = ws1.HPageBreaks.Count
'!!!!!!!!!!!!!!!!!!!Hier kommt der Fehler!!!!!!!!!!!!! und ich habe keine Ahnung warum
zellenzeile = ws1.HPageBreaks(seitenumbruchzaehler).Location.Row - 1
ws1.Shapes("Bild_" & zaehler).Select
Selection.Delete
ws1.Cells(zellenzeile + 1, 1).Select
ws1.Pictures.Insert(pfad & wort & ".jpg").ShapeRange.Name = "Bild_" & zaehler
ws1.Shapes("Bild_" & zaehler).Select
zeile = Selection.Top '+ bildhoehe
End If
End If
ws1.Shapes("Bild_" & zaehler).Select
spalte = Selection.Left + Selection.Width
oben = Selection.Top
hoehe = Selection.Height
Links = Selection.Left
breite = Selection.Width
ws1.Cells(1, 1).Select
'If opt_ja.Value = True Then 'das ist ein Optionsbutton, falls man sich die Bezeichnung nicht _
anzeigen lassen _
möchte
ws1.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 10, 10).Name = "Bescheibung_" _
& _
zaehler
'wieder die Sache, dass das mit dem benannten Objekt nicht funktioniert
'Set objTextbox = ws1.Shapes("Bescheibung_" & zaehler)
ws1.Shapes("Bescheibung_" & zaehler).Select
With Selection
.Text = wort
.HorizontalAlignment = xlCenter
.AutoSize = True
.ShapeRange.ZOrder msoBringToFront
.ShapeRange.Left = (Links + (breite / 2)) - Selection.Width / 2
.ShapeRange.Top = oben + hoehe - Selection.Height
End With
'End If
End If
End If
Application.ScreenUpdating = True
zaehler = zaehler + 1
Loop
End Sub
Grüße und schon mal ein hoffnungsvolles Danke
Ein Veit