Office: Bilder exakt Positionieren

marshal · 20. Mai 2007

Hallo, ich brauche etwas Unterstützung bei der Positionierung von Bildern in einer Tabelle mit Hilfe von VBA.

Ziel:
Für eine technische Dokumentation muss ich Verschiedene Bauteile fotografieren, Einzelheiten nummerieren und dann in eine Tabelle übertragen.
Pro Bauteil habe ich also eine Seite mit Bild und Tabelle.

Mit VBA habe ich jetzt grob eine Eingabemaske erstellt, in der ich das Foto auswähle und in einem Image-Feld anzeigen kann. Per Button füge ich das Bild auch in die Excel-Tabelle ein. Der eigentliche Trick an der ganzen Geschichte ist eigentlich folgender. Ich möchte per Klick in das Image-Fenster und damit auf das Bild einen "AutoForm-Blockpfeil" auf das Bild in der Tabelle setzten.

Dazu lese ich beim Klick die Mauszeigerposition und die Position des Forms aus und rechne das ganze um, damit es in die Tabelle passt, allerdings läuft dabei noch etwas schief, da die Positionen der Pfeile einfach nicht hinkommen. Leider finde ich aber keinen Fehler mehr.
Es kann aber auch sein, dass ich da was komplett falsch mache.

Ich hoffe auf ein paar TIPS *Smilie

(Der code ist noch nicht schön *wink.gif* )

excel-sheet

Der Code:
Code:

Dim neuesBild As String
Dim mausval As Long
Dim mausposition As POINTAPI
Dim posix As Integer
Dim posiy As Integer

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type

Private Sub CommandButton1_Click()
'''''Öffnen Dialog'''''
neuesBild = Application.GetOpenFilename("Photos(*.jpg),*.jpg")
On Error GoTo abbruch

'''''Schaltflächen aktivieren'''''
If neuesBild "Falsch" Then
UserForm1.Image1.PictureSizeMode = fmPictureSizeModeZoom
UserForm1.Image1.PictureAlignment = fmPictureAlignmentTopLeft
UserForm1.Image1.Picture = LoadPicture(neuesBild)

End If

If neuesBild = "Falsch" Then
End If

abbruch:

End Sub

Private Sub CommandButton2_Click()
Dim tempx As Integer
Dim tempy As Integer

Range("a9").Select
With Selection
tempx = .Left
tempy = .Top
End With

ActiveSheet.Pictures.Insert(neuesBild).Select
With Selection
.Top = tempy
.Left = tempx
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 300
End With
End Sub

Private Sub Image1_Click()
Dim tempx As Integer
Dim tempy As Integer

mausval = GetCursorPos(mausposition)

posix = mausposition.x - UserForm1.Left
posiy = mausposition.y - UserForm1.Top

Range("a9").Select
With Selection
tempx = .Left
tempy = .Top
End With

ActiveSheet.Shapes.AddShape(msoShapeRightArrow, 0, 0, 50, 50).Select
With Selection
.Left = tempx + posix
.Top = tempy + posiy
End With

UserForm1.Label1.Caption = mausposition.x
UserForm1.Label2.Caption = mausposition.y
UserForm1.Label3.Caption = UserForm1.Left
UserForm1.Label4.Caption = UserForm1.Top
UserForm1.Label5.Caption = posix
UserForm1.Label6.Caption = posiy
UserForm1.Label7.Caption = tempx
UserForm1.Label8.Caption = tempy

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

anfj · 23. Mai 2007

hallo marshal,

ich hatte ein ähnliches problem. Auch ich habe markierungen in einem Bild generiert. Ich habe jedoch Mousedown und M-Up benutzt um die Richtung des Pfeils vorzugeben. Der Code ermöglicht auch beim erneuten Klick auf den Pfeil die Löschung und beim Klick der rechten Mousetaste die Löschung aller Pfeile. Es erzeugt auch einen Kreis um den Startpunkt. Auffallen wird dir der Offset von 3.5 aber ohne den zeigt der Pfeil nicht auf die Spitze des Mauszeigers.
Zudem speicher ich ergebnisse auf dem Tabellenblatt was nicht sehr schön ist aber bei meinen Projekten leider unumgänglich. Ich hoffe der Code hilft bei deinem Problem.

Code:

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

ActiveSheet.Unprotect

If Button = 1 Then
X = X + Image1.Left - 3.5
Y = Y + Image1.Top - 3.5
ActiveSheet.Range("O2") = X
ActiveSheet.Range("O3") = Y
ActiveSheet.Shapes.AddShape(msoShapeOval, X, Y, 7#, 7).Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 1
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.BackColor.RGB = RGB(0, 255, 0)
Selection.OnAction = "Makro1"
Else
For Each Shape In ActiveSheet.Shapes
If Shape.Type = 1 Then
Shape.Delete
End If
Next
End If

ActiveSheet.Protect UserInterfaceOnly:=True

End Sub

Private Sub Image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

ActiveSheet.Unprotect

If ActiveSheet.Range("O1") = "ja" Then
If Button = 1 Then
X = X + Image1.Left
Y = Y + Image1.Top
zielx = ActiveSheet.Range("O2") + 3.5
ziely = ActiveSheet.Range("O3") + 3.5

ActiveSheet.Shapes.AddLine(X, Y, zielx, ziely).Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium
Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium
Selection.ShapeRange.Flip msoFlipHorizontal
Selection.ShapeRange.Flip msoFlipVertical
Selection.OnAction = "Makro1"
Else
For Each Shape In ActiveSheet.Shapes
If Shape.Type = 9 Then
Shape.Select
Selection.Delete
End If
Next
End If
End If

ActiveSheet.Protect UserInterfaceOnly:=True

End Sub

Sub Makro1()

ActiveSheet.Unprotect

ActiveSheet.Shapes(Parent.Caller).Select

Selection.Delete

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruß anfj

P.S.: Auch ich leide unter meinem spagetti code !

anfj · 23. Mai 2007

Nachtrag

Die Pfeillänge kann durch festhalten der linken Maustaste bestimmt werden.
Jedoch ziehe nicht über den Bildrahmen hinaus da dies ein anderes event auslöst und mit diesem Code nicht abgefangen wird, passiert unvohergesehenes. -> Excel verabschiedet sich bei mir komplett !

marshal · 23. Mai 2007

Ich hab jetzt den gemeinen Excel-Trick geschnallt.

Excel rechnet intern nicht in Pixel, die Mausposition die ich auslese ist aber in Pixel.
Ein bisschen Rumrechnen und es läuft schon mal nen Schritt weiter. Bin mal aufs nächste Problem gespannt

Office: Bilder exakt Positionieren

Bilder exakt Positionieren

Bilder exakt Positionieren

Bilder exakt Positionieren

Bilder exakt Positionieren - Similar Threads - Bilder exakt Positionieren

Feste Verankerung eines Bildes in Kopfzeile lösen

Bilder über VBA Größe und DPI ändern für Webshop

Seitenzahlen sind komplett verschoben....

Bilder lassen sich nicht verschieben

VBA Summe bilden

Excel Range als Bild in Word einfügen

Bilder in einer HTML Mail werden mit Unterstrich angezeigt