| | | Xometry Europe erweitert das Angebot um Vakuumguss und Formpressen, eine Pressemitteilung
|
Autor
|
Thema: Grafik automatisch einfügen [VBA?] (32382 mal gelesen)
|
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 22. Jun. 2006 11:55 <-- editieren / zitieren --> Unities abgeben:
Hallo Zusammen, ich bin auf der Suche nach einer Lösung für folgendes Problem. Wir erzeugen immer wieder autoatisch Exceltabellen, siehe Anhang. Gibt es eine Möglichkeit per VBA die Grafiken in dem Textrahmen einzufügen? Wenn das mit dem Textrahmen nicht geht, würde es schon sehr viel Zeit sparen die Grafiken neben der Nummer zu haben. Der manuelle Ablauf sieht z.Z. so aus, dass ich die Nummer aus dem Feld B5 in eine Adresse auflöse die lautet: i:\pdf\H11\11001280.jpg Die Adresse i:\pdf ist immer gleich - dann folgt H11 (die ersten Stellen der Nummer) - dann folgt 11001280 (die Nummer ohne Striche. Die Grafikadresse des zweiten Bildes (Feld B9) wäre demnach: i:\pdf\B56\56130111.jpg Ich danke Euch .... Viele Grüße aus Hessen
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 28. Jun. 2006 09:36 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hallo Martin, hatte Urlaub, hab mich jetzt aber mal dranbegeben. Ist bestimmt nicht das schönste Projekt auf Erden, aber läuft vielleicht. Also: Vorraussetzungen: Dateinamen sind immer gleich aufgebaut: X11-222-333, die Abstände der Einfügepunkte sind immer 4 Zeilen und die Pfade und Bilder sind vorhanden. Ansonsten ist Anpassen angesagt in Spalte A füge ich hilfsweise den Ordnernamen ein, "unter" das Bild, also in C den Bildnamen. Den Bildnamen sieht man unter dem Bild nicht, und die Spalte A ist weiße Schrift auf weißem Grund. Bei Nichtgefallen könnte man am Ende des Makros die Spalten A und C leeren hab ich mal in Kommentarzeichen gesetztDesweiteren müssen evtl. die Bilder größenmäßig angepasst werden, auch dafür ein Ansatz in Kommentarzeichen.
Code: Sub GrafikEinfuegen() Dim i As Integer Columns("A:A").Select Selection.Font.ColorIndex = 2 For i = 5 To 15 Step 4 'Bereich anpassen oder letzten Eintrag suchen lassen Cells(i, 1).Select ActiveCell.FormulaR1C1 = "=MID(RC[+1],1,3)" Cells(i, 3).Select ActiveCell.FormulaR1C1 = "=MID(RC[-1],2,2)&MID(RC[-1],5,3)&MID(RC[-1],9,3)" Cells(i, 3).Select ActiveSheet.Pictures.Insert("I:\PDF\" & Cells(i, 1) & "\" & (Cells(i, 3).Value) & ".jpg").Select 'Selection.ShapeRange.LockAspectRatio = msoTrue 'Selection.ShapeRange.Height = 32.25 'Selection.ShapeRange.Width = 39.75 'Selection.ShapeRange.Rotation = 0# Next 'Columns("A:A").ClearContents 'Columns("A:A").Select 'Selection.Font.ColorIndex = 1 End Sub
Kommt zwar spät, aber vielleicht hilft's trotzdem noch.Gruß, Nicole [edit: Kleinigkeiten ] ------------------ Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...
[Diese Nachricht wurde von runkelruebe am 28. Jun. 2006 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 28. Jun. 2006 11:36 <-- editieren / zitieren --> Unities abgeben:
Vielen lieben Dank Nicole! Wenn Bochum nicht so weit von Hessen wäre, würde ich Dir einen Strauß Blumen bringen - nun, sollst einen bekommen, halt virtuell... Ich hätte noch drei Fragen an Dich... 1.) Nach dem Programmablauf kommt ein Laufzeitfehler '1004' - wenn ich auf Debuggen gehe, ist die Zeile: ActiveSheet.Pictures.Insert("i:\PDF\" & Cells(i, 1) & "\" & (Cells(i, 3).Value) & ".jpg").Select gelb markiert. Das liegt wahrscheinlich an meiner Änderung: For i = 5 To 1000 Step 4 'Bereich anpassen oder letzten Eintrag suchen lassen Ist zwar nicht schön aber ich kann damit leben. 2.) Ich habe, wie in der Grafik vom ersten Beitrag zu sehen ist, ein Rechteck in den Zellen C4-C7 gleichmäßig verteilt. Ist es möglich die Bilder genau in dieses Rechteck zu placieren? Die Größe vom Rechteck ist immer 2,8 cm 3.) Falls ein Bild nicht vorhanden ist, muss das Programm weiter laufen. Zur Zeit bricht es ab. Kann man das irgendwie realisieren? Nochmals vielen lieben Dank Gruß Martin Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 28. Jun. 2006 12:02 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hallo Martin! Vielen Dank für diesen wunderschönen Blumenstrauß! Hab' ich hier noch nie bekommen Klar kann man: Zu 1 und 3: Zeile einfügen: Public Sub GrafikEinfuegen On Error Resume Next ...weiter mit Code End Sub Zu 2: Ich hab die Ansätze ja schon unten im Code stehen. 'Selection.ShapeRange.LockAspectRatio = msoTrue 'Selection.ShapeRange.Height = 32.25 'Selection.ShapeRange.Width = 39.75 'Selection.ShapeRange.Rotation = 0# einfach die Hochkomma weg und die Größe anpassen (rumspielen, ich weiß die Umrechnung von Pixel in cm nicht) Klappt? Gruß, Nicole
------------------ Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 28. Jun. 2006 13:01 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hallo Martin, kleine Änderungen: - Zellen (B5-B8) und folgende werden zusammengeführt - das eingefügte Bild ist abhängig von Zellposition und Größe - es wird mit der Größe 79.5 x 79.5 Pixel eingefügt, sollte ca. 2,8 cm sein - es wird automatisch der letze Eintrag in Spalte B gesucht Wenn jetzt alle Zeilen die Höhe 20 haben, sollte hübsch aussehen... tut's zumindest bei mir *g*Code: Sub GrafikEinfuegen() On Error Resume Next Dim i As Integer 'Cells.Select hier wird die Zeilenhöhe auf 20 festgelegt 'Selection.RowHeight = 20 For i = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 Cells(i, 1).Select ActiveCell.FormulaR1C1 = "=MID(RC[+1],1,3)" Cells(i, 3).Select ActiveCell.FormulaR1C1 = "=MID(RC[-1],2,2)&MID(RC[-1],5,3)&MID(RC[-1],9,3)" Cells(i, 3).Select Range(Cells(i, 3), Cells(i + 3, 3)).Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.Merge ActiveSheet.Pictures.Insert("C:\PDF\" & Cells(i, 1) & "\" & (Cells(i, 3).Value) & ".jpg").Select With Selection .ShapeRange.LockAspectRatio = msoFalse .Placement = xlMoveAndSize .PrintObject = True .ShapeRange.Height = 79.5 .ShapeRange.Width = 79.5 End With Next Columns("A:A").ClearContents End Sub
Da ich den Makro-Recorder benutzt habe, sind da noch einige Sachen unschön, bzw. überflüssig, aber ich wollte es jetzt nicht rauslöschen, vielleicht kann man es ja nutzen für was auch immer
------------------ Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 28. Jun. 2006 13:25 <-- editieren / zitieren --> Unities abgeben:
EDIT: UPS... mein Beitrag ist nicht auf den letzten von Dir bezogen... ich teste erst einmal... melde mich dann --------------------------------------- Hallo Nicole, Danke Dir... funktioniert soweit einwandfrei - bis auf die Ausrichtung der Bilder. Die Bilder fügen sich immer in der oberen linken Ecke von Zelle C4 - C8 - C12 usw an. Wünschenswert wäre allerdings die obere linke Ecke des Rechtecks welches in Zelle C4 liegt. Ist komisch zu erklären, ich mach dir mal ´ne Grafik. Danke Dir Gruß Martin [Diese Nachricht wurde von Martin_0103 am 28. Jun. 2006 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 28. Jun. 2006 13:53 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Du willst unbedingt diese Textfelder nutzen, wa? Kann ich aber auf die Schnelle nicht Falls es noch nicht funzt, Lösungsvorschlag: die Bilder nach Einfügen um 5 Pixel nach rechts und 5 Pixel nach unten verschieben natürlich Pixelzahl so anpassen, daß es paßt.: Code:
... With Selection .ShapeRange.LockAspectRatio = msoFalse .Placement = xlMoveAndSize .PrintObject = True .ShapeRange.Height = 79.5 .ShapeRange.Width = 79.5 .ShapeRange.IncrementLeft 5# 'hier wird verschoben .ShapeRange.IncrementTop 5# End With ...
------------------ Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 28. Jun. 2006 14:34 <-- editieren / zitieren --> Unities abgeben:
Hallo Nicole... bin ich schwer zufrieden zu stellen? Du, es läuft zu meiner vollsten Zufriedenheit... ich kann mich nur nochmals bei Dir bedanken!!! Hast mir sehr geholfen - vorallem in welch einer Zeit! Klasse! Lieben Gruß Martin Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Thomas Harmening Moderator Arbeiter ツ
Beiträge: 2897 Registriert: 06.07.2001 Das Innerste geäussert und aufs Äusserste verinnerlicht
|
erstellt am: 28. Jun. 2006 19:19 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 27. Okt. 2006 11:07 <-- editieren / zitieren --> Unities abgeben:
Hallo Forum, ich stell hier das Makro nochmals mit zwei kleinen Änderungswünschen ein. Seinerzeit sind wir von immer der gleichen Struktur der Nummern ausgegangen -> X11-222-333 daraus wurde der Bildername -> 11222333.jpg Nun ist ein Kollege auf die tolle Idee gekommen, eine zusätzliche neue Nummer zu kreieren -> X11-222-333-4 daraus wird dann der Bildname -> 11222333-4.jpg Änderungswunsch 1 Nun die Bitte, ist es möglich eine solche Änderung in dem Makro zu berücksichtigen? Für mich sind das böhmische Dörfer... Hut ab vor denen die das können und vor denen die hier helfen!!! Hier das Makro: Sub GrafikEinfuegen3() Dim intIndex As Integer, strPfad As String, shpRectangle As Shape On Error GoTo err_exit For intIndex = 4 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 strPfad = ("i:\PDF\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _ Mid$(Replace(Cells(intIndex, 2).Value, "-", ""), 2) & ".jpg") With Range(Cells(intIndex, 3), Cells(intIndex + 3, 3)) Set shpRectangle = ActiveSheet.Shapes.AddShape( _ msoShapeRectangle, .Left, .Top, .Width, .Height) End With shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad Next Exit Sub err_exit: ' MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" Resume Next End Sub Public Sub BilderLoeschen3() Dim sh As Object On Error GoTo err_exit For Each sh In ActiveSheet.Shapes If sh.Type = msoShapeRectangle Then sh.Select With Selection .ShapeRange.Fill.Visible = msoFalse End With End If Next Exit Sub err_exit: MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" End Sub Änderungswunsch 2 oder besser zusätzliches Makro Ich würde ein Makro benötigen welches ich in Excel, Word oder auch Outlook per Button starten kann welches wie folgt arbeitet.
Es sollte ein Fragefenster "Grafik einfügen" aufgehen in das ich die Nummer X11-222-333 oder die Nummer X11-222-333-4 manuell eingebe. Mit der Bestätigung eines OK Buttons sollte die Grafik an der Cursorposition eingefügt werden (analog des o.s. Makros). Die Grafik kann ich dann mittels Maus positionieren. Vielen lieben Dank Gruß Martin
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Thomas Harmening Moderator Arbeiter ツ
Beiträge: 2897 Registriert: 06.07.2001 Das Innerste geäussert und aufs Äusserste verinnerlicht
|
erstellt am: 27. Okt. 2006 12:19 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
zu 1 - Code: strPfad = ("i:\PDF\" & Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")
und zu 2 Aktive Zelle ist dort wo das Bild eingefügt werden soll Code: sTxt = InputBox("Bitte Eingabe tätigen:", "Grafik einfügen", Replace(ActiveCell.Offset(0, -1), "-", "", , 2))
könnte eine Lösung sein Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 27. Okt. 2006 12:34 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hallo Matthias, zu 1.: Folgende Zeile austauschen:
Code:
For intIndex = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 strPfad = ("i:\PDF\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _ Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")
Erklärung: ich ersetze nur noch 2 Stück Bindestriche: Replace(Cells(intIndex, 2).Value, "-", "", , 2) hier ist es die letzte 2, die die Anzahl der zu ersetzenden Zeichen bestimmt. Zu Deinem 2. Problem: Stichwort ist (glaub ich) TextBox, da gibt es aber noch was zweites, der Begriff ist mir spotan entfallen Ich melde mich wieder, muß noch schaffen... [edit] ach guck mal, da war schon jemand... Hallo Thomas! : )[/edit]
------------------ Gruß, Nicole Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... [Diese Nachricht wurde von runkelruebe am 27. Okt. 2006 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Thomas Harmening Moderator Arbeiter ツ
Beiträge: 2897 Registriert: 06.07.2001 Das Innerste geäussert und aufs Äusserste verinnerlicht
|
erstellt am: 27. Okt. 2006 15:20 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
ohne das jetzt mit dem Bildeinfügen geprüft zu haben -keine Lust mir so ein Verz. samt Bild zu erstellen :-) zu 1 Code: Sub GrafikEinfuegen3() Dim intIndex As Integer, strPfad As String, shpRectangle As Shape On Error GoTo err_exit For intIndex = 4 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 strPfad = ("i:\PDF\" & Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg") strPfad = InputBox("Bitte Eingabe tätigen:", "Grafik einfügen", strPfad) 'optional With Range(Cells(intIndex, 3), Cells(intIndex + 3, 3)) Set shpRectangle = ActiveSheet.Shapes.AddShape( _ msoShapeRectangle, .Left, .Top, .Width, .Height) End With shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad Next Exit Sub err_exit: ' MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" Resume Next End Sub
und zu 2 Aufruf am besten über Tastenkürzel oder auch Button und makrozuweisen
Code: Sub Grafikinput() 'Manuell - Aktive Zelle ist rechts der Nummer Dim intIndex As Integer, strPfad As String, shpRectangle As Shape On Error GoTo err_exit strPfad = InputBox("Bitte Eingabe tätigen:", "Grafik einfügen", _ "i:\PDF\" & Mid$(Replace(ActiveCell.Offset(0, -1), "-", "", , 2), 2) & ".jpg") With Range(ActiveCell, ActiveCell.Offset(3, 0)) Set shpRectangle = ActiveSheet.Shapes.AddShape( _ msoShapeRectangle, .Left, .Top, .Width, .Height) End With shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad Exit Sub err_exit: ' MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" Resume Next End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 30. Okt. 2006 08:07 <-- editieren / zitieren --> Unities abgeben:
Hallo Nicole, Hallo Thomas, vielen Dank für Eure Hilfe. Allerdings komm ich nicht ganz klar damit, die Änderung von Nicole: Zitat: Code:For intIndex = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 strPfad = ("i:\PDF\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _ Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")
arbeitet unerwartend, d.h. es wird ein Rahmen eingefügt - allerdings tiefer als bei dem original Makro dafür aber "ohne" Bild. Das Makro von Thomas verlangt eine Eingabe? Dieses sollte nicht sein, es sollte schon automatisch ablaufen.
Der Änderungswunsch ist: X11-222-333 -> 11222333.jpg X11-222-333-4 -> 11222333-4.jpg
Beide Varianten kommen vor! Der Vorschlag von Thomas bezüglich dem 2. Wunsch geht soweit - jedoch wird kein Bild eingefügt! Evtl. hängt das an o.g. Problem!
Vielleicht habt ihr ja noch mal Zeit es anzuschauen. Vielen Dank Gruß Martin Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 30. Okt. 2006 08:29 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hallo Martin, ich hab's jetzt nicht wieder komplett nachgestellt (so mit Anlegen von nem "PDF"-Ordner und mit den Bildern drin und so...), aber da wir ja nur eine Zeile verändert haben, müßte es eigentlich laufen. Vorausgesetzt natürlich, daß die Pfad-Angaben immer noch : Ordner "PDF" auf Laufwerk "I", und die Bilder sind da auch tatsächlich drin! Das mit dem eine Zeile tiefer liegt am Schleifenstart: For intIndex = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 hier hab ich Dir versehentlich die Zeile vermurkst , schreib anstatt 5 mal wieder ne 4 hin, dann paßt das Rechteck wieder Prüf doch mal mit dieser kleinen Änderung nochmal, und kontrolliere, ob die Ordnerstruktur vorhanden und gefüllt ist und wenn's wirklich nicht geht, dann stell' ich's mir heute nachmittag auch gerne nochmal nach. Bis dahin!
------------------ Gruß, Nicole Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 30. Okt. 2006 09:59 <-- editieren / zitieren --> Unities abgeben:
|
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 30. Okt. 2006 10:14 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Prima. und zu 2.: Versuch mal dieses leicht geänderte: Code: Sub Grafikinput() 'Manuell - Aktive Zelle ist rechts der Nummer Dim intIndex As Integer, strPfad2 As String, shpRectangle As Shape On Error GoTo err_exit strPfad2 = "i:\PDF\" & InputBox("Bitte Eingabe tätigen:", "Grafik einfügen") & ".jpg" With Range(ActiveCell, ActiveCell.Offset(3, 0)) Set shpRectangle = ActiveSheet.Shapes.AddShape( _ msoShapeRectangle, .Left, .Top, .Width, .Height) End With shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad2 Exit Sub err_exit: ' MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" Resume Next End Sub
in die Eingabeaufforderung jetzt nur noch die Bildnummer reinschreiben: Bsp: 111222333-4 das "I\PDF\" und das ".jpg" drumrum werden automatisch eingefügt.------------------ Gruß, Nicole Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... [wie immer: wenn man schon 'nen VariablenNamen ändert, dann bitte auch überall ] [Diese Nachricht wurde von runkelruebe am 30. Okt. 2006 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 30. Okt. 2006 10:50 <-- editieren / zitieren --> Unities abgeben:
Hallo Nicole, geht noch nicht. Das Resultat sieht wie auf der Grafik aus. Der Bildrahmen wird der Zelle angepaßt! Der Aufruf müßte meines Erachtens mit der vollen Nummer realisiert werden - sonst weiß man den Dateiordner nicht. H11-002-206 -> Ordner: i:\pdf\H11\11002206.jpg oder H11-002-206-1 -> Ordner: i:\pdf\H11\11002206-1.jpg Vielen Dank
Gruß Martin Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 30. Okt. 2006 11:10 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
dieses H11 kann er sich aber nirgendwoher ziehen, also müßtest Du es mit eingeben: Eingabe = H11\111222333-4 dann müßte es gehen. zum Rechteck: das ist abhängig von der Zelle, in der Du beim Makro-Aufruf stehst und doch auch so gewollt!? Zitat: Die Grafik kann ich dann mittels Maus positionieren.
OK, am Mauszeiger wird es noch nicht eingefügt, aber das können wir auch anders haben, ohne Rechteck, nur die Grafik einfügen: Code: Sub Grafikinput() 'Manuell - Aktive Zelle ist rechts der Nummer Dim intIndex As Integer, strPfad3 As String, shpRectangle As Shape On Error GoTo err_exit strPfad3 = "i:\PDF\" & InputBox("Bitte Eingabe tätigen:", "Grafik einfügen") & ".jpg" ActiveSheet.Pictures.Insert(strPfad3).Select Exit Sub err_exit: ' MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" Resume Next End Sub
check es und berichte ------------------ Gruß, Nicole Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 30. Okt. 2006 11:33 <-- editieren / zitieren --> Unities abgeben:
|
scrarat Mitglied Grafiker
Beiträge: 1 Registriert: 09.04.2013
|
erstellt am: 09. Apr. 2013 01:14 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hallo liebes Forum, dieser Code scheint, als sei er genau dass, was ich gesucht habe... Nur leider habe ich was VBA angeht überhaupt keine Ahnung, wie ich den Code eingeben muß, und vor allem, welche Zellen für den Dateinnamen stehen... Mein Wunsch wäre folgendes: Eine Zelle (Dropdownfeld, Tabellenname: Auswahl, Zelle:C1) zur Auswahl des Dateinamens. Der Dateiname ist gleich der Artikelnr. Der Pfad: H:\Produktbilder\ dateiformat bleibt jpg. Die Bildaktualisierung sollte nach Auswahl durch das Dropdownfeld erfolgen (nur wenn das geht...) Und wenn es geht, vielleicht eine kleine Anleitung, wie ich den Code einfügen muß, damit es funktioniert. Es wäre mir eine große Hilfe... Danke im Voraus, Andreas
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
runkelruebe Moderator Straßen- / Tiefbau
Beiträge: 8086 Registriert: 09.03.2006 MS-Office 365 ProPlus x86 WIN7(x64)
|
erstellt am: 09. Apr. 2013 03:18 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Moin Andreas, vorab: gar keine Ahnung von VBA ist viel zu wenig Ahnung von VBA ;-) Änder das, Tutorialempfehlungen findest Du u.a.hier im Forum. Zitat: Original erstellt von scrarat: Mein Wunsch wäre folgendes: Eine Zelle (Dropdownfeld, Tabellenname: Auswahl, Zelle:C1) zur Auswahl des Dateinamens. Der Dateiname ist gleich der Artikelnr. Der Pfad: H:\Produktbilder\ dateiformat bleibt jpg.Die Bildaktualisierung sollte nach Auswahl durch das Dropdownfeld erfolgen (nur wenn das geht...)
In diesem (steinalten ) thread ging es bislang darum, eine ganze Reihe von Bildern einzufügen, daher auch die Schleifen drumrum. Wenn ich Deine Anfrage richtig deute, suchst Du was ganz anderes, ein einfaches: Code: Private Sub Worksheet_Change(ByVal Target As Range) Dim strPfad7$ 'Nur Änderungen von C1 sind interessant, daher aus Performancegründen Bereich einschränken! If Not Intersect(Target, Range("C1")) Is Nothing Then strPfad7 = " H:\Produktbilder\ " & (ActiveCell.Value) & ".jpg" ActiveCell.Offset(0, 1).Select ActiveSheet.Pictures.Insert (strPfad7) End If End Sub
sollte Dir laut Beschreibung schon reichen.Einfügen musst Du diesen kompletten Code im Bereich des worksheets, auf dem die Sache stattfinden soll, siehe angehängten screenshot. Das Dropdown hast Du doch hoffentlich schon? Wenn nicht: (Angaben für Excel2010, bitte Systeminfo ergänzen) Ribbon: Daten > Gruppe: Datentools > Befehl: Datenüberprüfung > Zulassen: Liste > Quelle: an- oder eingeben [ =$A$1:$A$3 oder rot;gelb;blau ] HTH ------------------ Gruß, runkelruebe Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße... Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Beverly Mitglied Dipl.-Geologe (Rentner)
Beiträge: 395 Registriert: 11.08.2007
|
erstellt am: 11. Apr. 2013 08:54 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hi @All, nur mal als Tipp am Rande: wenn man nur 1 Adresse überwachen möchte, benötigt man kein Intersect, da reicht die Zelladresse Code: If Target.Address = "$C$1" Then
Wichtig dabei - die Adresse muss absolut angegeben sein. Will man die Adresse (obwohl dazu keine Notwendigkeit besteht) unbedingt relativ angeben, geht das mit einem Zusatz ebenfalls Code: If Target.Address(False, False) = "C1"
------------------ Bis später, Karin Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2010 SP3
|
erstellt am: 16. Apr. 2014 07:29 <-- editieren / zitieren --> Unities abgeben:
Hallo Forum, nun haben wir nach langer Zeit auf Excel 2010 umgestellt und siehe da, das Makro läuft nicht mehr. Wäre schön, wenn wir das wieder zum Laufen bringen würden. Vielen Dank schon mal Gruß Martin Code: Sub GrafikEinfuegen3() Dim intIndex As Integer, strPfad As String, shpRectangle As Shape On Error GoTo err_exit For intIndex = 4 To Cells(Rows.Count, 2).End(xlUp).Row Step 4 strPfad = ("i:\PDF\KVD\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _ Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg") With Range(Cells(intIndex, 3), Cells(intIndex + 3, 3)) Set shpRectangle = ActiveSheet.Shapes.AddShape( _ msoShapeRectangle, .Left, .Top, .Width, .Height) End With shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad Next Exit Sub err_exit: ' MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" Resume Next End Sub
------------------ Wenn man einen Hund so dressiert hat, dass er über einen See fliegt, dann gibt es sicher ein paar Neider die das Tier für Wasserscheu halten... Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KlausReiff Mitglied Sachbearbeiter
Beiträge: 3 Registriert: 13.11.2014
|
erstellt am: 13. Nov. 2014 10:53 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Hallo Nicole, ich schaffe es einfach nicht das Makro richtig abzuändern. Ich habe einen Excelliste (Exc.2007)siehe Anlage und möchte die Bilder dazu automatisch einfügen. Der Artikelpfad steht in Spalte I (mehrfach)- Das Bild soll in Spalte J eingefügt werden - Bildgrösse ca. 3 cm. Immer beginnend am zuerst genannten Bildpfad. Der Bildpfad ist: F:\Muster\FS2015\Niedrig\20522_501.jpg F:\Muster\bleibt immer gleich alle anderen Angaben ändern sich im Pfad. mfg Klaus
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Thomas Harmening Moderator Arbeiter ツ
Beiträge: 2897 Registriert: 06.07.2001 Das Innerste geäussert und aufs Äusserste verinnerlicht
|
erstellt am: 13. Nov. 2014 21:15 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
Es ist egal ob >F:\Muster< immer gleich bleibt, wenn die volle Adressierung in den Zeilen der Spalte I geben ist. Da nicht bekannt ist welche Variante vom Code man anpassen will, gibt es halt mal eine Variante im Kommentar Klarer Input -klarer Output Code: Sub picincomm() Dim intIndex As Integer, strPfad As String, shpRectangle As Shape On Error GoTo err_exit For intIndex = 2 To Cells(Rows.Count, 9).End(xlUp).Row Step 1 '= Spalte I strPfad = Cells(intIndex, 9) If Not Cells(intIndex, 10).Comment Is Nothing Then Cells(intIndex, 10).Comment.Delete End If Cells(intIndex, 10).AddComment Set objCom = Cells(intIndex, 10).Comment.Shape With objCom .Fill.UserPicture strPfad .Width = 100 .Height = 100 End With Next Exit Sub err_exit: ' MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _ Err.Description, vbCritical, "Fehlermeldung" Resume Next End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KlaK Ehrenmitglied V.I.P. h.c. Dipl. Ing. Vermessung, CAD- und Netz-Admin
Beiträge: 2799 Registriert: 02.05.2006 Office 2010; Office365 Visual Basic
|
erstellt am: 13. Nov. 2014 21:52 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
KlausReiff Mitglied Sachbearbeiter
Beiträge: 3 Registriert: 13.11.2014
|
erstellt am: 17. Nov. 2014 09:31 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
Thomas Harmening Moderator Arbeiter ツ
Beiträge: 2897 Registriert: 06.07.2001 Das Innerste geäussert und aufs Äusserste verinnerlicht
|
erstellt am: 17. Nov. 2014 12:41 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
KlausReiff Mitglied Sachbearbeiter
Beiträge: 3 Registriert: 13.11.2014
|
erstellt am: 17. Nov. 2014 15:16 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
Thomas Harmening Moderator Arbeiter ツ
Beiträge: 2897 Registriert: 06.07.2001 Das Innerste geäussert und aufs Äusserste verinnerlicht
|
erstellt am: 17. Nov. 2014 16:44 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
< Die codeschnippsel sind keine formeln, sonden schon entsprechende codes für ein makro > Ein bsp. wäre ja in der gezippten Datei Picincomment vorhanden. Datei entpacken, die Datei mit Excel öffen, die Bsp. Pfade anpassen und auf den Schalter >Klick mich< drücken sollte in der nebenstehenden Spalte die Bilder in das Kommentarfeld verfrachten. Aber dies ist ja nur ein Bsp. Deine genaue Aufgabenstellung ist nicht bekannt: - vollautomatisch - oder nur selektiv - oder gar als neue Funktion aka = Bild(F2) und da du die Codeschnippsel als Formel eingegeben hast... muss man ganz von vorn anfangen - was ist Excel, Formeln und was ist ein Makro - weil schliesslich musst du es ja bedienen können und ggf. auch wissen was passiert um es vielleicht irgendwann anzupassen ;-) Es Bringt nicht viel, wenn wir dir ein Code erstellen und du weisst nicht wo und wohin mit dem Code - (Alt&F11) VBA Umgebung) Ebensowenig wenn du einen Bsp Code nicht für deine Bedürfnisse anpassen kannst. Daher Klarer Input - Was genau ist die Aufgbenstellung, ggf. mit Bsp-Excel-Mappe (sensible Daten durch Dummy Werte ersetzen) Damit macht man es den Helfenden etwas einfacher. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|