Hallo Flupo,
danke für die Aufklärung über den Platzhalter .
Hallo M.O.,
bei der ersten Lösung ist es so, dass bei leerem Bildordner, nach herunter gefahrenem PC, die Fehlermeldung anstatt des Bildes erscheint.
Bei der 2. Lösung funktioniert es, bei leerem Bildordner ist nach dem wieder hochfahren des PC das eingefügte Bild noch vorhanden. aber mit der Scalierung happert es. Ich möchte das Bild in seiner Größe anpassen, dabei aber das Seitenverhältnis beibehalten.
Was mir noch fehlt, dass nach dem abspeichern der Datei das Bild im Bildordner noch gelöscht wird.
Jetzt noch mein Code:'
'
Public Sub SchildFotoEinf()
'..............................
'Schild-Foto-Einfügen
'..............................
'
Dim strText As String 'Schildnummer
Dim i As Integer 'MsgBox
Dim c As Integer 'Schaltknopf-Abfrage von der Bildvorbereitung
Dim e As Integer 'InputBox
Dim strPfad As String 'dre Pfad zum Wegweiser-Foto-Ordner
Dim strDatnam As String 'Foto-Ordner und Foto-Nr
'
Unload UserForm8 ' Auswahl UserForm archiviertes Schild bearbeiten
'
ActiveSheet.Unprotect '("freind")
'
c = MsgBox _
("Wurde das einzufügende Schild-Foto" & Chr(13) & _
"schon in den dazugehörenden Gebietsordner" & Chr(13) & _
" - SchildFoto - " & Chr(13) & _
" eingefügt ?" & Chr(13) & _
" Es darf auch nur dieses eine Foto " & Chr(13) & _
" in dem Ordner befinden!!!", _
vbYesNo + 256 + vbQuestion, "Schild-Foto-Prüfung") ' 256 ist Schaltknopf auf No activiert
'
If c = 7 Then Exit Sub ' 7=No
'
strPfad = "F:\1SchilderVerwaltung\SchildFoto\"
'prüfen, ob überhaupt ein Bild vorhanden ist - Endung ggf. anpassen
If Len(Dir(strPfad & "*.jpg")) = 0 Then
MsgBox "Kein Bild im Verzeichnis vorhanden!", 16, "Fehler"
Exit Sub
End If
'
' Wegweiser im Archivblatt nach seiner Wegweiser-Nummer suchen
Range("P51").Select 'Zelle für den Suchbeginn
strText = InputBox("Wegweiser-End-Nummer eingeben!!!", "Im Archiv suchen")
If strText = "" Then GoTo Ende
'
X:
ActiveSheet.Unprotect '("freind")
'
On Error GoTo Demo
'
Cells.Find(What:=strText, After:=ActiveCell, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:= _
xlByColumns, SearchDirection:=xlNext, MatchCase:=False). _
Activate
'
ActiveWindow.SmallScroll Down:=8 'geht noch 8 Zeilen nach unten, damit die ganze Archivierung zur Kontrolle zu sehen ist
'
i = MsgBox _
("Ist das die richtige Schild-Archivierung zum Foto-Einfügen ?" & Chr(13) & _
"Siehe links markierte, aktive Zelle!", _
1 + vbQuestion, "Einfügeprüfung")
'
If i = 2 Then GoTo Ende
GoTo Y ' überspringt Demo
'
Demo:
MsgBox ("Schildnummer im Archiv nicht vorhanden !!!" & Chr(13) & _
"Oder es ist kein Bild im Ordner - 4-Einfügen-Schild-Foto - " & Chr(13) & _
"vorbereitet.")
ActiveCell.Offset(-3, 0).Range("A1").Select 'geht auf den Datumseintrag
Selection.ClearContents 'Datumseintrag wieder löschen
Range("L1").Select
ActiveWindow.ScrollRow = 1
ActiveSheet.Protect '("freind")
Exit Sub
'
Y:
'........................
'Archivier-Datum einfügen
'........................
ActiveSheet.Range("L3").Copy 'kopiert das Datum Heute()
ActiveCell.Offset(-4, 52).Range("A1").Select 'Zelle für das Foto-Archivierungs-Datum
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'kopiert nur die Werte ein, sonst würde das Format eingefügt, also die Formel
Application.CutCopyMode = False 'beendet die KopieMarkierung = wie esc
'
ActiveCell.Offset(2, 0).Range("A1").Select 'Zelle für das Foto
'
'Name des 1. Bildes wird eingelesen und mit Pfad in Variable eingelesen
strDatnam = strPfad & Dir(strPfad & "*.jpg")
'Bild in ActiveZelle einfügen
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'DAS FUNKTIONIERT NICHT......................
'With ActiveSheet
' .Pictures.Insert (strDatnam)
' With .Pictures(.Pictures.Count)
' .Top = ActiveCell.Top
' .Left = ActiveCell.Left
' 'Bild wird skaliert
' .ShapeRange.ScaleWidth 0.51, msoFalse, msoScaleFromTopLeft
' .ShapeRange.ScaleHeight 0.51, msoFalse, msoScaleFromTopLeft
' End With
'End With
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'DAS FUNKTIONIERT....................
'Bild in (Zelle B10) ActiveCelle einfügen und skalieren
'ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Range("B10").Left, Range("B10").Top, 400, 320
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, ActiveCell.Left, ActiveCell.Top, 190, 252
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'?????????????????????????????????????????????????????????????????????????????????????????????????????????????????
' ich möchte das Seitenverhältnis des einzufügenden Bildes nicht ändern, aber ungefähr eine Breite von 7cm erhalten.
'Das bezieht sich auf meinem 20"Bildschirm, auf dem Notebook ist das ja kleiner. Wie muß ich das da in % eingeben?
'was bedeutet Add?ition? (Picture) und mso? (True)??
'dann wäre es noch gut, wenn ich am Ende den Bildordner für das nächste Bild noch leeren würde
'??????????????????????????????????????????????????????????????????????????????????????????????????????????????????
ActiveCell.Offset(-1, 0).Range("A1").Select
'
Beep
e = InputBox("Bitte noch eingeben," & Chr(13) & _
" " & Chr(13) & _
"bei mehreren Schildern, " & Chr(13) & _
"
