AW: Grafik positionieren
21.09.2008 15:24:37
Hajo_Zi
Hallo Marco,
mit folgendem Code wird das Bild unter der Eingabezele eingefügt.
' ************************************************************* _
' Modul: Tabelle3 Typ = Element der Mappe(Sheet, Workbook, ...)
' **************************************************************
Option Explicit _
' Variablendefinition erforderlich
' Konstante für Ablagepfad Bilder
Const StPfad As String = "O:\Bilder\0001-1000\"
Private Sub _
Worksheet_Change(ByVal Target As Range)
'**************************************************
'* H. Ziplies *
'* 20.11.07 *
'* erstellt von Hajo.Ziplies@web.de *
'* http://Hajo-Excel.de/ *
'**************************************************
Dim StBild As String ' Variable für Bildname
Dim InI As Integer ' Schleifenvariable
If Target.Address <> "$A$15" Then Exit Sub
Application.EnableEvents = False ' Reaktion auf Eingabe abschalten
Target.Offset(0, 1) = "" ' _
Zelle neben Eingabefeld leeren
Application.EnableEvents = True ' Reaktion auf Eingabe einschalten
' Bild löschen von jinx
' löscht alle Bilder in der aktuelen Tabelle, deren erste _
drei Buchstaben "Pic" sind
For InI = ActiveSheet.Shapes.Count To 1 Step -1
If Left(ActiveSheet.Shapes(InI).Name, 3& _
#41; = "Pic" Then
ActiveSheet.Shapes(InI).Delete ' Bild lö _
schen
End If
Next
If Target.Value = "" Then Exit Sub ' kein Eingabe, Prozedur verlassen
' Bildnamen zusammensetzen
StBild = StPfad & "D" & Format( _
Target.Value, "00000") & ".jpg"
Application.EnableEvents = False ' Reaktion auf Eingabe abschalten
If Dir(StBild) = "" Then ' prüfen ob Bild vorhanden
Target.Offset(0, 1) = "kein Bild" _
' Text in Zelle neben Eingabefeld schreiben
Application.EnableEvents = True ' Reaktion auf Eingabe einschalten
Exit Sub _
' Prozedur verlassen
Else
Target.Offset(0, 1) = "" ' _
Zelle neben Eingabefeld leeren
Application.EnableEvents = True ' Reaktion auf Eingabe einschalten
End If
' Bildhöhe des eingefügeten Bildes ermitteln, _
erstellt von Nepumuk
Bildgroesse_auslesen StBild
' Einfügen ohne Select von Bert Körn
' Ausdruck.AddPicture(FileName, Verknüpfung, in Mappe _
speichern,
' Pos. Links, Pos. Oben, Breite, Höhe)
' erstes Offset Pos. Links 0 Zeilen und eine Spalte nach rechts
' zweites Offset Pos. Oben 0 Zeilen tiefer und 0 Spalten nach _
rechts
With ActiveSheet.Shapes.AddPicture(StBild, True, True, Target.Offset(0, 1).Left, _
Target.Offset(0, 0).Top, DoBreite * DoBildhoehe / DoHohe, DoBildhoehe)
.OnAction = "Bild_BeiKlick" ' Makro im Modul BeiKlick
.Name = "Pic" & Target ' Bildname festlegen
End With
End Sub
' **************************************************************
' Modul: Bildgröße Typ = Allgemeines Modul
' **************************************************************
Option Explicit ' Variablendefinition erforderlich
'********************************************************************************
'* erstellt von Nepumuk *
'* http://www.online-excel.de/fom/fo_read.php?f=1&bzh=1259&h=1256&ao=1#a123x *
'********************************************************************************
Public DoHohe As Double ' Bildhöhe Original
Public DoBreite As Double ' Bildbreite Original
Private Declare Function CreateIC Lib "GDI32.dll" Alias "CreateICA" ( _
ByVal lpDriverName As String, _
ByVal lpDeviceName As String, _
ByVal lpOutput As String, _
ByRef lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" ( _
ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" ( _
ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "Kernel32.dll" ( _
ByVal nNumber As Long, _
ByVal nNumerator As Long, _
ByVal nDenominator As Long) As Long
Private Const LOGPIXELSX = 88&
Private Const LOGPIXELSY = 90&
Private Const HimetricInch = 2540&
Sub Bildgroesse_auslesen(strPicturePath As String)
Dim MyPicture As StdPicture
' Dim dblPixelX As Long, dblPixelY As Long
Set MyPicture = LoadPicture(strPicturePath)
' es wird nur die Höhe benötigt für Faktor
' dblPixelX = HimetricToPixelsX(MyPicture.Width)
' dblPixelY = HimetricToPixelsY(MyPicture.Height)
DoBreite = HimetricToPixelsX(MyPicture.Width)
DoHohe = HimetricToPixelsY(MyPicture.Height)
' MsgBox "Breite in Pixel " & CStr(dblPixelX) & vbLf & _
' "Höhe in Pixel " & CStr(dblPixelY)
' MsgBox "Breite in Zoll " & CStr(dblPixelX / 72) & vbLf & _
' "Höhe in Zoll " & CStr(dblPixelY / 72)
' MsgBox "Breite in mm " & CStr(dblPixelX * 0.352777777777778) & vbLf & _
' "Höhe in mm " & CStr(dblPixelY * 0.352777777777778)
Set MyPicture = Nothing
End Sub
Function HimetricToPixelsX(ByVal inHimetric As Long) As Long
HimetricToPixelsX = ConvertPixelHimetric(inHimetric, True, True)
End Function
Function HimetricToPixelsY(ByVal inHimetric As Long) As Long
HimetricToPixelsY = ConvertPixelHimetric(inHimetric, True, False)
End Function
Function ConvertPixelHimetric(ByVal inValue As Long, _
ByVal ToPix As Boolean, inXAxis As Boolean) As Long
Dim TempIC As Long, GDCFlag As Long
TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
If (TempIC) Then
If (inXAxis) Then GDCFlag = LOGPIXELSX Else GDCFlag = LOGPIXELSY
If (ToPix) Then ConvertPixelHimetric = MulDiv(inValue, _
GetDeviceCaps(TempIC, GDCFlag), HimetricInch) _
Else ConvertPixelHimetric = MulDiv(inValue, _
HimetricInch, GetDeviceCaps(TempIC, GDCFlag))
Call DeleteDC(TempIC)
End If
End Function
' **************************************************************
' Modul: BeiKlick Typ = Allgemeines Modul
' **************************************************************
Option Explicit ' Variablendefinition erforderlich
Option Private Module ' damit Makro nicht sichtbar bei Makro
Public Const DoBildhoehe = 150 ' alle Bilder werden mit dieser Bildhöhe eingefügt, die Breite wird angepast
Public Const DoFaktor = 2.5 ' Faktor Bildvergrößerung
Sub Bild_BeiKlick()
'**************************************************
'* H. Ziplies *
'* 02.12.07 *
'* erstellt von Hajo.Ziplies@web.de *
'* http://Hajo-Excel.de/ *
'**************************************************
Dim ObB As Object ' Variable für Bild
Set ObB = ActiveSheet.Shapes(Application.Caller) ' das geklickte Bildobjekt auf Variable schreiben
If ObB.Height = DoBildhoehe Then
ObB.ScaleWidth DoFaktor, msoFalse, msoScaleFromTopLeft ' Faktor bezogen auf eingefügtes Bild
ObB.ScaleHeight DoFaktor, msoFalse, msoScaleFromTopLeft ' Faktor bezogen auf eingefütes Bild
ObB.ZOrder msoBringToFront ' Bild in den Vordergrund
Else
ObB.ScaleWidth 1 / DoFaktor, msoFalse, msoScaleFromTopLeft ' Faktor bezogen auf eingefügtes Bild
ObB.ScaleHeight 1 / DoFaktor, msoFalse, msoScaleFromTopLeft ' Faktor bezogen auf eingefügtes Bild
ObB.ZOrder msoSendToBack ' Bild in den Hintergrund
End If
Set ObB = Nothing ' Variable leeren
End Sub