' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
'Code 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&
'### Einstellungen ###
Private Const cWidth As Long = 60 'Bildbreite in Pixel
Private Const cGap As Long = 3 'Abstand zwischen den Bildern in Pixel bei Fixabstand
Private Const cFixedGap As Boolean = False 'Fixer Abstand zwischen den Bildern
Sub insertPictures()
Dim strPath As String, strFile As String
Dim rng As Range, lngOffset As Long
Dim objPic As Shape
Dim sngWidth As Single, sngGap As Single
Dim dblW As Double, dblH As Double
sngWidth = cWidth * 0.75
sngGap = cGap * 0.75
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "E:\"
.Title = "Bilder einfügen - Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
End With
If Len(strPath) Then
Set rng = ActiveCell
strFile = Dir(strPath & "*.jpg", vbNormal)
Do While strFile <> ""
lngOffset = lngOffset + 1
GetImageSize strPath & strFile, dblW, dblH
Set objPic = ActiveSheet.Shapes.AddPicture(strPath & strFile, msoFalse, msoTrue, 0, 0, dblW, dblH)
With objPic
.Top = rng.Top
If cFixedGap Then
.Left = rng.Offset(0, 1).Left + (sngWidth * (lngOffset - 1)) + _
(sngGap * -(lngOffset > 1)) * (lngOffset - 1)
Else
.Left = rng.Offset(0, lngOffset).Left
End If
.LockAspectRatio = True
.Width = sngWidth
.AlternativeText = 0
.Shadow.Style = msoShadowStyleOuterShadow
.Shadow.Visible = msoFalse
.Line.Style = msoLineSingle
.Line.Visible = msoFalse
.OnAction = "ToggleSize"
End With
strFile = Dir
Loop
'JPG's löschen
If MsgBox("Importierte Bilder von der Festplatte löschen?", 292) = vbYes Then
Kill strPath & "*.jpg"
End If
End If
Set objPic = Nothing
Set rng = Nothing
End Sub
Private Sub ToggleSize()
Dim objPic As Picture
Set objPic = ActiveSheet.Pictures(Application.Caller)
With objPic.ShapeRange
If .AlternativeText = "0" Then
.AlternativeText = 1
.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
.Shadow.Visible = msoTrue
.Line.Visible = msoTrue
.ZOrder 0
Else
.AlternativeText = 0
.Width = cWidth * 0.75
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.ZOrder 1
End If
End With
Set objPic = Nothing
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