Excel 2003 Bild vom Laufwerk einfügen???

  • #41
Dann gibts eben noch ein Makro  ;D

Gruß Matjes ;)
Code: 
'***********************************************************
Sub NurZellenMitBildernSperren()
->Auf dem aktuellen Blatt
->a) wird eine ggf. vorhandener Blattschutz entfernt
->  (ohne Paßwort)
->b) für alle Zellen wird Format->Zellen->Schutz->gesperrt entfernt
->c) für alle Zellen, die ein Bild enthalten, wird
->  Format->Zellen->Schutz->gesperrt wieder gesetzt
->d) Blattschutz wird wieder gesetzt (ohne Paßwort)
->Voraussetzung:
-> - Seite darf nicht Passwort-geschützt sein
 
 
 Dim ws As Worksheet, sh As Shape
 Dim l_Spalte As Long
 
->aktives Blatt setzen
 Set ws = ActiveSheet
 
->Blatt-Schutz ausschalten
 On Error Resume Next
 ws.Unprotect
 If Err.Number <> 0 Then
  MsgBox Blatt-Schutz konnte nicht entfernt werden.
  GoTo AUFRAEUMEN
 End If
 On Error GoTo 0
 
->Format->Zellen->Schutz->gesperrt entfernen
 ws.Cells.Locked = False
 
->*** Zellen mit Bild Format->Zellen->Schutz->gesperrt setzen
 On Error Resume Next
 For Each sh In ws.Shapes
  l_Spalte = sh.TopLeftCell.Column
  If Err.Number = 0 Then
   ws.Cells(sh.TopLeftCell.Row, sh.TopLeftCell.Column).Locked = True
  Else
   Err.Clear
  End If
 Next
 On Error GoTo 0
  
 ws.Cells(1, 1).Select
->Blattschutz einschalten, damit Zell-Sperre wirksam wird
 ws.Protect
 
 
AUFRAEUMEN:
 Set ws = Nothing: Set sh = Nothing
End Sub
 
  • #42
Da mit Blattschutz das Ein-/Ausblenden von Zeilen verhindert wird, noch 2 Makros mit denen das dann doch geht  ;D

Code: 
'***********************************************************
Sub SelektierteZeilenAusblenden()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) die selektierten Zeilen werden eingeblendet
 ->c) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  Dim ws As Worksheet
 ->aktives Blatt setzen
  Set ws = ActiveSheet
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
 ->Zeilen ausblenden
  Selection.EntireRow.Hidden = True
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub

'***********************************************************
Sub SelektierteZeilenEinblenden()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) die selektierten Zeilen werden eingeblendet
 ->c) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  Dim ws As Worksheet
 ->aktives Blatt setzen
  Set ws = ActiveSheet
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
 ->Zeilen einblenden
  Selection.EntireRow.Hidden = False
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub
 
  • #43
das geht aber fix!

das mit dem blattschutz habe ich gemacht.
aber ich verstehe den unterschied nicht ganu. die eingefügten bilder sind gechützt. supi. aber in den anderen zellen kann ich den text dann trotzdem nicht ändern. bzw. keinen schreiben. kann das makro für den bildschutz direkt in das andere makro für das bild einfügen eingebunden werden?
 
  • #44
Hallo Thorsten,

hier nochmal alle Makros für dich in einem Stück. Packe sie in ein Modul.

SelektierteZelleJPEGEinfügenMitAuswahl() ist nochmal etwas erweitert.
Damit schon eingefügte Bilder bei der ggf. notwendigen Erweiterung der Spaltenbreite bzgl. eines neuen Bildes nicht verzerren, wird für alle Bilder der Spalte der Modus xlMove eingestellt, dann die Spalte verbreitert und abschliessend wieder der Modus xlMoveAndSize eingestellt.

Aus meinen Augen ist damit dein Wunsch-Makro erstmal abgeschlossen, es sei denn du findest noch bugs  ;D

Gruß Matjes :)
Code: 
Option Explicit
'***********************************************************
Sub SelektierteZelleJPEGEinfügenMitAuswahl()
 ->Das Makro
 ->a) fügt in die monentan selektierte Zelle ein Bild ein,
 ->   das an diese Zelle gebunden wird.
 ->b) Auswahl des Bildes erfolgt online über einen aufzublendenden Auswahl-Dialog
 ->   (Überprüfung, ob ausgewähltes file ein Bild ist,
 ->    erfolgt über einen internen Filter)
 ->c) Zeilenhöhe wird entsprechend der Bildhöhe gesetzt.
 ->   Wird dabei eine maximale Höhe c_MAXBILDHOEHE überschritten,
 ->   wird die Bildhöhe darauf reduziert.
 ->d) Spalte der betreffenden Zelle wird auf die sich dann ergebende Bildbreite erweitert,
 ->   wenn das Bild nach der Skalierung breiter als die Spalte ist.
 ->e) Bild soll nicht mehr anwählbar sein, also geschützt.
 ->  (Schutz ohne Paßwort)
 ->
 ->Voraussetzung:
 -> - die Zelle darf nicht bereits ein Bild enthalten
 -> - Seite darf nicht Passwort-geschützt sein
  
  
  Const c_MAXBILDHOEHE = 100-> max. Bildhöhe in Punkten
  Const c_SICHERHEITSFAKTOR_BILDBREITE = 1.02
  Dim BILD_ENDUNGEN As Variant
  BILD_ENDUNGEN = Array(.jpg, .jpeg, .bmp)
  
  Dim ws As Worksheet, o_Bild As OLEObject, sh As Shape
  Dim s_DateinameFull As String, b_IstBild As Boolean
  Dim x1 As Long, l_Spalte As Long, lRow As Long, lCol As Long
  Dim l_faktor As Double, d_ColWidth As Double
  Dim d_colWidth_Pkt As Double, d_BildWidth_Pkt As Double
  Dim lCount As Long
  
 ->prüfen, ob Zelle markiert ist
  On Error Resume Next
  lCount = Selection.Count
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox Keine Zelle markiert. Ein Bild ?
    Exit Sub
  End If
  
 ->prüfen, ob nur eine Zelle selektiert ist
  If Selection.Count > 1 Then
    MsgBox Es darf nur eine zelle selektiert sein.
    Exit Sub
  End If
  
  s_DateinameFull = Application.GetOpenFilename
 ->Dialog abgebrochen ?
  If s_DateinameFull = False Or s_DateinameFull = Falsch Then Exit Sub
  
 ->file ein Bild ?
  b_IstBild = False
  For x1 = LBound(BILD_ENDUNGEN) To UBound(BILD_ENDUNGEN)
    If LCase(Right(s_DateinameFull, Len(BILD_ENDUNGEN(x1)))) = _
       LCase(BILD_ENDUNGEN(x1)) Then b_IstBild = True: Exit For
  Next
  If Not b_IstBild Then
    MsgBox file-Typ ist nicht im Filter BILD_ENDUNG enthalten.
    Exit Sub
  End If
  
 ->*** na dann an die Arbeit
  Set ws = ActiveSheet
  lRow = Selection.Row
  lCol = Selection.Column
  
 ->*** pruefen, ob Zelle bereits ein Bild enthält
  On Error Resume Next
  For Each sh In ws.Shapes
    l_Spalte = sh.TopLeftCell.Column
    If Err.Number = 0 Then
      If l_Spalte = lCol Then
        If sh.TopLeftCell.Row = lRow Then
          MsgBox Die selektierte Zelle enthält bereits ein Bild.
          GoTo AUFRAEUMEN
        End If
      End If
    Else
      Err.Clear
    End If
  Next
  On Error GoTo 0
    
 ->Blatt-Schutz
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
 ->alten Zellinhalt entfernen
  ws.Cells(lRow, lCol).Value = 
    
 ->*** Bild eintragen
 ->Zelle markieren
 ->Bild als Objekt einfügen
  On Error Resume Next
  ws.Cells(lRow, lCol).Select
  ws.OLEObjects.Add(FileName:=s_DateinameFull, _
    Link:=False, DisplayAsIcon:=False).Select
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox Das Bild  & s_DateinameFull &  konnte nicht eingefügt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
  Set o_Bild = Selection
  o_Bild.Placement = xlMove->xlFreeFloating
  o_Bild.PrintObject = True
  
 ->Bildhöhe begrenzen
  If o_Bild.Height > c_MAXBILDHOEHE Then
   ->skalieren
    l_faktor = c_MAXBILDHOEHE / o_Bild.Height
    o_Bild.ShapeRange.ScaleWidth l_faktor, msoFalse, msoScaleFromTopLeft
    o_Bild.ShapeRange.ScaleHeight l_faktor, msoFalse, msoScaleFromTopLeft
  End If
  
 ->Zeilenhöhe dem Bild anpassen
  ws.Rows(lRow).RowHeight = o_Bild.Height
  
 ->Breite der Spalte anpassen, wenn Bild breiter als Spalte
  d_ColWidth = ws.Cells(lRow, lCol).ColumnWidth
  d_colWidth_Pkt = ws.Cells(lRow, lCol).Width->in Punkt
  d_BildWidth_Pkt = o_Bild.ShapeRange.Width   'in Punkt
 ->kleiner Koorekturfaktor, damit Bild nicht über den rand hinausschaut
  d_BildWidth_Pkt = d_BildWidth_Pkt * c_SICHERHEITSFAKTOR_BILDBREITE
 ->Bild breiter als Spalte - > Spalte auf Bild-Breite
  If d_BildWidth_Pkt > d_colWidth_Pkt Then
    
   ->Bilder dieser Spalte auf xlMove, damit sie nicht verzerrt werden
    On Error Resume Next
    For Each sh In ws.Shapes
      l_Spalte = sh.TopLeftCell.Column
      If Err.Number = 0 Then
        If l_Spalte = lCol Then
          sh.Placement = xlMove
        End If
      Else
        Err.Clear
      End If
    Next
    On Error GoTo 0
   
   ->Splate Breite anpassen
    d_ColWidth = d_BildWidth_Pkt / d_colWidth_Pkt * d_ColWidth * c_SICHERHEITSFAKTOR_BILDBREITE
    ws.Columns(lCol).ColumnWidth = d_ColWidth
    
   ->Bilder dieser Spalte wieder auf xlMoveAndSize
    On Error Resume Next
    For Each sh In ws.Shapes
      l_Spalte = sh.TopLeftCell.Column
      If Err.Number = 0 Then
        If l_Spalte = lCol Then
          sh.Placement = xlMove
        End If
      Else
        Err.Clear
      End If
    Next
    On Error GoTo 0
    
  End If
 ->Um Bild mit Spalte ausblenden zu können, Bild mit Zelle verbinden
  o_Bild.Placement = xlMoveAndSize
  
 ->Zelle gesperrt setzen
  ws.Cells(lRow, lCol).Locked = True
  
  ws.Cells(1, 1).Select
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
  
AUFRAEUMEN:
  Set ws = Nothing: Set o_Bild = Nothing: Set sh = Nothing
End Sub
'***********************************************************
Sub SelektierteZeilenAusblenden()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) die selektierten Zeilen werden eingeblendet
 ->c) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  Dim ws As Worksheet
 ->aktives Blatt setzen
  Set ws = ActiveSheet
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
 ->Zeilen ausblenden
  Selection.EntireRow.Hidden = True
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub

'***********************************************************
Sub SelektierteZeilenEinblenden()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) die selektierten Zeilen werden eingeblendet
 ->c) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  Dim ws As Worksheet
 ->aktives Blatt setzen
  Set ws = ActiveSheet
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
 ->Zeilen einblenden
  Selection.EntireRow.Hidden = False
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub
'***********************************************************
Sub NurZellenMitBildernSperren()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) für alle Zellen wird Format->Zellen->Schutz->gesperrt entfernt
 ->c) für alle Zellen, die ein Bild enthalten, wird
 ->   Format->Zellen->Schutz->gesperrt wieder gesetzt
 ->d) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  
  Dim ws As Worksheet, sh As Shape
  Dim l_Spalte As Long
  
 ->aktives Blatt setzen
  Set ws = ActiveSheet
  
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
 ->Format->Zellen->Schutz->gesperrt entfernen
  ws.Cells.Locked = False
  
 ->*** Zellen mit Bild  Format->Zellen->Schutz->gesperrt setzen
  On Error Resume Next
  For Each sh In ws.Shapes
    l_Spalte = sh.TopLeftCell.Column
    If Err.Number = 0 Then
      ws.Cells(sh.TopLeftCell.Row, sh.TopLeftCell.Column).Locked = True
    Else
      Err.Clear
    End If
  Next
  On Error GoTo 0
    
  ws.Cells(1, 1).Select
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
  
AUFRAEUMEN:
  Set ws = Nothing: Set sh = Nothing
End Sub
 
  • #45
Damit du die anderen Zellen (nicht Bildzellen) editieren kannst, führe einmal NurZellenMitBildernSperren() aus.

Gruß Matjes :)
 
  • #46
hallo matjes,

nochmals vielen Dank.

Jetzt wollte ich für das Makro button´s zuweisen!

Habe daher hier in dem super forum gesucht und bin auch fündig geworden. unter Makro schreiben hast du erklärt wie es geht.

aber ich kann dem button das makro nicht zuweisen! es wird mir in der liste nicht angezeigt. mache ich aber mit alt + f11 das menü auf steht es dort. was mache in nun wieder falsch?
 
  • #47
Hallo Thorsten,

was da falsch läuft ????????????

Ich hab es eben folgendemassen probiert:

a) Excel-Datei mit den Makros aktiviert
b) Maus auf Menü-Leisten-rechte Maustaste -> Anpassen
c) Im Anpassen-Fenster
c1) Reiter Symbolleisten -> Neu ->Name z.B. JPEGS
neu Menüleiste in Menüleisten positionieren
c2) Reiter Befehle -> Kategorie Makro -> Befehle->Schaltfläche anpassen auf neu MenüLeiste ziehen
c3) neuen Button mit rechter Maustaste anklicken -> Makros zuweisen
entsprechenden Makro auswählen
....

Wahrscheinlich ist Punkt a) massgebend.

Gruß Matjes :)
 
  • #48
hmm, es klappt. ich habe irgendwie etwas durcheinander gebracht.
hatte es irgendwie als add-in drin. habe nochmals alles so gemacht wie bechrieben. jetzt funktioniert es auch. aber das erste blatt heißt jetzt so wie der name den ich für das xla vergeben haben!

warum es als add-in ist keine ahnung. wie gesagt bin hier echt ne niete. aber geht das als add-in? dann wäre es doch bei jedem arbeitsbaltt vorhanden, oder??? ich werde nochmals über die such funktion gehen!
 
  • #49
son´n mist, jetzt hatte ich es als xls gespeichert :'(. nun nochmal!
 
  • #50
Hallo Thorsten,

das braucht keine xla zu sein. Wenn Du die Symbolleiste , die Button und die Zuweisung der Makros erstellt hast, wird in der Zuweisung auch der Pfad gespeichert (das sieht man nur nicht).

Sollte die Datei mit den Makros dann später nicht geöffnet sein, wird sie bei Betätigung des Buttons automatisch geöffnet.

Gruß Matjes :)

ps: mit xla wäre ich vorsichtig ...
 
  • #51
hallo matjes,

jetzt klappte es. habe es als xls und name mappe 1 gespeichert. der fehler denke ich war des ich es wie unter makro einfügen als xla gespeichert hatte!

so, aber du hast noch keine ruhe vor mir :|

wie kann ich den ein einzelnes bild wieder frei geben??? z.b wenn ich ein falsch eingefügt habe :??!?

das wäre glaube ich der letzte Punkt den ich hätte!
:1 O0 O0
 
  • #52
hat sich erledigt,

habe es gefunden. blattschutz aufheben und dann kann ich wieder auf bilder sperren drücken.



So nun wird das Protokoll gebastelt. Also nochmals VIELEN DANK
 
  • #53
Hallo thorsten,

einen kleinen Bug hab ich noch korrigiert (ist gekennzeichnet).

Zum Anlegen bzw. Löschen einer Menüleiste für die benötigten Makros hab ich noch
- MenuLeisteJPEGSEinfuegen()
- MenuLeisteJPEGSLoeschen()
hinzugefügt.

Als weiter Möglichkeit auch als Menü
- MenuJPEGSEinfuegen()
- MenuJPEGSLoeschen()

Gruß Matjes :)
Code: 
Option Explicit

Private Const c_MENULEISTE_NAME = JPEGS_MENU->Menü-Leisten-Name
Private Const c_MENU_NAME = &Jpeg-Bilder     ->Menü-Name
Private Const c_MAXBILDHOEHE = 100-> max. Bildhöhe in Punkten


'***********************************************************
Sub SelektierteZelleJPEGEinfügenMitAuswahl()
 ->Das Makro
 ->a) fügt in die monentan selektierte Zelle ein Bild ein,
 ->   das an diese Zelle gebunden wird.
 ->b) Auswahl des Bildes erfolgt online über einen aufzublendenden Auswahl-Dialog
 ->   (Überprüfung, ob ausgewähltes file ein Bild ist,
 ->    erfolgt über einen internen Filter)
 ->c) Zeilenhöhe wird entsprechend der Bildhöhe gesetzt.
 ->   Wird dabei eine maximale Höhe c_MAXBILDHOEHE überschritten,
 ->   wird die Bildhöhe darauf reduziert.
 ->d) Spalte der betreffenden Zelle wird auf die sich dann ergebende Bildbreite erweitert,
 ->   wenn das Bild nach der Skalierung breiter als die Spalte ist.
 ->e) Bild soll nicht mehr anwählbar sein, also geschützt.
 ->  (Schutz ohne Paßwort)
 ->
 ->Voraussetzung:
 -> - die Zelle darf nicht bereits ein Bild enthalten
 -> - Seite darf nicht Passwort-geschützt sein
  
  
  Const c_SICHERHEITSFAKTOR_BILDBREITE = 1.02
  Dim BILD_ENDUNGEN As Variant
  BILD_ENDUNGEN = Array(.jpg, .jpeg, .bmp)
  
  Dim ws As Worksheet, o_Bild As OLEObject, sh As Shape
  Dim s_DateinameFull As String, b_IstBild As Boolean
  Dim x1 As Long, l_Spalte As Long, lRow As Long, lCol As Long
  Dim l_faktor As Double, d_ColWidth As Double
  Dim d_colWidth_Pkt As Double, d_BildWidth_Pkt As Double
  Dim lCount As Long
  
 ->prüfen, ob Zelle markiert ist
  On Error Resume Next
  lCount = Selection.Count
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox Keine Zelle markiert. Ein Bild ?
    Exit Sub
  End If
  
 ->prüfen, ob nur eine Zelle selektiert ist
  If Selection.Count > 1 Then
    MsgBox Es darf nur eine zelle selektiert sein.
    Exit Sub
  End If
  
  s_DateinameFull = Application.GetOpenFilename
 ->Dialog abgebrochen ?
  If s_DateinameFull = False Or s_DateinameFull = Falsch Then Exit Sub
  
 ->file ein Bild ?
  b_IstBild = False
  For x1 = LBound(BILD_ENDUNGEN) To UBound(BILD_ENDUNGEN)
    If LCase(Right(s_DateinameFull, Len(BILD_ENDUNGEN(x1)))) = _
       LCase(BILD_ENDUNGEN(x1)) Then b_IstBild = True: Exit For
  Next
  If Not b_IstBild Then
    MsgBox file-Typ ist nicht im Filter BILD_ENDUNG enthalten.
    Exit Sub
  End If
  
 ->*** na dann an die Arbeit
  Set ws = ActiveSheet
  lRow = Selection.Row
  lCol = Selection.Column
  
 ->*** pruefen, ob Zelle bereits ein Bild enthält
  On Error Resume Next
  For Each sh In ws.Shapes
    l_Spalte = sh.TopLeftCell.Column
    If Err.Number = 0 Then
      If l_Spalte = lCol Then
        If sh.TopLeftCell.Row = lRow Then
          MsgBox Die selektierte Zelle enthält bereits ein Bild.
          GoTo AUFRAEUMEN
        End If
      End If
    Else
      Err.Clear
    End If
  Next
  On Error GoTo 0
    
 ->Blatt-Schutz
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
 ->alten Zellinhalt entfernen
  ws.Cells(lRow, lCol).Value = 
    
 ->*** Bild eintragen
 ->Zelle markieren
 ->Bild als Objekt einfügen
  On Error Resume Next
  ws.Cells(lRow, lCol).Select
  ws.OLEObjects.Add(FileName:=s_DateinameFull, _
    Link:=False, DisplayAsIcon:=False).Select
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox Das Bild  & s_DateinameFull &  konnte nicht eingefügt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
  Set o_Bild = Selection
  o_Bild.Placement = xlMove->xlFreeFloating
  o_Bild.PrintObject = True
  
 ->Bildhöhe begrenzen
  If o_Bild.Height > c_MAXBILDHOEHE Then
   ->skalieren
    l_faktor = c_MAXBILDHOEHE / o_Bild.Height
    o_Bild.ShapeRange.ScaleWidth l_faktor, msoFalse, msoScaleFromTopLeft
    o_Bild.ShapeRange.ScaleHeight l_faktor, msoFalse, msoScaleFromTopLeft
  End If
  
 ->Zeilenhöhe dem Bild anpassen
  ws.Rows(lRow).RowHeight = o_Bild.Height
  
 ->Breite der Spalte anpassen, wenn Bild breiter als Spalte
  d_ColWidth = ws.Cells(lRow, lCol).ColumnWidth
  d_colWidth_Pkt = ws.Cells(lRow, lCol).Width->in Punkt
  d_BildWidth_Pkt = o_Bild.ShapeRange.Width   'in Punkt
 ->kleiner Koorekturfaktor, damit Bild nicht über den rand hinausschaut
  d_BildWidth_Pkt = d_BildWidth_Pkt * c_SICHERHEITSFAKTOR_BILDBREITE
 ->Bild breiter als Spalte - > Spalte auf Bild-Breite
  If d_BildWidth_Pkt > d_colWidth_Pkt Then
    
   ->Bilder dieser Spalte auf xlMove, damit sie nicht verzerrt werden
    On Error Resume Next
    For Each sh In ws.Shapes
      l_Spalte = sh.TopLeftCell.Column
      If Err.Number = 0 Then
        If l_Spalte = lCol Then
          sh.Placement = xlMove
        End If
      Else
        Err.Clear
      End If
    Next
    On Error GoTo 0
   
   ->Splate Breite anpassen
    d_ColWidth = d_BildWidth_Pkt / d_colWidth_Pkt * d_ColWidth * c_SICHERHEITSFAKTOR_BILDBREITE
    ws.Columns(lCol).ColumnWidth = d_ColWidth
    
   ->Bilder dieser Spalte wieder auf xlMoveAndSize
    On Error Resume Next
    For Each sh In ws.Shapes
      l_Spalte = sh.TopLeftCell.Column
      If Err.Number = 0 Then
        If l_Spalte = lCol Then
          sh.Placement = xlMoveAndSize->korrigiert 29.5.2006
        End If
      Else
        Err.Clear
      End If
    Next
    On Error GoTo 0
    
  End If
 ->Um Bild mit Spalte ausblenden zu können, Bild mit Zelle verbinden
  o_Bild.Placement = xlMoveAndSize
  
 ->Zelle gesperrt setzen
  ws.Cells(lRow, lCol).Locked = True
  
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
  
AUFRAEUMEN:
  Set ws = Nothing: Set o_Bild = Nothing: Set sh = Nothing
End Sub
'***********************************************************
Sub SelektierteZeilenAusblenden()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) die selektierten Zeilen werden eingeblendet
 ->c) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  Dim ws As Worksheet
 ->aktives Blatt setzen
  Set ws = ActiveSheet
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
 ->Zeilen ausblenden
  Selection.EntireRow.Hidden = True
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub

'***********************************************************
Sub SelektierteZeilenEinblenden()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) die selektierten Zeilen werden eingeblendet
 ->c) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  Dim ws As Worksheet
 ->aktives Blatt setzen
  Set ws = ActiveSheet
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
 ->Zeilen einblenden
  Selection.EntireRow.Hidden = False
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub
'***********************************************************
Sub NurZellenMitBildernSperren()
 ->Auf dem aktuellen Blatt
 ->a) wird eine ggf. vorhandener Blattschutz entfernt
 ->   (ohne Paßwort)
 ->b) für alle Zellen wird Format->Zellen->Schutz->gesperrt entfernt
 ->c) für alle Zellen, die ein Bild enthalten, wird
 ->   Format->Zellen->Schutz->gesperrt wieder gesetzt
 ->d) Blattschutz wird wieder gesetzt (ohne Paßwort)
 ->Voraussetzung:
 -> - Seite darf nicht Passwort-geschützt sein
  
  
  Dim ws As Worksheet, sh As Shape
  Dim l_Spalte As Long
  
 ->aktives Blatt setzen
  Set ws = ActiveSheet
  
 ->Blatt-Schutz ausschalten
  On Error Resume Next
  ws.Unprotect
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
 ->Format->Zellen->Schutz->gesperrt entfernen
  ws.Cells.Locked = False
  
 ->*** Zellen mit Bild  Format->Zellen->Schutz->gesperrt setzen
  On Error Resume Next
  For Each sh In ws.Shapes
    l_Spalte = sh.TopLeftCell.Column
    If Err.Number = 0 Then
      ws.Cells(sh.TopLeftCell.Row, sh.TopLeftCell.Column).Locked = True
    Else
      Err.Clear
    End If
  Next
  On Error GoTo 0
    
 ->Blattschutz einschalten, damit Zell-Sperre wirksam wird
  ws.Protect
  
  
AUFRAEUMEN:
  Set ws = Nothing: Set sh = Nothing
End Sub
'***********************************************************
Sub MenuLeisteJPEGSLoeschen()
'***
'*** Löscht die Menüleiste c_MENULEISTE_NAME
  
  Dim cmdbar As CommandBar
  
 ->schauen, ob MenuLeiste schon existiert
  For Each cmdbar In Application.CommandBars
    If cmdbar.Name = c_MENULEISTE_NAME Then
      Application.DisplayAlerts = False
      cmdbar.Delete
      Application.DisplayAlerts = True
      Exit For
    End If
  Next
  
AUFRAEUMEN:
  Set cmdbar = Nothing
End Sub
'***********************************************************
Sub MenuLeisteJPEGSEinfuegen()
'***
'*** Legt die Menüleiste c_MENULEISTE_NAME an
'*** - Bild einfügen           -> SelektierteZelleJPEGEinfügenMitAuswahl()
'*** - Zeilen ausblenden       -> SelektierteZeilenAusblenden()
'*** - Zeilen einblenden       -> SelektierteZeilenEinblenden()
'*** - Nur Bild-Zellen sperren -> NurZellenMitBildernSperren()

  Dim cmdbar As CommandBar, Ctrl As CommandBarControl
  
 ->schauen, ob MenuLeiste schon existiert
  For Each cmdbar In Application.CommandBars
    If cmdbar.Name = c_MENULEISTE_NAME Then
     ->bereits vorhanden
     ->ausgeblendet? -> sichtbar machen
      If Not cmdbar.Visible Then cmdbar.Visible = True
      MsgBox Menu-Leiste-> & c_MENULEISTE_NAME &-> bereits vorhanden.
      GoTo AUFRAEUMEN
    End If
  Next
  
 ->noch nicht vorhanden - dann anlegen
  
 ->Symbolleiste anlegen
  Set cmdbar = Application.CommandBars.Add(Name:=c_MENULEISTE_NAME)
  cmdbar.Position = msoBarTop
  cmdbar.Visible = True
  
  Set Ctrl = cmdbar.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = Bild einfügen
    .OnAction = SelektierteZelleJPEGEinfügenMitAuswahl
    .BeginGroup = True
    .TooltipText = Bild einfügen
  End With
  
  Set Ctrl = cmdbar.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = Zeilen ausblenden
    .OnAction = SelektierteZeilenAusblenden
    .BeginGroup = True
    .TooltipText = Selektierte Zeilen ausblenden
  End With
  
  Set Ctrl = cmdbar.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = Zeilen einblenden
    .OnAction = SelektierteZeilenEinblenden
    .BeginGroup = True
    .TooltipText = Selektierte Zeilen einblenden
  End With
  
  Set Ctrl = cmdbar.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = Nur Bild-Zellen sperren
    .OnAction = NurZellenMitBildernSperren
    .BeginGroup = True
    .TooltipText = Nur Zellen mit Bildern sperren
  End With
  
AUFRAEUMEN:
  Set cmdbar = Nothing: Set Ctrl = Nothing
End Sub
'***********************************************************
Sub MenuJPEGSLoeschen()
'***
'*** Löscht die Menüleiste c_MENULEISTE_NAME
  
  Dim cmdPopUp As CommandBarPopup
  
 ->schauen, ob MenuLeiste schon existiert
  For Each cmdPopUp In Application.CommandBars(Worksheet Menu Bar).Controls
    If cmdPopUp.Caption = c_MENU_NAME Then
      Application.DisplayAlerts = False
      cmdPopUp.Delete
      Application.DisplayAlerts = True
      Exit For
    End If
  Next
  
AUFRAEUMEN:
  Set cmdPopUp = Nothing
End Sub
Sub MenuJPEGSEinfuegen()
'***
'*** Legt ein Menü c_MENU_NAME an
'*** - Bild einfügen           -> SelektierteZelleJPEGEinfügenMitAuswahl()
'*** - Zeilen ausblenden       -> SelektierteZeilenAusblenden()
'*** - Zeilen einblenden       -> SelektierteZeilenEinblenden()
'*** - Nur Bild-Zellen sperren -> NurZellenMitBildernSperren()

  Dim cmdbar As CommandBar, cmdPopUp As CommandBarPopup, Ctrl As CommandBarButton
  
 ->schauen, ob MenuLeiste schon existiert
  For Each cmdbar In Application.CommandBars
    If cmdbar.Name = c_MENU_NAME Then
     ->bereits vorhanden
     ->ausgeblendet? -> sichtbar machen
      If Not cmdbar.Visible Then cmdbar.Visible = True
      MsgBox Menu-> & c_MENU_NAME &-> bereits vorhanden.
      GoTo AUFRAEUMEN
    End If
  Next
  
 ->noch nicht vorhanden - dann anlegen
  
  Set cmdPopUp = Application.CommandBars(Worksheet Menu Bar).Controls.Add _
                  (Type:=msoControlPopup)
  cmdPopUp.Caption = c_MENU_NAME
  
  Set Ctrl = cmdPopUp.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = &Bild einfügen
    .OnAction = SelektierteZelleJPEGEinfügenMitAuswahl
    .BeginGroup = True
    .TooltipText = Bild einfügen
  End With
  
  Set Ctrl = cmdPopUp.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = Zeilen &ausblenden
    .OnAction = SelektierteZeilenAusblenden
    .BeginGroup = True
    .TooltipText = Selektierte Zeilen ausblenden
  End With
  
  Set Ctrl = cmdPopUp.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = Zeilen &einblenden
    .OnAction = SelektierteZeilenEinblenden
    .BeginGroup = True
    .TooltipText = Selektierte Zeilen einblenden
  End With
  
  Set Ctrl = cmdPopUp.Controls.Add(Type:=msoControlButton, Id:=1)
  With Ctrl
    .Style = msoButtonCaption
    .Caption = &nur Bild-Zellen sperren
    .OnAction = NurZellenMitBildernSperren
    .BeginGroup = True
    .TooltipText = Nur Zellen mit Bildern sperren
  End With
  
AUFRAEUMEN:
  Set cmdbar = Nothing: Set cmdPopUp = Nothing: Set Ctrl = Nothing
End Sub
 
  • #54
Hallo Matjes,

klappt alles bisher super! ich habe nur noch folgendes Problem! Ich habe mal ein Muster angelegt und hier zwei Bilder (700k) eingefügt. Die Größe der excel Datei ist 400k groß
Das erstellte Protokoll gespeichert. nun stelle ich fest, das die gespeicherte Datei ca 56.000k groß ist !!! Erstelle ich daraus ein pdf ist sie nur 59k groß!?


Kannst du hier helfen?
 
  • #55
Hallo thorsten,

gegen die Vergrößerung ist nichts zu machen - zunächst. :(

Du könntest unter 2003 das ganz als html speichern, dann müßten die bilder wieder abgespalten werden bzw. parallel zur Datei landen.

Gruß Matjes :)
 
  • #56
danke,

aber warum wird die datei soviel größer??
 
  • #57
Wird intern glaub ich als BITMAP gespeichert und da ist das Verhältnis halt so. Speicher mal ein jpg als bmp, da hast du ungefähr das gleiche Verhältnis.

Ich hab übrigens noch Versuch gemacht und die Bilder  als links und als Picture ( Bildrahmen) eingefügt, um die Dateigröße kleiner zu bekommen.

als Picture: die Dateigröße wächst genau wie bei der bisherigen Version.
als link:Bild wird nur als weisser Kasten dargestellt.

Gruß Matjes :)
 
  • #58
hallo matjes,

da bin ich wieder.
es gibt einen kleinen trick wie man die datei doch etwas schrumpfen lassen kann!
man konvertiert das bild in eine vga -Größe und komprimiert das ganzw dann noch auf 96 dpi.
habe aber noch keinen ausdruck gemacht, wie es dann wirklich aussieht.
Ist mir gestern mal eingefallen. werde es morgen mal in einem protokll erstellen. ansonsten ist die datei leider viel zu groß. aber so könnte es vielleicht noch gehen.

hast du schon vielleicht mitlerweile eine andere lösung? kann man irgendwie eine ole- verknüpfung machen? das zeigt er ja immer an, wenn man den photoed nicht installiert hat! den muß man bei 2003 ja noch dann installieren sonst zeigt excel2003 die bilder nicht an. dann kommt halt nur Einbetten:

Bis dann

thorsten, der den link weider gefunden hat :)
 
  • #59
Hallo Matjes
Habe da mal eine Frage bin VBA-Anfänger
wie wird dieser Befehl in der Exceltabelle
bzw. im VBA eingefügt. Kann ich den Code
einfach kopieren und ein fügen oder muss ich das abschreiben.
Danke schon mal für eine Antwort.

Gruß Charlie
 
Thema:

Excel 2003 Bild vom Laufwerk einfügen???

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.838
Beiträge
707.961
Mitglieder
51.491
Neuestes Mitglied
haraldmuc
Oben