Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Bilder importieren mit Text versehen und anordnen
zurück: Makro CommandButton1_click in einem anderen VBAProject weiter: Automatische Generierung von ppt-Slides aus Excel Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Offen Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
hellgrueneBlaetter
Gast


Verfasst am:
22. Mai 2009, 00:02
Rufname:

Bilder importieren mit Text versehen und anordnen - Bilder importieren mit Text versehen und anordnen

Nach oben
       Version: Office 2003

Hallo liebes Forum,

das erste mal mit einem ppt-makro zugange, habe ich ein paar Fragen und hoffe, ihr könntet mir helfen? Mit Excel-VBA-Makros komme ich schon ganz gut klar, jedoch ist dies mein erster Versuch für ppt! Wenn Ihr mir bei diesen Schritten in ppt helfen könntet, wäre ich wohl in der Lage einen guten Teil des restlichen Weges alleine programmieren zu können,

es dankt im voraus, hellgrueneblaetter




mein Ziel: ich würde gerne eine größere Menge an (kleinen) Grafiken nach Powerpoint importieren und jeweils mit einem kleinen Texteintrag, welcher den Namen der Ursprungsdatei enthält, zusammen (Gruppierung) nebeneinander anzeigen lassen.

mein Stand: Pfade selbst anzugeben und aus diesem dann Dateien zu importieren, funktioniert schon gut.

meine Fragen:
* Wie kann ich mir die aktuelle Breite einer Slide zurückgeben lassen? (Ich will ja meine Bilder auf und nicht neben einer Folie haben ;) )
* Kann ich beim (oder nach dem) Import eine Bildhöhe vorgeben und ppt zwingen diese bei einer "Preserve Aspect Ratio" auch einzuhalten? Wie?
* Ich habe per makro-Aufzeichnen mir die Befehle für das Einfügen eines TextFrame angeschaut (bsp siehe ganz unten)... sieht ja recht kompliziert aus, geht das einfacher?



Code:

Option Explicit

Const iFileMax = 10000 'max number of files in folder to be imported
Const iPosLeftOffset = 30 'minimum position from left
Const iPosLeftMax = 300 ' maximum position from left
Const iPosTopOffset = 30 'minimum position from top
Const iPosTopMax = 600 'maximum position from left


Public Sub myMain()
'
'--------------------------------------------------------------'
'VARIABLES
'--------------------------------------------------------------'
Dim i As Integer, j As Integer, k As Integer, iContent As Integer, iL As Integer, iT As Integer
Dim iPosLeftInc As Integer, iPosTopInc As Integer, iPosLeft As Integer, iPosTop As Integer
Dim strTgt As String
Dim objA As Shape


'--------------------------------------------------------------'
'Get Source Folder from User
'--------------------------------------------------------------'

    strTgt = getUserFolder("Please specify an import folder", "")
    If Not strTgt <> "" Then Exit Sub

'------------------------------------'
'Get all file names in target folder
'------------------------------------'
    ReDim arrFiles(0 To iFileMax)
    arrFiles(0) = Dir(strTgt & "*.*") 'get first file in Target Folder (folder in which files will be changed)
    Do Until arrFiles(iContent) = ""
        iContent = iContent + 1
        arrFiles(iContent) = Dir() 'get next file from directory
    Loop

'------------------------------------'
'POSITIONING of first image
'------------------------------------'
iPosLeft = iPosLeftOffset
iPosTop = iPosTopOffset
   
'------------------------------------'
'Looping through Target folder
'------------------------------------'
    For i = 0 To iContent - 1
        '------------------------------------'
        'IMPORT image
        '------------------------------------'
        Set objA = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strTgt & arrFiles(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=iPosLeft, Top:=iPosTop)
        '------------------------------------'
        'Positioning image
        '------------------------------------'
        objA.Top = iPosTop: objA.Left = iPosLeft
        iPosTop = iPosTop + objA.Top: iPosLeft = iPosLeft + objA.Width
    Next i
   
End Sub



Code:

'----------------------------------------------------------------------------'
'Mit Makro-Recorder aufgezeichneter Code:
'Kann man das Hinzufügen eines Textes auch vereinfachen?
'----------------------------------------------------------------------------'
ActiveWindow.Selection.SlideRange.Shapes.AddLabel(msoTextOrientationHorizontal, 160.75, 98.875, 14.5, 28.875).Select
    ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoFalse
    With ActiveWindow.Selection.TextRange.ParagraphFormat
        .LineRuleWithin = msoTrue
        .SpaceWithin = 1
        .LineRuleBefore = msoTrue
        .SpaceBefore = 0.5
        .LineRuleAfter = msoTrue
        .SpaceAfter = 0
    End With
    ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
    With ActiveWindow.Selection.TextRange
        .Text = "asdf"
        With .Font
            .Name = "Arial"
            .Size = 8
            .Color.SchemeColor = ppForeground
        End With
    End With
hellgrueneBlaetter
Gast


Verfasst am:
22. Mai 2009, 11:14
Rufname:


AW: Bilder importieren mit Text versehen und anordnen - AW: Bilder importieren mit Text versehen und anordnen

Nach oben
       Version: Office 2003

Embarassed
hellgrueneBlaetter
Gast


Verfasst am:
22. Mai 2009, 16:03
Rufname:

AW: Bilder importieren mit Text versehen und anordnen - AW: Bilder importieren mit Text versehen und anordnen

Nach oben
       Version: Office 2003

OK, ich habe das Probem nach stundenlanger Google-Suche und etlichen "Try&Error" Durchläufen hinbekommen. Ihr könnt den Code gerne benutzen. Für User ist er eingänglicher, wenn Ihr dazu noch einen schönen Command-button und ein paar sympathische Check-Boxes einbaut, doch das ist Geschmackssache.

Beschreibung: Dieses Makro importiert alle Grafikdateien eines vom User angegebenen Ordners in die Präsentation, resized sie auf eine bestimmte Höhe, ordnet sie nebeneinander und untereinander an und erstellt optional ein Label mit dem Ursprungsnamen der Grafikdatei.



Zitat:

Option Explicit

'***************************************************************************
'*
'* DESCRIPTION: This macro asks the user to specify a folder and will
'* import all images from there, align them and possibly
'* add a label with the original file name.
'*
'***************************************************************************


Const iFileMax = 10000 'max number of files in folder to be imported
Const iPosLeftOffset = 10 'minimum position from left
Const iPosTopOffset = 10 'minimum position from top
Const iVerticalSpace = 20 'spacing between two vertically aligned images
Const iHorizontalSpace = 10 'spacing between two horizontally aligned images
Const iSetHeight = 100 'image height in pixels
Const iTopLblOff = 13 'offset of the label in reference to its image
Const iLabelFontSize = 8 'font size of the label text


Public Sub myMain(Optional bAddLabel As Boolean, Optional bGroup As Boolean, Optional bAddBorderLine As Boolean)
'
' This is the main sub in the macro, you might call it by hand by clicking into
' it and pressing "F5". However, the check-box values might not be correctly be
' interpreted.
'

'--------------------------------------------------------------'
'VARIABLES
'--------------------------------------------------------------'
Dim i As Integer, j As Integer, k As Integer, iContent As Integer, iL As Integer, iT As Integer
Dim iPosLeftInc As Integer, iPosTopInc As Integer, iPosLeft As Integer, iPosTop As Integer
Dim strTgt As String
Dim objA As Shape, objB As Shape

'--------------------------------------------------------------'
'Get Source Folder from User
'--------------------------------------------------------------'
strTgt = getUserFolder("Please specify an import folder", "")
If Not strTgt <> "" Then Exit Sub

'------------------------------------'
'Get all file names in target folder
'------------------------------------'
ReDim arrFiles(0 To iFileMax)
arrFiles(0) = Dir(strTgt & "*.*") 'get first file in Target Folder (folder in which files will be changed)
Do Until arrFiles(iContent) = ""
iContent = iContent + 1
arrFiles(iContent) = Dir() 'get next file from directory
Loop

'------------------------------------'
'Undo selection
'------------------------------------'
ActiveWindow.Selection.Unselect 'unselecting whatever was selected before

'------------------------------------'
'Add another slide
'------------------------------------'
ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank).SlideIndex 'ppLayoutText or ppLayoutBlank

'------------------------------------'
'POSITIONING of first image
'------------------------------------'
iPosLeft = iPosLeftOffset
iPosTop = iPosTopOffset

'------------------------------------'
'Looping through Target folder
'------------------------------------'
For i = 0 To iContent - 1
'------------------------------------'
'IMPORT image
'------------------------------------'
Set objA = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strTgt & arrFiles(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=iPosLeft, Top:=iPosTop)
'------------------------------------'
'Resize image
'------------------------------------'
If objA.Height <> iSetHeight Then Call resizeShape(objA, iSetHeight, 0, True)
'------------------------------------'
'Positioning image
'------------------------------------'
If (iPosLeft + objA.Width + iHorizontalSpace) > ActivePresentation.PageSetup.SlideWidth Then
If (objA.Top + 2 * objA.Height + iVerticalSpace) > ActivePresentation.PageSetup.SlideHeight Then ''add new slide and move object there
objA.Cut
ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank).SlideIndex 'ppLayoutText or ppLayoutBlank
ActiveWindow.View.Paste
Set objA = ActiveWindow.Selection.SlideRange.Shapes(ActiveWindow.Selection.SlideRange.Shapes.Count)
objA.Left = iPosLeftOffset
objA.Top = iPosTopOffset 'correct alignment
Else
objA.Left = iPosLeftOffset: objA.Top = objA.Top + objA.Height + iVerticalSpace
End If
Else
objA.Top = iPosTop: objA.Left = iPosLeft
End If
'------------------------------------'
'Add Border-Line
'------------------------------------'
If bAddBorderLine Then objA.Line.Visible = msoTrue

'------------------------------------'
'Add Label
'------------------------------------'
If bAddLabel Then
Set objB = ActiveWindow.Selection.SlideRange.Shapes.AddLabel(msoTextOrientationHorizontal, objA.Left, objA.Top - iTopLblOff, 15, 30) '.Select
With objB.TextFrame.TextRange
.Text = arrFiles(i) '"asdf"
.Font.Size = iLabelFontSize
End With
'------------------------------------'
'Group together both image and label
'------------------------------------'
If bGroup Then ActiveWindow.Selection.SlideRange.Shapes.Range(Array(objA.Name, objB.Name)).Group
'------------------------------------'
'Read out new positioning values for the next object
'------------------------------------'
iPosTop = objA.Top: iPosLeft = objA.Left + objA.Width + iHorizontalSpace
End If
Next i 'import next image

ActiveWindow.Selection.Unselect 'unselecting the last label

End Sub

Function getUserFolder(sPre As String, sPost As String) As String
'
' this function asks the user for a folder
'
Dim strFolderName As String 'name of folder within which files have to be renamed
Dim objShell As Object
Dim BrowseDir As Variant

Set objShell = CreateObject("Shell.Application")
Set BrowseDir = objShell.BrowseForFolder(0, sPre & "Select Folder " & sPost, 0, 17)
If Not BrowseDir Is Nothing Then
strFolderName = BrowseDir.items().Item().Path & "\"
Else
Exit Function
End If
Set objShell = Nothing
Set BrowseDir = Nothing

'return value
getUserFolder = strFolderName

End Function

Sub resizeShape(objA As Shape, iHeight As Integer, iWidth As Integer, bLockAspectRatio As Boolean)

'------------------------------------'
'Catch Error
'------------------------------------'
If (iHeight = 0 And iWidth = 0) Or (iHeight < 0 Or iWidth < 0) Then
MsgBox "Invalid combination of Width and Height: '" & iWidth & " x " & iHeight & "'" & vbNewLine & _
"One must be zero and the other one larger than zero. Please try again."
Exit Sub
End If
'------------------------------------'
'Resize
'------------------------------------'
With objA '.ShapeRange
If bLockAspectRatio Then .LockAspectRatio = msoTrue Else: .LockAspectRatio = msoFalse
If iHeight > 0 And iWidth = 0 Then .Height = iHeight
If iWidth > 0 And iHeight = 0 Then .Width = iWidth
'.Width = 275#
End With
End Sub
Gast



Verfasst am:
09. Mai 2011, 10:05
Rufname:


AW: Bilder importieren mit Text versehen und anordnen - AW: Bilder importieren mit Text versehen und anordnen

Nach oben
       Version: Office 2010

Ist zwar schon etwas älter, hat aber ganz genau meine Anforderung getroffen.

Danke!
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Powerpoint Präsentationen: Bild und Text abwechselnd erscheinen lassen 3 Falco953 6442 13. Feb 2008, 19:09
Falco953 Bild und Text abwechselnd erscheinen lassen
Keine neuen Beiträge Powerpoint Präsentationen: Bilder aus Präsentation heraus kopieren 2 huebges 2227 15. Jan 2008, 12:48
Gast Bilder aus Präsentation heraus kopieren
Keine neuen Beiträge Powerpoint Präsentationen: PPT Jahreskalender 2008 mit Bilder erstellen 4 miku von der Ostalb 3965 08. Jan 2008, 21:10
miku von der Ostalb PPT Jahreskalender 2008 mit Bilder erstellen
Keine neuen Beiträge Powerpoint Präsentationen: avi lässt sich nicht importieren 1 Apollo54 2531 07. Jan 2008, 15:07
Apollo54 avi lässt sich nicht importieren
Keine neuen Beiträge Powerpoint Präsentationen: Fester Text (Folge-Folien) und Gesperrter Folien Bereich 1 chp 1527 07. Dez 2007, 17:50
Ute-S Fester Text (Folge-Folien) und Gesperrter Folien Bereich
Keine neuen Beiträge Powerpoint Präsentationen: Folie.autom.v.Hochform.i.Querformat stell.o.Verzerr.d.Bilder 3 Ela-Micha 1844 01. Okt 2007, 08:22
Ela-Micha Folie.autom.v.Hochform.i.Querformat stell.o.Verzerr.d.Bilder
Keine neuen Beiträge Powerpoint Präsentationen: Bilder werden durch Vergrößern in der Animation unscharf 4 katharina_p 7775 28. Aug 2007, 20:29
Ute-S Bilder werden durch Vergrößern in der Animation unscharf
Keine neuen Beiträge Powerpoint Präsentationen: Bilder austauschen 6 Jens_Pu 5147 15. Aug 2007, 15:38
Jens_Pu Bilder austauschen
Keine neuen Beiträge Powerpoint Präsentationen: Textfeld in text und Objekt umwandeln 0 Jan_fragt: 3877 25. Jul 2007, 16:39
Jan_fragt: Textfeld in text und Objekt umwandeln
Keine neuen Beiträge Powerpoint Präsentationen: *T*Text an Form anpassen 2 IT-User 4074 03. Jul 2007, 20:13
IT-User *T*Text an Form anpassen
Keine neuen Beiträge Powerpoint Präsentationen: Problem: Bilder von Excel in PowerPoint einfügen 3 tom1979 14902 10. Jun 2007, 10:07
Ute-S Problem: Bilder von Excel in PowerPoint einfügen
Keine neuen Beiträge Powerpoint Präsentationen: *T*bilder nacheinander auf eine folie? 3 rauschform 6726 14. Dez 2006, 00:10
flip2oo6 *T*bilder nacheinander auf eine folie?
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: PHP Forum