Datum

Titel

25.04.2024 21:21:16

Zellkommentar in UserForm anzeigen und bearbeiten

25.04.2024 21:13:13

Kalenderwochen addieren

25.04.2024 21:06:05

Duplikate entfernen

25.04.2024 18:41:19

vba Zeilen duplizieren ab aktiver Zeile bis letzte Zeile

Du findest keine passende Antwort auf Deine Frage?

Stelle Deine Frage in unserem Live-Forum

Archiv - Navigation

728to732

Aktuelles Verzeichnis

Verzeichnis Index

Übersicht Verzeichnisse

Vorheriger Thread

Rückwärts Blättern

Nächster Thread

Vorwärts blättern

HERBERS

Excel-Forum (Archiv)

20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender

Rückwärts Blättern

Aktuelles Verzeichnis

Übersicht Verzeichnisse

Vorwärts blättern

Inhaltsverzeichnis

Bilder in UserForm!

Forumthread: Bilder in UserForm!
17 Beiträge zu diesem Forumthread
Anzeige
304 Threads zu ähnlichen Themen
VBA Beispiele zu verwandten Themen

Excel Dialoge
Top 100 Forumthreads

Bilder in UserForm!

06.02.2006 14:03:59

Maik

Ich habe folgendes Problem:
Ich möchte in einer UserForm aus einer Datenbank einige Inhalte heraussuchen unter anderem auch bmp.-Dateien. Anzeigen lassen kann ich sie in der UserForm. Jetzt möchte ich aber über einen Kopie-Button die Daten in Tabelle2 kopieren. Das geht mit den ComboBoxen und den TextBoxen einwandfrei. Aber nicht mit der bmp.Datei. Ist es überhaupt möglich diese auf eine Zelle in Excel zu beziehen?
Hier ist der Quellcode:


Private Sub SpinButton1_Change()
Dim s As String
SpinButton1.Max = 10
SpinButton1.Min = 1
Select Case SpinButton1.Value
Case 1
s = "1.bmp"
Case 2
s = "2.bmp"
Case 3
s = "3.bmp"
Case 4
s = "4.bmp"
Case 5
s = "5.bmp"
Case 6
s = "6.bmp"
Case 7
s = "7.bmp"
Case 8
s = "8.bmp"
Case 9
s = "9.bmp"
Case 10
s = "10.bmp"
Case Else
MsgBox "Kein Bild gefunden!"
End Select
Image1.Picture = LoadPicture("C:\Gefahrensymbole\" & s)
End Sub

Der dazugehörige Eintrag zum Kopieren:
...
Sheets("Druck").Range("E35").Value = ComboBox14
Sheets("Druck").Range("D11").Value = ComboBox15
Sheets("Druck").Range("C14").Value = ComboBox16
Sheets("Druck").Range("A12").Value = Image1
...
Wäre super wenn mir jemand weiter helfen kann.
Thx
Maik

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Bilder in UserForm!

06.02.2006 15:11:43

Nepumuk
AW: Bilder in UserForm!

06.02.2006 20:06:15

Maik
AW: Bilder in UserForm!

06.02.2006 20:57:10

Nepumuk
Kleiner Fehler

06.02.2006 21:03:57

Nepumuk
AW: Kleiner Fehler

07.02.2006 12:22:27

Maik
AW: Kleiner Fehler

07.02.2006 12:34:26

Nepumuk
AW: Kleiner Fehler

07.02.2006 12:42:01

Maik
AW: Kleiner Fehler

07.02.2006 12:42:10

Maik
AW: Kleiner Fehler

07.02.2006 12:42:13

Maik
AW: Kleiner Fehler

07.02.2006 12:42:57

Maik
AW: Kleiner Fehler

07.02.2006 12:43:43

Maik
AW: Kleiner Fehler

07.02.2006 12:43:48

Maik
AW: Kleiner Fehler

07.02.2006 12:52:41

Nepumuk
AW: Kleiner Fehler

07.02.2006 13:19:40

Maik
AW: Kleiner Fehler

07.02.2006 13:19:46

Maik
AW: Kleiner Fehler

07.02.2006 13:35:24

Maik
AW: Kleiner Fehler

07.02.2006 13:46:34

Nepumuk

AW: Bilder in UserForm!

06.02.2006 15:11:43

Nepumuk

Hallo Maik,
was willst du in der Tabelle haben, das Bild oder dessen Namen?
Gruß
Nepumuk

AW: Bilder in UserForm!

06.02.2006 20:06:15

Maik

Das Bild, den Namen anzuzeigen ist kein problem. Ich will das das Bild das ich in der UserForm auswähle bei betätigung des KopieButton in die Tabelle Kopiert wird
Geht das überhaupt?

AW: Bilder in UserForm!

06.02.2006 20:57:10

Nepumuk

Hi,
klar geht das, sonst würde ich ja nicht nachfragen. :-)
Im Userform:

Option Explicit

Private Sub CommandButton1_Click()
Call prcCopyPicture(Me.Image1, 12, 1)
End Sub

In einem Standardmodul:

Option Explicit

Private Declare Function CopyImage Lib "user32.dll" ( _
    ByVal handle As Long, _
    ByVal imageType As Long, _
    ByVal newWidth As Long, _
    ByVal newHeight As Long, _
    ByVal lFlags As Long) As Long
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long, _
    ByVal hMem As Long) As Long

Private Const IMAGE_BITMAP = 0&
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2&
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"

Public Sub prcCopyPicture(objImage As MSForms.Image, lngRow As Long, lngColumn As Long)
    Dim lngTempPicture As Long
    Dim objShape As Shape
    lngTempPicture = CopyImage(objImage.Picture.handle, _
        IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
    If lngTempPicture <> 0 Then
        Application.ScreenUpdating = False
        OpenClipboard FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption)
        EmptyClipboard
        SetClipboardData CF_BITMAP, lngTempPicture
        CloseClipboard
        With ThisWorkbook.Worksheets("Druck")
            .Paste
            Set objShape = .Shapes(.Shapes.Count)
            objShape.Top = Rows(lngRow).Top
            objShape.Left = Columns(lngColumn).Left
        End With
        Application.ScreenUpdating = True
    End If
End Sub

Gruß
Nepumuk

Kleiner Fehler

06.02.2006 21:03:57

Nepumuk

Hi,
in der With-Anweisung fehlen noch Bezugspunkte:

Public Sub prcCopyPicture(objImage As MSForms.Image, lngRow As Long, lngColumn As Long)
    Dim lngTempPicture As Long
    Dim objShape As Shape
    lngTempPicture = CopyImage(objImage.Picture.handle, _
        IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
    If lngTempPicture <> 0 Then
        Application.ScreenUpdating = False
        OpenClipboard FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption)
        EmptyClipboard
        SetClipboardData CF_BITMAP, lngTempPicture
        CloseClipboard
        With ThisWorkbook.Worksheets("Druck")
            .Paste
            Set objShape = .Shapes(.Shapes.Count)
            objShape.Top = .Rows(lngRow).Top
            objShape.Left = .Columns(lngColumn).Left
        End With
        Application.ScreenUpdating = True
    End If
End Sub

Gruß
Nepumuk

AW: Kleiner Fehler

07.02.2006 12:22:27

Maik

Super funktioniert einwandfrei! Herzlichen Dank. Wo genau wird die Position festgelegt, das ich das variable verändern kann?
Wahrscheinlich kann ich dann auch dort den text so umschreiben, das nach erneutem drücken des CopyButton, das Bild nicht überdeckt wird, sonder erst das alte gelöscht und dann das neue eingefügt wird.
Thx
Maik

AW: Kleiner Fehler

07.02.2006 12:34:26

Nepumuk

Hallo Maik,
die Position wird mit diesen Anweisungen festgelegt:
objShape.Top = .Rows(lngRow).Top
objShape.Left = .Columns(lngColumn).Left
Die Werte für die Position werden im Aufruf übergeben. Damit du ein Bild an einer bestimmten Position löschen kannst, musst du alle Bilder durchlaufen und die Topleftcell-Eigenschaft abfragen.
Gruß
Nepumuk

AW: Kleiner Fehler

07.02.2006 12:42:01

Maik

wenn ich ganz ehrlich bin, dann raff ich gerade nichts von dem was du mir erzählst. Ich dachte ich kann dort jetzt z.B. eingeben, dass das Bild im Bereich der Zelle A35 oder so angezeigt wird, grob zumindest, aber mit den Angaben kann ich überhaupt nichts anfangen.
Kann ich dir mal das Sheet schicken, vielleicht ist es dann einfacher zu verstehen auf was ich überhaupt hinaus möchte?

AW: Kleiner Fehler

07.02.2006 12:42:10

Maik

AW: Kleiner Fehler

07.02.2006 12:42:13

Maik

AW: Kleiner Fehler

07.02.2006 12:42:57

Maik

AW: Kleiner Fehler

07.02.2006 12:43:43

Maik

AW: Kleiner Fehler

07.02.2006 12:43:48

Maik

AW: Kleiner Fehler

07.02.2006 12:52:41

Nepumuk

Hallo Maik,
Im Prozeduraufruf wird die Zeile (im Beispiel 12) und Spalte (im Beispiel 1 = Spalte A) übergeben.
Call prcCopyPicture(Me.Image1, 12, 1)
Und in der Prozedur werden diese Wert in die Variablen lngRow und lngColumn übernommen.
Public Sub prcCopyPicture(objImage As MSForms.Image, lngRow As Long, lngColumn As Long)
Gruß
Nepumuk

AW: Kleiner Fehler

07.02.2006 13:19:40

Maik

Ok das habe ich verstanden, sollte nun kein Problem mehr sein, aber das mit dem löschen ist mir eine absolut schleierhafte Sache, könntest du das nochmal etwas ausführlicher erläutern, bitte?
MfG
Maik

AW: Kleiner Fehler

07.02.2006 13:19:46

Maik

AW: Kleiner Fehler

07.02.2006 13:35:24

Maik

AW: Kleiner Fehler

07.02.2006 13:46:34

Nepumuk

Hallo Maik,
bist du heute etwas nervös, weil du immer mehrfach auf absenden klickst?
Bilder löschen, welche eine definierte Position in der Tabelle haben, geht so:

Option Explicit

Public Sub prcDeletePicture(lngRow As Long, lngColumn As Long)
    Dim objShape As Shape
    For Each objShape In Worksheets("Tabelle1").Shapes
        With objShape
            If .Type = msoPicture Then
                If .TopLeftCell.Row = lngRow And .TopLeftCell.Column = _
                    lngColumn Then .Delete
            End If
        End With
    Next
End Sub

Public Sub test()
    Call prcDeletePicture(15, 1) 'lösch das Bild in Zeile 15 Spalte 1
End Sub

Gruß
Nepumuk