1.6k Aufrufe
Gefragt in Datenbanken von syler902 Mitglied (159 Punkte)
Halli Hallo,
da es gestern bzw die letzten Tage hier so super mit den Hilfe von euch geklappt hat wofür
ich echt dankbar bin , dachte ich mir wir gehen weiter zu punkt 2 ^^.
Ich habe jetzt von M.O. einen text für VBA Programmiert bekommen den ich leicht geändetr
habe um mir die maße einzustellen.
Was jetzt noch genial wäre , wäre wenn ich neben jedem bild dazu noch fest gesetzte Texte
Habe die er mir neben jedes Bild Packt das ich einfüge.
So hier einmal der Programmierte text und darüber quasi das wie ich es mir rechts neben
dem Bild vorstelle. Kann auch eine excel datei zu schicken oder ein scrrenshot damit man
weis wie ich es meine. Weiß nur nicht wie ich das hier mache mit dem einfügen oder senden
habe es bis jetzt per email versendet.
Also hier der text   

Das ist der Text mit den EIgenschaften wie ich es gerne neben jedem Bild hätte.
Die leere zeilen, sollen halt leer bleiben damit ich dort die jeweiligen werte selber eintragen
kann.


- Lego Star Wars , Fett und unterstrichen Schriftgröße 14
- Name: Fett mit Unterstrich 12
-( Leere Zeile) 12
- Farben: Fett mit Unterstrich12
-( Leere Zeile)12
-( Leere Zeile )12
-Preis ca.: fett mit unterstrich12
-( Leere Zeile)12
Set Nr.: fett mit unterstrich
-( Leere Zeile)



Den geschriebenen Text von M.O. Habe ich so verändert :

Sub Bilder_einlesen()

Dim strPfad As String
Dim DateiName As String
Dim lngZaehler As Long
Dim lngSpalte As Long
Dim lngZeile As Long
Dim rngSpalte As Range

With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Ereignisse ausschalten
.Calculation = xlCalculationManual 'automatische Berechnuns ausschalten
End With

'erste Zeile und Spalte zum Einfügen festlegen
lngZeile = 1
lngSpalte = 1

'Tabelle einrichten
'Spalten für Bilder Breite von 17,75 festlegen
With ActiveSheet
Set rngSpalte = .Range("A:A,C:C,E:E,G:G,I:I,K:K")
rngSpalte.ColumnWidth = 17.75
'Spalten für Erläuterungen Breite von 20 festlegen
Set rngSpalte = .Range("B:B,D:D,F:F,H:H,J:J,L:L")
rngSpalte.ColumnWidth = 20
'Seitenränder (jeweils 1,5 cm) einrichten
With .PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362) 'linker Seitenrand
.RightMargin = Application.InchesToPoints(0.590551181102362) 'rechter Seitenrand
.TopMargin = Application.InchesToPoints(0.590551181102362) 'oberer Seitenrand
.BottomMargin = Application.InchesToPoints(0.590551181102362) 'unterer Seitenrand
End With

End With

'Pfad auswählen und in Variable für Pfad schreiben
With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"

If .Show = -1 Then
strPfad = .SelectedItems(1) & "\"
Else
MsgBox "Kein Pfad gewählt! Abbruch!", 16, "Abbruch!" 'Abbrechen wenn kein Pfad
ausgewählt wurde
Exit Sub
End If

End With

'nur Dateien mit Endung jpg und png öffnen
DateiName = Dir(strPfad)
Do While DateiName <> ""
If LCase(Right(DateiName, 3)) = "jpg" Or LCase(Right(DateiName, 3)) = "png" Then

lngZaehler = lngZaehler + 1 'Zähler für Bilder
'Zeile und Spalte für das einzufügende Bild festlegen
If lngZaehler > 1 Then
If lngZaehler Mod 6 = 1 Then 'ist Zähler ungrade
lngZeile = lngZeile + 12 'dann neue Zeile festlegen
Else
If lngZaehler > 1 Then 'ansonsten Einfügespalte neu festlegen
lngSpalte = lngSpalte + 2
If lngSpalte > 11 Then lngSpalte = 1
End If
End If
End If

'Bilder einfügen
'Bild in Zellen einfügen, 4,3 cm breit - 1 cm = = 28,35 pt ergibt 121,91 pt - und 6,64 cm hoch
= 188,24

With ActiveSheet
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile,
lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
End With

End If

DateiName = Dir
Loop

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

End Sub

39 Antworten

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Julian,

noch einen Text neben den Bildern zu ergänzen ist kein Problem. Es könnte nur ein Problem mit den Schriftgrößen geben, dass die Seitenränder dann nicht mehr passen.

Ich werde das mal ausprobieren und mich dann wieder melden.

Gruß

M.O.
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Julian,

was ich noch vergessen habe, welche Schrift soll den verwendet werden?

Gruß

M.O.
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
Die ganz normale Schrift Art das ist erstmal egal das kann ich dann ja
notfalls selber noch ändern :-) danke dir erstmal :-) bin gespannt was
kommt :-)
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
Und hast schon ein wenig rumprobiert ?:-)
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Julian,

kopiere das Makro in ein allgemeines Modul, nicht in das VBA-Projekt der Tabelle. Wie das geht siehe hier: [url=http://www.excelbeispiele.de/Modul.htm]Klick mich![/url].

Nun zu deiner Frage.
Ändere den Teil
[code]With ActiveSheet
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile,
lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
End With[/code]
in
[code]With ActiveSheet
'Bilder einfügen
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile, lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
'Text einfügen und formatieren
 With Cells(lngZeile, lngSpalte + 1)
  .Value = "Lego Starwars"
  With .Font
   .Size = 14                     'Schriftgröße
   .Bold = True                   'Fett
   .Underline = xlUnderlineStyleSingle 'unterstrichen
  End With
 End With
 'Text einfügen, soweit vorhanden
 .Cells(lngZeile + 1, lngSpalte + 1).Value = "Name:"
 .Cells(lngZeile + 3, lngSpalte + 1).Value = "Farben:"
 .Cells(lngZeile + 6, lngSpalte + 1).Value = "Preis ca.:"
 .Cells(lngZeile + 8, lngSpalte + 1).Value = "Set Nr.:"
 'weitere Zeilen formatieren
 With .Range(.Cells(lngZeile + 1, lngSpalte + 1), .Cells(lngZeile + 9, lngSpalte + 1)).Font
   .Size = 12                     'Schriftgröße
   .Bold = True                   'Fett
   .Underline = xlUnderlineStyleSingle 'unterstrichen
 End With
 
End With[/code]

Gruß

M.O.
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
So probiere es gleich mal aus.
Habe mir das mal durchgelesen, wo genau könnte ich denn jetzt teoretisch die Schriftart noch ändern ? dachte ich finde etwas wie calibre oder
irgend einen namen von einer Schriftart die ich nur austauschen muss.
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
So habe es ausprobiert und komme bis zum wählen des Ordners, wenn ich diesen dann öffne kommt ein Laufzeit fehler der mir angezeigt
wird Laufzeitfehler 424 und er gibt mir an das ich beenden kann oder Debuggen. wenn ich auf Debuggen gehe wird nur noch ein einziges
Bild eingefügt.

Hier der Code den ich jetzt aus deinen beiden zusammen gebaut habe.






Sub Bilder_einlesen()

Dim strPfad As String
Dim DateiName As String
Dim lngZaehler As Long
Dim lngSpalte As Long
Dim lngZeile As Long
Dim rngSpalte As Range

With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Ereignisse
.Calculation = xlCalculationManual 'automatische Berechnuns ausschalten
End With

'erste Zeile und Spalte zum Einfügen festlegen
lngZeile = 1
lngSpalte = 1

'Tabelle einrichten
'Spalten für Bilder Breite von 17,75 festlegen
With ActiveSheet
Set rngSpalte = .Range("A:A,C:C,E:E,G:G,I:I,K:K,M:M,O:O")
rngSpalte.ColumnWidth = 17.75
'Spalten für Erläuterungen Breite von 20 festlegen
Set rngSpalte = .Range("B:B,D:D,F:F,H:H,J:J,L:L,N:N,P:P")
rngSpalte.ColumnWidth = 20
'Seitenränder (jeweils 1,5 cm) einrichten
With .PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362) 'linker Seitenrand
.RightMargin = Application.InchesToPoints(0.590551181102362) 'rechter Seitenrand
.TopMargin = Application.InchesToPoints(0.590551181102362) 'oberer Seitenrand
.BottomMargin = Application.InchesToPoints(0.590551181102362) 'unterer Seitenrand
End With

End With

'Pfad auswählen und in Variable für Pfad schreiben
With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"

If .Show = -1 Then
strPfad = .SelectedItems(1) & "\"
Else
MsgBox "Kein Pfad gewählt! Abbruch!", 16, "Abbruch!" 'Abbrechen wenn kein Pfad ausgewählt wurde
Exit Sub
End If

End With

'nur Dateien mit Endung jpg und png öffnen
DateiName = Dir(strPfad)
Do While DateiName <> ""
If LCase(Right(DateiName, 3)) = "jpg" Or LCase(Right(DateiName, 3)) = "png" Then

lngZaehler = lngZaehler + 1 'Zähler für Bilder
'Zeile und Spalte für das einzufügende Bild festlegen
If lngZaehler > 1 Then
If lngZaehler Mod 6 = 1 Then 'ist Zähler ungrade
lngZeile = lngZeile + 12 'dann neue Zeile festlegen
Else
If lngZaehler > 1 Then 'ansonsten Einfügespalte neu festlegen
lngSpalte = lngSpalte + 2
If lngSpalte > 15 Then lngSpalte = 1
End If
End If
End If

'Bilder einfügen
'Bild in Zellen einfügen, 4,3 cm breit - 1 cm = = 28,35 pt ergibt 121,91 pt - und 6,64 cm hoch = 188,24

With ActiveSheet
'Bilder einfügen
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile, lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
'Text einfügen und formatieren
 With Cells(lngZeile, lngSpalte + 1).Value = "Lego Star-Wars"
  With .Font
   .Size = 14 'Schriftgröße
   .Bold = True 'Fett
   .Underline = xlUnderlineStyleSingle 'unterstrichen
End With
End With
 'Text einfügen, soweit vorhanden
 .Cells(lngZeile + 1, lngSpalte + 1).Value = "Name:"
 .Cells(lngZeile + 3, lngSpalte + 1).Value = "Farben:"
 .Cells(lngZeile + 6, lngSpalte + 1).Value = "Preis ca.:"
 .Cells(lngZeile + 8, lngSpalte + 1).Value = "Set Nr.:"
 'weitere Zeilen formatieren
With .Range(.Cells(lngZeile + 1, lngSpalte + 1), .Cells(lngZeile + 9, lngSpalte + 1)).Font
   .Size = 12 'Schriftgröße
   .Bold = True 'Fett
   .Underline = xlUnderlineStyleSingle 'unterstrichen
   End With
 
End With


End If

DateiName = Dir
Loop

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

End Sub
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Julian,

die Schriftart kannst du wie folgt angeben:
[code]With .Font
.Name = "Calibri"
.Size = 14 'Schriftgröße
.Bold = True 'Fett
.Underline = xlUnderlineStyleSingle 'unterstrichen
End With[/code]

Welche Zeile wird denn markiert, wenn du das Makro laufen lässt.

Gruß

M.O.
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
Er makiert die Zeile bei With .Font  gelb an. und er Zeigt in dem Fenster Laufzeitfehler 424 daunter steht dann Objekt erforderlich




With ActiveSheet
'Bilder einfügen
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile, lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
'Text einfügen und formatieren
With Cells(lngZeile, lngSpalte + 1).Value = "Lego Star-Wars"
With .Font
.Name = "Calibri"
.Size = 14 'Schriftgröße
.Bold = True 'Fett
.Underline = xlUnderlineStyleSingle 'unterstrichen
End With
End With






Ps habe ich hier denn das Calibiri richtig eingefügt ?  darüber die gemeinte gelb makierte Stelle wenn ich den Makro abspiele
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Julian,

ersetze mal
[code]With Cells(lngZeile, lngSpalte + 1).Value = "Lego Star-Wars"[/code]
durch
[code]With .Cells(lngZeile, lngSpalte + 1).Value = "Lego Star-Wars"[/code]
Gruß

M.O.
...