Object einbetten mit Icon

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Informationen und Beispiele zum Thema InputBox
Screenshot zu InputBox	InputBox-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema MsgBox
Screenshot zu MsgBox	MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema Label
Screenshot zu Label	Label-Seite mit Beispielarbeitsmappe aufrufen

Object einbetten mit Icon

Object einbetten mit Icon von Thomas Mayer vom 16.10.2020 12:10:05

AW: Object einbetten mit Icon - von volti am 16.10.2020 15:18:16
- AW: Object einbetten mit Icon - von Thomas Mayer am 16.10.2020 16:23:17
  - AW: Object einbetten mit Icon - von volti am 16.10.2020 16:33:48
    - AW: Object einbetten mit Icon - von volti am 16.10.2020 17:00:36
      - AW: Object einbetten mit Icon - von Thomas Mayer am 16.10.2020 17:47:03
    - AW: Object einbetten mit Icon - von Thomas Mayer am 16.10.2020 17:41:54

Betrifft: Object einbetten mit Icon von: Thomas Mayer
Geschrieben am: 16.10.2020 12:10:05

Hallo,

ich möchte in mein Dokument noch die Möglichkeit haben, Objekte (PDF, JPG, XLS) einzubetten. Ich habe untenstehenden Code hier gefunden und eingebaut. Soweit so gut, nur dass beim hinzufügen des dritten Dokuments das Icon über dem zweiten Icon liegt. Also schaltet die Column Anweisung nicht weiter.

Ich möchte auch das Script noch so abändern, dass nur PDF, JPG, XLS eingefügt werden können und die Row zwar im Endeffekt bei 216 beginnt, aber ggf. durch hinzufügen von Zeilen sich auch ändern kann wie z.B. 220 (falls vier Zeilen hinzugefügt werden).

Hier mein Code Versuch:

Option Explicit

Private Declare PtrSafe Function FindExecutableA Lib "shell32.dll" ( _
    ByVal lpFile As String, _
    ByVal lpDirectory As String, _
    ByVal lpResult As String) As Long
Private Declare PtrSafe Function LockWindowUpdate Lib "user32.dll" ( _
    ByVal hwndLock As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As Long

Private Const MAX_PATH As Long = 260&

Public Sub InsertFileObjectNEU()
    
    Dim objOLEObject As OLEObject
    Dim lngReturn As Long
    Dim strPath As String, strFilename As String, strDisplayName As String
    Dim strTemp As String * MAX_PATH, strExecutable As String
    
    Dim vntItem As Variant
    Dim lngRow As Long, lngColumn As Long
    lngRow = 4
    lngColumn = 2


    With Application.FileDialog(msoFileDialogFilePicker)
  
        .Filters.Clear
        .Title = "Add General Document"
        .AllowMultiSelect = False
        
        If .Show Then
        For Each vntItem In .SelectedItems
        
            If (IsEmpty(ActiveSheet.Cells(lngRow, lngColumn)) = False) Then
            lngColumn = lngColumn + 2
            End If
        
                If lngColumn Mod 9 = 0 Then
                    lngRow = lngRow + 5
                    lngColumn = 2
                End If
                
            strPath = .SelectedItems(1)
            strFilename = Mid$(strPath, InStrRev(strPath, "\") + 1)
            strFilename = Left$(strFilename, InStrRev(strFilename, ".") - 1)
            
            lngReturn = FindExecutableA(strPath, vbNullString, strTemp)
            
            If lngReturn > 32 Then
                strExecutable = Left$(strTemp, InStr(strTemp & vbNullChar, vbNullChar) - 1)
            Else
                Call MsgBox("Kein Programm zum Öffnen gefunden.", vbCritical, "Programmabbruch") _
 _

                Exit Sub
            End If
            
            strDisplayName = InputBox("Bitte Anzeigetext eingeben.", "Einagbe", strFilename)
            If StrPtr(strDisplayName) <> 0 Then
               
                Call LockWindowUpdate(GetDesktopWindow)
                
                Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strExecutable, IconLabel:=strDisplayName)
                objOLEObject.ShapeRange.AlternativeText = strFilename
                
                With objOLEObject
                    .Left = Columns(lngColumn).Left
                    .Top = Rows(lngRow).Top
                End With
                
                ActiveSheet.Cells(lngRow, lngColumn) = lngColumn
              
                lngColumn = lngColumn + 2
                
                Call LockWindowUpdate(0&)
                
                Set objOLEObject = Nothing
                 
            End If
        Next
        End If
        
    End With
   
End Sub

Betrifft: AW: Object einbetten mit Icon
von: volti
Geschrieben am: 16.10.2020 15:18:16

Hallo Thomas,

schau mal, ob die u.a. Erweiterung schon Deinem Wunsche entspricht. Anfangs-Zeile/Spalte und Anzahl der Spalten kannst im Kopf vorgeben.

Code:
[Cc][+][-] 
Option Explicit

Private Declare PtrSafe Function FindExecutableA Lib "shell32.dll" ( _
    ByVal lpFile As String, _
    ByVal lpDirectory As String, _
    ByVal lpResult As String) As Long
Private Declare PtrSafe Function LockWindowUpdate Lib "user32.dll" ( _
    ByVal hwndLock As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As Long

Private Const MAX_PATH As Long = 260&

Public Sub InsertFileObjectNEU()
    
    Dim objOLEObject As OLEObject
    Dim lngReturn As Long
    Dim strPath As String, strFilename As String, strDisplayName As String
    Dim strTemp As String * MAX_PATH, strExecutable As String
    
    Dim vntItem As Variant
    Dim lngRow As Long, lngColumn As Long
    Dim lngMaxColumn As Long, lngMaxRow As Long
    Dim lngRowBegin As Long, lngColumnBegin As Long
    Dim bCheck As Boolean
    
    lngRowBegin = 4
    lngColumnBegin = 2
    lngMaxColumn = 10
    lngMaxRow = 20

    With Application.FileDialog(msoFileDialogFilePicker)
  
      .Filters.Clear
      .Title = "Add General Document"
      .AllowMultiSelect = False
        
      If .Show Then
         For Each vntItem In .SelectedItems
        
           bCheck = False
           For lngRow = lngRowBegin To lngMaxRow Step 5
              For lngColumn = lngColumnBegin To lngMaxColumn Step 2
                  If (IsEmpty(ActiveSheet.Cells(lngRow, lngColumn)) = True) Then
                    bCheck = True: Exit For
                  End If
              Next lngColumn
              If bCheck = True Then Exit For
           Next lngRow
               
           strPath = .SelectedItems(1)
           If InStr(".pdf .xls xlsm xlsx xlsb .jpg", LCase(Right(strPath, 4))) > 0 Then
             
             strFilename = Mid$(strPath, InStrRev(strPath, "\") + 1)
             strFilename = Left$(strFilename, InStrRev(strFilename, ".") - 1)
            
             lngReturn = FindExecutableA(strPath, vbNullString, strTemp)
            
             If lngReturn > 32 Then
                 strExecutable = Left$(strTemp, InStr(strTemp & vbNullChar, vbNullChar) - 1)
             Else
                 Call MsgBox("Kein Programm zum Öffnen gefunden.", vbCritical, "Programmabbruch")
                 Exit Sub
             End If
            
             strDisplayName = InputBox("Bitte Anzeigetext eingeben.", "Einagbe", strFilename)
             If StrPtr(strDisplayName) <> 0 Then
               
                Call LockWindowUpdate(GetDesktopWindow)
                
                Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strExecutable, IconLabel:=strDisplayName)
                objOLEObject.ShapeRange.AlternativeText = strFilename
                
                With objOLEObject
                    .Left = Columns(lngColumn).Left
                    .Top = Rows(lngRow).Top
                End With
                
                ActiveSheet.Cells(lngRow, lngColumn) = lngColumn

                Call LockWindowUpdate(0&)
                
                Set objOLEObject = Nothing
             
             End If
                 
          Else
             Call MsgBox("Falsches Dateiformat!", vbCritical, "Programmabbruch")
             Exit Sub
           
           End If
         Next
      End If
        
    End With
   
End Sub

____________________
viele Grüße aus Freigericht
Karl-Heinz

Betrifft: AW: Object einbetten mit Icon
von: Thomas Mayer
Geschrieben am: 16.10.2020 16:23:17

funktioniert soweit. Die Frage ist, ob ich denn die Zelle unterhalb des Bilds mit lngColumn füllen muß. Danke dir. hat mich schon weiter gebracht.

Betrifft: AW: Object einbetten mit Icon
von: volti
Geschrieben am: 16.10.2020 16:33:48

Hallo Thomas,

in der Vorlage war das so. Hiermit wird abgefragt, ob ein potenzielles Feld schon belegt ist und dort kein Bild hin soll.
Da muss zwar nicht die Nummer rein, aber irgendwas, damit erkannt werden kann, ob das Feld leer ist.

Alternative wäre (wenn es total stören sollte) das Durchgehen aller vorhandener Objekte und die Ermittlung des jeweiligen Feldes über linke/obere Eckposition des Objekts und dann die Ermittlung des ersten freien Feldes.

Machbar, aber deutlich aufwändiger....

viele Grüße
Karl-Heinz

Betrifft: AW: Object einbetten mit Icon
von: volti
Geschrieben am: 16.10.2020 17:00:36

Hallo Thomas,

hab's jetzt doch mal ohne Nummern gemacht....

Code:
[Cc][+][-] 
Option Explicit

Private Declare PtrSafe Function FindExecutableA Lib "shell32.dll" ( _
    ByVal lpFile As String, _
    ByVal lpDirectory As String, _
    ByVal lpResult As String) As Long
Private Declare PtrSafe Function LockWindowUpdate Lib "user32.dll" ( _
    ByVal hwndLock As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As Long

Private Const MAX_PATH As Long = 260&

Public Sub InsertFileObjectNEU()
    
    Dim objOLEObject As OLEObject
    Dim lngReturn As Long
    Dim strPath As String, strFilename As String, strDisplayName As String
    Dim strTemp As String * MAX_PATH, strExecutable As String
    
    Dim vntItem As Variant
    Dim lngRow As Long, lngColumn As Long
    Dim lngMaxColumn As Long, lngMaxRow As Long
    Dim lngRowBegin As Long, lngColumnBegin As Long
    Dim bCheck As Boolean, bBesetzt As Boolean
    Dim oShape As Object, AC As Range
    
    lngRowBegin = 4
    lngColumnBegin = 2
    lngMaxColumn = 10
    lngMaxRow = 20

    With Application.FileDialog(msoFileDialogFilePicker)
  
      .Filters.Clear
      .Title = "Add General Document"
      .AllowMultiSelect = False
        
      If .Show Then
         For Each vntItem In .SelectedItems
        
           bCheck = False
           For lngRow = lngRowBegin To lngMaxRow Step 5
              For lngColumn = lngColumnBegin To lngMaxColumn Step 2
                  
                  Set AC = ActiveSheet.Cells(lngRow, lngColumn)
                  bBesetzt = False
                  
                  For Each oShape In ActiveSheet.Shapes
                     With oShape
                       If .Top > AC.Top - 2 And .Left > AC.Left - 2 _
                          And .Top < AC.Top + 5 And .Left < AC.Left + 5 Then
                          bBesetzt = True: Exit For
                       End If
                     End With
                  Next oShape
                  
                  If bBesetzt = False Then bCheck = True: Exit For

              Next lngColumn
              If bCheck = True Then Exit For
           Next lngRow
               
           strPath = .SelectedItems(1)
           If InStr(".pdf .xls xlsm xlsx xlsb .jpg", LCase(Right(strPath, 4))) > 0 Then
             
             strFilename = Mid$(strPath, InStrRev(strPath, "\") + 1)
             strFilename = Left$(strFilename, InStrRev(strFilename, ".") - 1)
            
             lngReturn = FindExecutableA(strPath, vbNullString, strTemp)
            
             If lngReturn > 32 Then
                 strExecutable = Left$(strTemp, InStr(strTemp & vbNullChar, vbNullChar) - 1)
             Else
                 Call MsgBox("Kein Programm zum Öffnen gefunden.", vbCritical, "Programmabbruch")
                 Exit Sub
             End If
            
             strDisplayName = InputBox("Bitte Anzeigetext eingeben.", "Einagbe", strFilename)
             If StrPtr(strDisplayName) <> 0 Then
               
                Call LockWindowUpdate(GetDesktopWindow)
                
                Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strExecutable, IconLabel:=strDisplayName)
                objOLEObject.ShapeRange.AlternativeText = strFilename
                
                With objOLEObject
                    .Left = Columns(lngColumn).Left
                    .Top = Rows(lngRow).Top
                End With

                Call LockWindowUpdate(0&)
                
                Set objOLEObject = Nothing
             
             End If
                 
          Else
             Call MsgBox("Falsches Dateiformat!", vbCritical, "Programmabbruch")
             Exit Sub
           
           End If
         Next
      End If
        
    End With
   
End Sub

____________________
viele Grüße aus Freigericht
Karl-Heinz

Betrifft: AW: Object einbetten mit Icon
von: Thomas Mayer
Geschrieben am: 16.10.2020 17:47:03

zu spät gesehen... funktioniert bestens. Habe es noch mit .locked=False erweitert um es wieder zu löschen, da mein Worksheet protected ist.

Betrifft: AW: Object einbetten mit Icon
von: Thomas Mayer
Geschrieben am: 16.10.2020 17:41:54

genau, so habe ich das auch verstanden. Ist es denn möglich, beim Entfernen (durch Del taste) auch die Zelle zu leeren?

Herbers Excel/VBA-Archiv

Der kurze Weg zum Ziel: Auftragsprogrammierung

Object einbetten mit Icon