Bilder in Abhängigkeit von Listbox laden

Hallo, ich beschäftige mich seit einiger Zeit mit VBA, bin aber noch absoluter Neuling.Mein Ziel ist eine Kräuter-Datenbank zu erstellen.
Ich habe in Zeile 1 folgende Überschriften:
Kraut (A), Lat.Name(B), Gesundheit(C),verwendet wird (D),passt zu (E),Rezepte (F) und Bild (G).
In Spalte A sind die Kräuter alphabetisch geordnet.
Ich habe eine Userform mit einer ListBox, einer Imagebox, 6 Textboxen und den Buttons: Neuer Eintrag, Löschen, Speichern, Beenden.
In meiner Userform habe ich es hinbekommen, das mir in einer ListBox alle Kräuter aus Spalte A angezeigt werden und auch die Spalten B:F werden in den zugehörigen Textboxen richtig angezeigt. Außerdem funktioniert das Scrollen mit der Maus in der Listbox. Auch die Buttons haben alle Funktion.
Zusätzlich habe ich es geschafft, das alle Eingaben die ich in der Userform ändere, auch im Excel-Tabellenblatt gespeichert werden können und das ich auch neue Einträge eingeben kann. Soweit so gut.
Mein Problem ist, das ich es nicht hinbekomme in meinen vorhandenen Code einzugeben , das mir in der Imagebox das jeweils passende Bild (aus Spalte G) zu dem Kraut aus der Listbox angezeigt wird. Das Bild sollte möglichst nicht aus einem Ordner geladen werden, sondern aus dem Tabellenblatt 1. (Falls das nicht möglich sein sollte, soll der auskommentierte Code am Ende des VBA Codes genommen werden, bei dem ich aber nicht weiß wo und wie ich ihn einfügen muss, damit er funktioniert)
In einer anderen Mappe mit selben Inhalt habe ich einen Code zum Bilder einfügen ( der auskommentierte Code am Ende des VBA Codes) aus einem Ordner auf meiner Festplatte, der wunderbar klappt. Da lassen sich jedoch die Textboxen nicht füllen. Ich bin mit meinem Latein am Ende.Versuche jetzt schon seit mehr als einer Woche passenden Code zu finden, der mir beides ermöglicht oder meine beiden Codes zusammen zu kombinieren. Da ich aber nur Bahnhof verstehe gelingt mir das nicht.
Schön wäre außerdem , wenn sich das Tabellenblatt automatisch neu alphabetisch sortieren würde beim nächsten Neustart oder beim beenden, wenn ich neue Einträge gemacht habe und ich dies dann nicht mehr händisch machen müßte. Das ist aber nicht unbedingt nötig, wäre nur ein kleines Bonbon für mich.
Ich hoffe ihr könnt mir helfen, mein Problem zu lösen.Für mich ist es mega kompliziert, aber für die Profis unter euch wahrscheinlich ein Klacks. Lieben Dank schon mal im Vorraus für eure Hilfe. LG Britta
Anbei die Beispielmappe: https://www.herber.de/bbs/user/152950.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Britta,
folgende Änderung im Modul des UserForms:


Private Sub ListBox1_Change()
Dim objShape As Shape
TextBox1.Text = Tabelle1.Cells(2, 1).Offset(ListBox1.ListIndex, 1).Text
TextBox2.Text = Tabelle1.Cells(2, 1).Offset(ListBox1.ListIndex, 2).Text
TextBox3.Text = Tabelle1.Cells(2, 1).Offset(ListBox1.ListIndex, 3).Text
TextBox4.Text = Tabelle1.Cells(2, 1).Offset(ListBox1.ListIndex, 4).Text
TextBox5.Text = Tabelle1.Cells(2, 1).Offset(ListBox1.ListIndex, 5).Text
TextBox6.Text = Tabelle1.Cells(2, 1).Offset(ListBox1.ListIndex, 6).Text
For Each objShape In Tabelle1.Shapes
If objShape.Type = msoPicture Then If objShape.TopLeftCell.Row = ListBox1.ListIndex + 2 Then Exit For
Next
If objShape Is Nothing Then
Set Image1.Picture = Nothing
Else
Set Image1.Picture = ShowPicture(objShape)
Set objShape = Nothing
End If
End Sub

dann füge ein neues Modul ein mit folgendem Code:


Option Explicit
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
ByRef PicDesc As PICT_DESC, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
ByVal handle As LongPtr, _
ByVal un1 As Long, _
ByVal n1 As Long, _
ByVal n2 As Long, _
ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Any, _
ByRef pCLSID As GUID) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICT_DESC
lSize As Long
lType As Long
hPic As LongPtr
hPal As LongPtr
End Type
Private Const PICTYPE_BITMAP As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Private Function PastePicture(ByRef prlngptrCopy As LongPtr) As IPictureDisp
Dim lngReturn As Long, lngptrPointer As LongPtr
If CBool(IsClipboardFormatAvailable(CF_BITMAP)) Then
lngReturn = OpenClipboard(Application.hwnd)
If lngReturn > 0 Then
lngptrPointer = GetClipboardData(CF_BITMAP)
prlngptrCopy = CopyImage(lngptrPointer, _
IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Call CloseClipboard
If lngptrPointer  0 Then Set PastePicture = _
CreatePicture(prlngptrCopy, 0)
End If
End If
End Function
Private Function CreatePicture( _
ByVal lngptrhPic As LongPtr, _
ByVal lngptrhPal As LongPtr) As IPictureDisp
Dim udtPicInfo As PICT_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp
Call CLSIDFromString(StrPtr( _
GUID_IPICTUREDISP), udtID_IDispatch)
With udtPicInfo
.lSize = Len(udtPicInfo)
.lType = PICTYPE_BITMAP
.hPic = lngptrhPic
.hPal = lngptrhPal
End With
Call OleCreatePictureIndirect(udtPicInfo, _
udtID_IDispatch, 0&, objPicture)
Set CreatePicture = objPicture
Set objPicture = Nothing
End Function
Public Function ShowPicture(ByRef probjShape As Shape) As IPictureDisp
Dim slngptrCopy As LongPtr
Dim objTempPicture As IPictureDisp
If slngptrCopy  0 Then Call DeleteObject(slngptrCopy)
Call OpenClipboard(0)
Call EmptyClipboard
Call CloseClipboard
On Error Resume Next
Do
Call probjShape.CopyPicture( _
Appearance:=xlScreen, Format:=xlBitmap)
If Err.Number = 0 Then Exit Do
Call Err.Clear
Loop
On Error GoTo 0
Do
Set ShowPicture = PastePicture(slngptrCopy)
Loop While ShowPicture Is Nothing
End Function

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Bilder in Abhängigkeit von Listbox laden

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bilder in Abhängigkeit von Listbox laden

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread