Ein Bild per UserForm in Zellenkommentar einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Josef.
Absolut geniales Skript. ;o) Vielen Dank fürs mitdenken.
Ich habs noch ein bisschen umgeschrieben, aber es ist genau das
was ich gesucht habe. Funktioniert auch fast schon tadellos!! ;o)
4 Fragen hab ich nun noch dazu:
1. Bilder werden nun in ein eigenes VorschauForm geöffnet.
Nach dem Öffnen eines Bildes erscheint dessen Pfad nicht auf einem Label,
sondern im Tag von imgCommentPicture.
Erst wenn ich nun auf ok clicke wird der Bild-Pfad in Label2.Tag auf einem zweiten
UserForm (EingabeForm) übertragen und gleichzeitig das VorschauForm geschlossen.
Soweit bin ich schon. Funktioniert.
Problem: Wie bekomme ich jetzt den Namen des Bildes aus Label2.Tag in Label2?
Aber eben nicht den vollständigen Pfad, sondern nur den Namen des Bildes.
2. Kann ich beim Öffnen eines Bildes seine Größe prüfen lassen?
Wenn es größer als 110x110Pixel ist sollte eine MsgBox erscheinen die anzeigt das
das Öffnen verweigert wurde.
3. Wenn ich nun ok im EingabeForm clicke wird der Bild-Pfad aus Label2.Tag ausgelesen
und das entsprechende Bild als Kommentar in das passende Tabellenfeld übertragen.
Funktioniert erstklassig.
Problem: Wenn Label2.Tag keine Pfadangabe enthält bekomme ich bei click auf ok eine
kräftige Fehlermeldung. Wie kann ich das verhindern?
Wenn Label2.Tag leer ist, dann soll eben einfach kein Kommentarbild eingfügt werden.
4. Die Größe des Kommentar-Feldes in meinen Tabellen stimmt noch nicht.
Das Feld soll 2,5cm breit sein und das Seitenverhältnis des eingefügten Bildes
berücksichtigen.
Meinst Du könntest mir da noch ein bisschen helfen?
Sonnige Grüße
Chris B.

Hallo Chris!
Viel Spass!
'**********************************************************
'Code-Modul UserForm1
Option Explicit

Const maxBreite As Integer = 110 'maximale Breite des Bildes
Const maxHoehe As Integer = 110 'maximale Höhe des Bildes

Private Sub CommandButton1_Click()
    'Bild auswählen
    Dim sFile As String


    'Datei auswählen
    sFile = Application.GetOpenFilename _
        ("Bilddateien _(*.bmp;*.gif;*.jpg), *.bmp;*.gif;*.jpg")

    If sFile = "Falsch" Then Exit Sub

    'Grössenkontrolle
    If MaxImgSize(sFile, maxBreite, maxHoehe) Then

        'Vorschau
        With UserForm2

            .imgCommentPicture.Picture = LoadPicture(sFile)
            .imgCommentPicture.Tag = sFile
            .Show

        End With

    Else
        'Meldung bei ungültigem Bild
        MsgBox "Das gewählte Bild ist zu groß!" & Space(20) & vbLf & _
            vbLf & "Bitte beachten Sie die maximale Größe" & vbLf & _
            "von " & maxBreite & " x " & maxHoehe & " Pixel!", _
            vbInformation, "Hinweis"
    End If

End Sub

Private Sub CommandButton2_Click()
    'Bild in Kommentar einfügen
    Dim cmnt As Comment
    Dim dblAspR As Double


    If Label2.Tag <> "" Then
        Set cmnt = Cells(1, 1).Comment
        'Wenn kein Kommentar vorhanden dann einfügen
        If cmnt Is Nothing Then _
            Set cmnt = Cells(1, 1).AddComment

        'Seitenverhältnis des Bildes ermitteln
        dblAspR = GetImgAspectRatio(Label2.Tag)

        With cmnt.Shape
            'Bild in den Kommentar einfügen
            .Fill.UserPicture Label2.Tag
            'Kommentargrösse anpassen
            .LockAspectRatio = msoFalse
            .Width = 70.5
            .Height = .Width / dblAspR
        End With

    Else
        'wenn kein Bildpfad vorhanden
        MsgBox "Kein Bild vorhanden!" & Space(25), vbInformation, "Hinweis"

    End If

End Sub

'Ende Code-Modul UserForm1
'**********************************************************

'**********************************************************
'Code-Modul UserForm2
Option Explicit

Private Sub CommandButton1_Click()
    'OK
    UserForm1.Label2.Tag = Me.imgCommentPicture.Tag
    UserForm1.Label2 = Right(Me.imgCommentPicture.Tag, _
        InStr(1, StrReverse(Me.imgCommentPicture.Tag), "\") - 1)
    Unload Me
End Sub

Private Sub CommandButton2_Click()
    'Abbrechen
    UserForm1.Label2.Tag = ""
    UserForm1.Label2 = ""
    Unload Me
End Sub

'Ende Code-Modul UserForm2
'**********************************************************

'**********************************************************
'Allgemeines Modul
Option Explicit
'Code aus "Online Excel Forum" - http://www.online-excel.de/
'Postet by Nepumuk, 20/06/05

'Abgewandelt von J.Ehrensberger

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&

Public Function MaxImgSize(strPicturePath As String, _
        xPix As Integer, yPix As Integer) As Boolean
    'Bildgrösse (Pixel) Checken
    Dim MyPicture As StdPicture
    Dim dblPixelX As Long, dblPixelY As Long
    Set MyPicture = LoadPicture(strPicturePath)
    dblPixelX = HimetricToPixelsX(MyPicture.Width)
    dblPixelY = HimetricToPixelsY(MyPicture.Height)

    MaxImgSize = dblPixelX <= xPix And dblPixelY <= yPix

    Set MyPicture = Nothing
End Function

Public Function GetImgAspectRatio(strPicturePath As String) As Double
    'Seitenverhältnis ermitteln
    Dim MyPicture As StdPicture

    Set MyPicture = LoadPicture(strPicturePath)

    GetImgAspectRatio = CDbl(MyPicture.Width / MyPicture.Height)

    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

'Ende Allgemeines Modul
'**********************************************************

Gruß Sepp

P.S.: Rückmeldung nicht vergessen!

Beliebteste Forumthreads (12 Monate)

Ein Bild per UserForm in Zellenkommentar einfügen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ein Bild per UserForm in Zellenkommentar einfügen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread