Bilder für UF platzsparend einbinden

Liebe VBA-Cracks,
ich programmiere gerade eine kleine Datenbank für chemische Substanzen. Zu jeder Substanz soll eine Grafik (die chem. Struktur) angezeigt werden. Davon habe ich insg. ca. 140, das sind kleine jpg-Bilder (15-20 kb). In der Summe sind das 2,3 MB, die Bilder vergrößern die Datei aber um 6,3 MB. Vor allem lädt die Datei jetzt rund 20 Sekunden. Der Nutzer wird denken, dass Excel abgestürzt ist...
Die Bilder sind alle in einem Tabellenblatt in Image-Steuerelementen "geparkt" und werden von da aus in die Userform geladen, was eigentlich sehr gut funktioniert. Ich weiß, dass das man die Bilder im Idealfall in einem Ordner ablegt und sie von da aus lädt. Ich möchte sie aber gerne irgendwie in der Datei haben. Die Datenbank soll in der Firma die Runde machen, die KollegInnen sollen sie untereinander teilen und da würde der Bilder-Ordner früher oder später auf der Strecke bleiben.
Gibt es eine Möglichkeit die Fotos irgendwie in die Datei zu "mogeln", sodass sie beim Start nicht zuerst in den Arbeitsspeicher geladen werden? Mir hat ein Kollege kürzlich gezeigt, dass man die Dateiendung in .zip ändern kann und so die "Ordnerstruktur" der Datei einsehen kann. Könnte man da einen Ordner unterbringen, die Datei wieder zippen und dann darauf zugreifen?
Oder gibt es vielleicht eine andere Idee wie ich den Ladevorgang beschleunigen oder die Bilder geschickter einbinden kann?
Hier der Link zur Datei: https://www.herber.de/bbs/user/148543.xlsm. Mit 2 Bildern ist sie grade so klein genug für den Forums-Server.
Vielen Dank für alle Ideen und schöne Grüße,
Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Christian,
wenn Du Bilder von einem Tabellenblatt in eine Userform dynamisch einsetzen möchtest, geht das z.B. über die Zwischenablage.
Dazu habe ich hier zwei Varianten, einmal über Angabe der Zeilennummer der Zelle, wo das gewünschte Bild liegt oder über den Bildernamen an sich.
Hier das Beispiel für die Übername per Bildernamen:
Einfach nur noch Tabellen-, Userform- und Picturenamen im Code anpassen, dann sollte es funktionieren.

Code:


[Cc][+][-]




	
	
	
	


Option Explicit

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
        ByRef PicDesc As PIC_DESC, ByRef RefIID As GUID, _
        ByVal fPictureOwnsHandle As LongPtr, ByRef IPic As IPictureDisp) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" ( _
        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" ( _
        ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
        ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" ( _
        ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" ( _
        ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" _
        Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
  
Private Type PIC_DESC
    lSize As Long
    lType As Long
    hPic  As LongPtr
    hPal  As LongPtr
End Type
Dim hPic  As LongPtr

Private Type GUID
     Data1 As Long
     Data2 As Integer
     Data3 As Integer
     Data4(0 To 7) As Byte
End Type

Private Const PICTYPE_BITMAP = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

Sub Paste_Picture_ByName(sSuch As String)
' Fügt ein Bild aus einer Pic-Sammlung über die Zwischenablage
' in ein Userform-Control ein
  Dim oPict As IPictureDisp, oShape As Shape
  Dim tPicInfo As PIC_DESC, tID_IDispatch As GUID

' Bild suchen und in die Zwischenablage kopieren
  With ThisWorkbook.Sheets("Tabelle2")              ' Blatt ggf. <<<anpassen>>>
      For Each oShape In .Shapes
          If oShape.Name Like sSuch & "*" Then
             oShape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
             DoEvents: Exit For
          End If
      Next oShape
  End With

' Bild aus Zwischenablage in das Image einfügen
  If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
     If OpenClipboard(0&) <> 0 Then
        hPic = CopyImage(GetClipboardData(CF_BITMAP), _
        IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        CloseClipboard
        If hPic <> 0 Then
           With tID_IDispatch
               .Data1 = &H20400
               .Data4(0) = &HC0
               .Data4(7) = &H46
           End With

           With tPicInfo
               .lSize = Len(tPicInfo)
               .lType = PICTYPE_BITMAP
               .hPic = hPic
               .hPal = 0
           End With

           OleCreatePictureIndirect tPicInfo, tID_IDispatch, 0&, oPict

           If Not oPict Is Nothing Then
' ######### Hier die Userform und Image-Angaben anpassen ########
              UserForm1.Image3.Picture = oPict
           Else
              MsgBox "Das Bild kann nicht angezeigt werden", vbCritical, "Bild einfügen"
           End If

        End If
     End If
  End If
End Sub


'Aufrufbeispiel für Sternzeichenpicture
Sub test()
  Paste_Picture_ByName "Löwe"
  UserForm1.Show
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

Bilder für UF platzsparend einbinden

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bilder für UF platzsparend einbinden

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread