Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Label
BildScreenshot zu Label Label-Seite mit Beispielarbeitsmappe aufrufen

Object einbetten mit Icon

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?