' **********************************************************************
' Modul: Tabelle4 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Const cstrPath As String = "F:\Bilder" 'Pfad
Private Const cstrExt As String = ".png" 'Erweiterung
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strFile As String
strFile = cstrPath & IIf(Right(cstrPath, 1) <> "\", "\", "") & Cells(Target.Row, 1).Text & cstrExt
If Dir(strFile, vbNormal) <> "" Then
Cancel = True
Call insertPicture(strFile, Target)
End If
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
'Code zum Auslesen der Bildgröße aus "Online Excel Forum" - http://www.online-excel.de/
'Postet by Nepumuk, 20/06/05
'Geändert von J.Ehrensberger 08/02/06
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 insertPicture(strFilename As String, Target As Range)
Dim objPic As Shape, objText As Shape, objGroup As Shape
Dim lngCount As Long
Dim dblw As Double, dblH As Double
If Dir(strFilename, vbNormal) <> "" Then
For Each objText In ActiveSheet.Shapes
If objText.Name Like "group_*" Then
lngCount = Application.Max(lngCount, Clng(Split(objText.Name, "_")(1)))
End If
Next
lngCount = lngCount + 1
GetImageSize strFilename, dblw, dblH
Set objPic = ActiveSheet.Shapes.AddPicture(strFilename, msoFalse, msoTrue, Target.Left, Target.Top + 1, dblw, dblH)
With objPic
.LockAspectRatio = True
.Line.Visible = msoFalse
.OnAction = "dummy"
End With
Set objText = ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, Target.Left, Target.Top + objPic.Height - 3, objPic.Width, 10)
With objText
.TextFrame.Characters.Font.Size = 8
.TextFrame.Characters.Text = lngCount
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.Line.Visible = msoFalse
.OnAction = "dummy"
End With
Set objGroup = ActiveSheet.Shapes.Range(Array(objPic.Name, objText.Name)).Group
objGroup.Name = "group_" & lngCount
End If
Set objPic = Nothing
Set objText = Nothing
Set objGroup = Nothing
End Sub
Sub dummy()
'..
End Sub
Private Function GetImageSize(ByVal strPicturePath As String, ByRef dblWidth As Double, ByRef dblHeight As Double) As Long
Dim MyPicture As StdPicture
On Error GoTo ErrExit
Set MyPicture = LoadPicture(strPicturePath)
If Not MyPicture Is Nothing Then
GetImageSize = -1
dblWidth = HimetricToPixelsX(MyPicture.Width)
dblHeight = HimetricToPixelsY(MyPicture.Height)
End If
ErrExit:
Err.Clear
On Error GoTo 0
Set MyPicture = Nothing
End Function
Private Function HimetricToPixelsX(ByVal inHimetric As Long) As Long
HimetricToPixelsX = ConvertPixelHimetric(inHimetric, True, True)
End Function
Private Function HimetricToPixelsY(ByVal inHimetric As Long) As Long
HimetricToPixelsY = ConvertPixelHimetric(inHimetric, True, False)
End Function
Private 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