Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1200to1204
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Anpassung Bild code vom Josef Ehrensberger

Anpassung Bild code vom Josef Ehrensberger
Karel
Hallo Leute,
Ich habe im Forum unterstehende schöne Code gefunden.
https://www.herber.de/forum/archiv/1104to1108/t1107770.htm
Kan het makro so angepasst worden, das wenn im Zelle B1 Pfadname steht und bildname in spalte C ab C3 stehen.
Also bildname in Spalte C
Pfadname im B1
Bilder im Spalte B einlesen anhand Dateiname Spalte C
Code vom Josef Ehrensberger
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importPictures()
Dim objShp As Shape
Dim strPath As String
Dim objFiles() As Object
Dim lngRes As Long, lngIndex As Long
strPath = fncBrowseForFolder
ActiveSheet.Shapes.SelectAll
Selection.Delete
If strPath "" Then
lngRes = FileSearchINFO(objFiles, strPath, "*.jpg;*.gif", False)
If lngRes > 0 Then
For lngIndex = 0 To UBound(objFiles)
ActiveSheet.Pictures.Insert (objFiles(lngIndex))
Set objShp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
Rows(lngIndex + 4).RowHeight = 141.75
With objShp
.Left = Columns(2).Left
.Top = Cells(lngIndex + 4, 2).Top
.LockAspectRatio = msoFalse
.Height = 141.75
.Width = 141.75
.AlternativeText = "small"
.OnAction = "resizePic"
End With
Next
End If
End If
End Sub
Sub resizePic()
Dim objShp As Shape
Set objShp = ActiveSheet.Shapes(Application.Caller)
With objShp
If .AlternativeText = "small" Then
.AlternativeText = ""
.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
.ZOrder msoBringToFront
Else
.LockAspectRatio = msoFalse
.Height = 141.75
.Width = 141.75
.AlternativeText = "small"
End If
End With
Set objShp = Nothing
End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*. _
*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Grüße
Karel
AW: Anpassung Bild code vom Josef Ehrensberger
24.02.2011 16:27:57
Josef

Hallo Karel,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Const cdblHeight As Double = 40.75

Sub importPictures()
  Dim objShp As Shape
  Dim strPath As String
  Dim lngRow As Long, lngLast As Long
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  With ActiveSheet
    strPath = .Range("B1").Text
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    
    .Shapes.SelectAll
    Selection.Delete
    
    .Rows.AutoFit
    
    lngLast = Application.Max(3, .Cells(Rows.Count, 3).End(xlUp).Row)
    
    For lngRow = 3 To lngLast
      If Dir(strPath & .Cells(lngRow, 3).Text, vbNormal) <> "" Then
        .Rows(lngRow).RowHeight = cdblHeight
        .Cells(lngRow, 2) = ""
        Set objShp = .Shapes.AddPicture(strPath & .Cells(lngRow, 3).Text, False, True, _
          .Cells(lngRow, 2).Left, .Cells(lngRow, 2).Top, cdblHeight, cdblHeight)
        objShp.AlternativeText = "small"
        objShp.OnAction = "resizePic"
      Else
        .Cells(lngRow, 2) = "Datei nicht gefunden!"
      End If
      Set objShp = Nothing
    Next
  End With
  
  ErrExit:
  Application.ScreenUpdating = True
End Sub


Sub resizePic()
  Dim objShp As Shape
  
  Set objShp = ActiveSheet.Shapes(Application.Caller)
  With objShp
    If .AlternativeText = "small" Then
      .AlternativeText = ""
      .ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
      .ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
      .ZOrder msoBringToFront
    Else
      .LockAspectRatio = msoFalse
      .Height = cdblHeight
      .Width = cdblHeight
      .AlternativeText = "small"
    End If
  End With
  Set objShp = Nothing
End Sub


Gruß Sepp

Anzeige
AW: Anpassung Bild code vom Josef Ehrensberger
26.02.2011 14:18:38
Karel
Hallo Sepp,
Sorry für die Späte zuruckmeldung aber ich wahr Unterwegs.
Habe dein Code probiert in einer Datei von mir,
aber er löscht alle Command buttons
beim alte code könnte ich Bild im zelle Positionieren
With objShp
.Left = Columns(1).Left + 2
.Top = Cells(lngIndex + 4, 1).Top + 2
.LockAspectRatio = msoFalse
.Height = 80
.Width = 80
.AlternativeText = "small"
.OnAction = "resizePic"
End With
Ist es auch möglich wenn kein bild dann Zeilehöhe wieder auf normal zurückgesetz wird

Die Datei https://www.herber.de/bbs/user/73741.xls wurde aus Datenschutzgründen gelöscht


Grüße
Karel
Anzeige
AW: Anpassung Bild code vom Josef Ehrensberger
26.02.2011 15:36:38
Karel
Hallo Sepp,
Einwandfrei ;-)
Aber Makro Bilder umbennen geht nicht mehr wa kanns dass dran liegen?
Gestestest auf Excel 2007
Grüße
Karel
AW: Anpassung Bild code vom Josef Ehrensberger
26.02.2011 16:27:21
Josef

Hallo Karel,
den Code hab ich mir nicht angesehen, du prüfst ja auch eine Spalte in der nichts steht!
So geht's.
'Umbenennen
Private Sub CommandButton2_Click()
  Dim lz As Long
  Dim zeile As Long
  Dim Pfad As String
  Dim fn_alt As String, fn_neu As String
  
  lz = Cells(Rows.Count, 3).End(xlUp).Row
  If lz < 4 Then lz = zeile
  Range("E4:E65536").ClearContents
  
  Pfad = Range("B1")
  If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
  
  For zeile = 4 To lz
    If Cells(zeile, 3) <> "" And Cells(zeile, 4) <> "" Then
      fn_alt = Pfad & Cells(zeile, 3)
      fn_neu = Pfad & Cells(zeile, 4)
      Name fn_alt As fn_neu
      Cells(zeile, 5) = "OK"
    End If
  Next zeile
End Sub


Gruß Sepp

Anzeige
AW: Anpassung Bild code vom Josef Ehrensberger
28.02.2011 15:22:27
Karel
Hallo Sepp,
Manchmal hat man ein brett für den Kopf.
Kan man Bild auch einlesen mit oder ohne Datei endung
123.jpg und/oder nur 123
Grüße
Karel
AW: Anpassung Bild code vom Josef Ehrensberger
28.02.2011 15:40:28
Karel
Hallo Sepp,
Manchmal hat man ein brett für den Kopf.
Kan man Bild auch einlesen mit oder ohne Datei endung
123.jpg und/oder nur 123
Grüße
Karel
AW: Anpassung Bild code vom Josef Ehrensberger
28.02.2011 16:27:34
Josef

Hallo Karel,
klar "kann man", aber dann musst du bei allen Makros die Dateiendung wieder dranhängen, wenn es nur jpg's sind OK, aber bei unterschiedlichen Dateitypen wirst du diesen irgendwo hinterlegen müssen.

Gruß Sepp

Anzeige
AW: Anpassung Bild code vom Josef Ehrensberger
28.02.2011 18:00:35
Karel
Hallo Sepp,
Nur jpg's
Ist praktisch, aus der grund beim artikelnummer 12345 ist dies gleich bildnummer.
Grüße
Karel
AW: Anpassung Bild code vom Josef Ehrensberger
01.03.2011 10:45:24
Karel
Hallo Sepp,
Danke, genau so.
Gruss
Karel
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige