Frage - Automatische Formatirung und Einbindung von Bildern

[StevenRott]

Liebe Community,
ich habe folgendes Problem und da ich nicht weiß, welches das beste Programm für mein Problem ist (Excel oder Word) schreibe ich mal in die Kategorie "Sonstiges". Also:
Ich habe einen Dialog, der im txt-Format vorliegt. In diesem Text-Dokument sind Datum und Uhrzeit angegeben und sozusagen wer "spricht", also in etwa so:
09.03.2016, 13:57 - Person1: Hallo, wie geht es Dir ? 09.03.2016, 14:03 - Person2: Mir geht es gut.... usw.
Außerdem sind Bilderangaben im Dateiformat angegeben, z.B.: IMG-20160309-WA0011.jpg
Ich würde das Text-Dokument jetzt gerne automatisch formatieren, also z.B. die Sachen, die Person 1 sagt, automatisch linksbündig (Word) oder in Excel in eine Extra-Spalte, die Sachden die Person 2 sagt, nach einem Absatz, automatisch rechtsbündig oder in einer Extra-Spalte. Gerne auch in unterschiedlichen Farben.....

Außerdem würde ich gerne die Bilder, die im Dateiformat-Namen im Text-Dokument angegeben sind, als Bild-Datei einbinden lassen, also das tatsächliche Bild anzeigen lassen.

Ich weiß, das ist wohl ziemlich kompliziert, aber ich bräuchte das für meine Unterricht immer mal wieder (ich bin Lehrer...) um Dialoge aufzubereiten.

Achja...teilweise sind auch Smilies angegeben, die ich auch gerne korrekt anzeigen würde.

Ich bin für jede Hilfe dankbar, Makros, VBA-Schnipsel, die zu Lösng weiterhelfen oder eine Kompletlösung....ganz egal.....ich bin recht sicher im Umgang mit Word und/oder Excel, aber hier bräuchte ich dringend Hilfe......

Ich bedanke mich bei allen, die mir weiterhelfen, schon mal ganz herzlich im Voraus !!!

Liebe Grüße

Steven

[Gerhard H]

Hallo Steven,

hier ein ähnliches Anliegen, wo du vielleicht das Eine oder Andere für dich rausziehen kannst:
http://www.ms-office-forum.de/forum/...d.php?t=316673

[StevenRott]

Hallo, vielen Dank, das hilft schon mal sehr weiter !!!:-)

Jetzt habe ich noch das Problem, dass ich in meinem Text die Dateinamen von Bildern habe, die ich gerne per MAkro automatisch durch das tatsächliche Bild ersetzen möchte.....

Kann mi rhier noch jemand weiterhelfen ??

Liebe Grüße

Steven

[StevenRott]

Ich habe jetzt den Code genauer angeschaut, noch eine FRage, ow wird definiert, wie der Shape aussieht ?? Das finde ich nicht oder kapiere ich ehrlicherweise nicht....der Rest ist mir soweit klar.....
Sub grünekästen4()
Dim autotextname As String
Dim komplettText As String, textOhneSprecher As String
Dim uhrzeit As String, datum As String
Dim sprecher1 As String, sprecher2 As String
Dim anzahlabsätze As Long, i As Long
Dim kasten As Shape
Dim einfügestelle As Range

autotextname = "grüka"
sprecher1 = "Dreampeace Z." 'Anpassen!!
sprecher2 = "Max Mustermann" 'Anpassen!!
anzahlabsätze = ActiveDocument.Paragraphs.Count - 1

With ActiveDocument

For i = 1 To anzahlabsätze
'immer im letzten Absatz einfügen
Set einfügestelle = .Paragraphs.Last.Range
'als Autotext gespeicherte Autoform-Legende einfügen
.AttachedTemplate.BuildingBlockEntries(autotextname).Insert where:=einfügestelle
Set kasten = .Shapes(.Shapes.Count)

'textbestandteile auseinanderklauben und wieder zusammensetzen
komplettText = Left(.Paragraphs(i).Range.Text, _
Len(ActiveDocument.Paragraphs(i).Range.Text) - 1)

uhrzeit = Left(komplettText, 5)
datum = Mid(komplettText, 7, 14)

If InStr(komplettText, sprecher1) > 0 Then
textOhneSprecher = Mid(komplettText, 24 + Len(sprecher1), Len(komplettText))
kasten.Left = 0
kasten.TextFrame.TextRange = uhrzeit & datum & textOhneSprecher
Else
textOhneSprecher = Mid(komplettText, 24 + Len(sprecher2), Len(komplettText))
kasten.Left = 100
kasten.Fill.ForeColor.RGB = RGB(255, 255, 100)
kasten.TextFrame.TextRange = textOhneSprecher & datum & uhrzeit
End If

kasten.TextFrame.AutoSize = True
kasten.TextFrame.WordWrap = False
einfügestelle.InsertAfter Chr(13)
Next i

.Range(.Paragraphs(1).Range.Start, .Paragraphs(anzahlabsätze).Range.End).Delete

End With
End Sub

[Gerhard H]

Hallo Steven,

der grüne Kasten ist hier definiert:

Code:

autotextname = "grüka"
'...
.AttachedTemplate.BuildingBlockEntries(autotextname).Insert where:=einfügestelle

Das bedeutet:
Es wurde händisch eine Legende aus den Autoformen erzeugt und formatiert, danach mittels Alt-F3 als Autotext unter dem Namen "grüka" abgespeichert. Wichtig dabei ist, dass der Speicherort die eigene Dokumentvorlage ist.

Händisch könntest du diesen Baustein über Einfügen > Schnellbausteine > Organizer für Schnellbausteine finden, und zwar in der Dokumentvorlage, aus der du dieses Makro hast.

Im Makro übernehmen die zitierten Zeilen das Einfügen.

[StevenRott]

Hallo Gerhard,

ich versuche den damaligen Beitrag nach und nach zu verstehen.......ich habe jetzt die erste Datei mit den Makros heruntergeladen und versucht auf meine Grundlage umzumünzen......leider bekomme ich einen Indexfehler.....
Das ist mein Quelltext:
29.03.18, 17:50 - Person 1: ‎IMG-20180329-WA0006.jpg (Datei angehängt)
Fast wie das Original!!😍😍😂😂😂😂😘😘😂😂🙄🙄
‎29.03.18, 17:50 - Person 2: ‎29.03.18, 17:51 - Person 2: 😂😂😂😂besser!!! VIEL BESSER!!!!😍😍😍😍😍😍😍😂😂😂
‎‎29.03.18, 17:52 - Person 1: 😂😂😂😂zumindest vom aussehen her......🙄🙄😂😂😘😘😍😍🙄🙄
‎29.03.18, 17:55 - Person 2: Hol den Pokal!!😂😂😍😍😍😍😍😍ich setze mich schon mal ans Fenster!😂😂😍😍😍😍😍
‎29.03.18, 18:05 - Person 1: Jaaa!!!😘😘😘😍😍😍😍😂😂😂ich schreib kurz vorher okay!??😂😂😂😂😂😂😂
‎‎29.03.18, 18:27 - Person 2: Ist okay…..😂😂😍😍😍
‎29.03.18, 18:34 - Person 2:
‎29.03.18, 18:59 - Person 1: ‎IMG-20180329-WA0009.jpg (Datei angehängt)
Es 7st angerichtet!!😘😘😍😍

Und jetzt habe ich die Datei wie folgt abgeändert:

Code:

Sub WhatsApp2Doc()
Dim oDoc As Document: Set oDoc = ActiveDocument
Dim oCol As New Collection
Dim oPara As Paragraph, oRng As Range
Dim oTable As Table, oRow As Row, sDate As String
Dim vSearch As Variant, vReplace As Variant, vEntry As Variant
Dim i As Long, sgWidth As Single
Const sName1 = "Person1:", sName2 = "Person2:"

    vSearch = Array("([0-9]{2})(.)(01)(.)( [0-9]{4})", "([0-9]{2})(.)(02)(.)( [0-9]{4})", _
        "([0-9]{2})(.)(03)(.)( [0-9]{4})", "([0-9]{2})(.)(04)(.)( [0-9]{4})", _
        "([0-9]{2})(.)(05)(.)( [0-9]{4})", "([0-9]{2})(.)(06)(.)( [0-9]{4})", _
        "([0-9]{2})(.)(07)(.)( [0-9]{4})", "([0-9]{2})(.)(08)(.)( [0-9]{4})", _
        "([0-9]{2})(.)(09)(.)( [0-9]{4})", "([0-9]{2})(.)(10)(.)( [0-9]{4})", _
        "([0-9]{2})(.)(11)(.)( [0-9]{4})", "([0-9]{2})(.)(12)(.)( [0-9]{4})")
    vReplace = Array("2. Januar4", "2. Februar4", "2. März4", "2. April4", "2. Mai4", _
        "2. Juni4", "2. Juli4", "2. August4", "2. September4", "2. Oktober4", "2. November4", "2. Dezember4")

    Application.ScreenUpdating = False
    
    Set oRng = oDoc.Content
    
    ClearFindnReplace
    With oRng.Find
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        For i = LBound(vSearch) To UBound(vSearch)
            .Text = vSearch(i)
            .Replacement.Text = vReplace(i)
            .Execute Replace:=wdReplaceAll
        Next i
    End With

    ClearFindnReplace
    With oRng.Find
        .Text = "([0-9]{2}:[0-9]{2})(,)"
        .Replacement.Text = "1 -"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    

    For Each oPara In oDoc.Paragraphs
        If Len(oPara.Range.Text) > 1 Then
            If InStr(oPara.Range.Text, sName1) > 0 Then
                On Error Resume Next
                oCol.Add Replace(oPara.Range.Text, sName1, "") & " - l", oPara.Range.Text
                On Error GoTo 0
            ElseIf InStr(oPara.Range.Text, sName2) > 0 Then
                On Error Resume Next
                oCol.Add Replace(oPara.Range.Text, sName2, "") & " - r", oPara.Range.Text
                On Error GoTo 0
            End If
        End If
    Next
    
    oDoc.Content.Delete
    oDoc.Content.InsertAfter Chr(13)
    
    vEntry = Split(oCol(1), " - ")
    sDate = vEntry(1)
    
    Set oTable = oDoc.Tables.Add(oDoc.Paragraphs.Last.Range, 1, 4)
    
    With oTable.Borders(wdBorderTop)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    With oTable.Borders(wdBorderLeft)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    With oTable.Borders(wdBorderBottom)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    With oTable.Borders(wdBorderRight)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    With oTable.Borders(wdBorderVertical)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    
    sgWidth = CurrentTableWidth(1)
    
    oTable.Columns(4).Width = CentimetersToPoints(1.5)
    oTable.Columns(3).Width = (sgWidth - CentimetersToPoints(3)) / 2
    oTable.Columns(2).Width = (sgWidth - CentimetersToPoints(3)) / 2
    oTable.Columns(1).Width = CentimetersToPoints(1.5)
    oTable.AutoFitBehavior (wdAutoFitFixed)
    
    oTable.Cell(1, 1).Range.Text = sDate
    
    For i = 1 To oCol.Count
        Set oRow = oTable.Rows.Add
        vEntry = Split(oCol(i), " - ")
        If Not vEntry(1) = sDate Then
            sDate = vEntry(1)
            oRow.Cells(1).Range.Text = sDate
            Set oRow = oTable.Rows.Add
        End If
        Select Case vEntry(3)
            Case "l"
                With oRow.Cells(1).Range
                    .Text = vEntry(0)
                    .ParagraphFormat.Alignment = wdAlignParagraphRight
                End With
                With oRow.Cells(2).Range
                    .Text = Trim(vEntry(2))
                    .ParagraphFormat.Alignment = wdAlignParagraphLeft
                End With
            Case "r"
                With oRow.Cells(4).Range
                    .Text = vEntry(0)
                    .ParagraphFormat.Alignment = wdAlignParagraphLeft
                End With
                With oRow.Cells(3).Range
                    .Text = Trim(vEntry(2))
                    .ParagraphFormat.Alignment = wdAlignParagraphRight
                End With
            Case Else
                MsgBox "Sollte gar nicht vorkommen !!!"
        End Select
        
    Next
    
    Set oRng = oTable.Range
    ClearFindnReplace
    With oRng.Find
        .Text = Chr(13)
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Execute Replace:=wdReplaceAll
    End With
    
    For Each oRow In oTable.Rows
        If Len(oRow.Cells(1).Range.Text) > 10 Then
            oRow.Range.Cells.Merge
            oRow.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
            oRow.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            oRow.Range.Font.Bold = True
        End If
    Next

End Sub

Zusätzlich gibt es noch folgende SUB-Routinen:

Code:

Sub ClearFindnReplace()

    With Selection.Find
       .ClearFormatting
       .Replacement.ClearFormatting
       .Text = ""
       .Replacement.Text = ""
       .Forward = True
       .Wrap = wdFindStop
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
    End With
    
End Sub

und:

Code:

Function CurrentTableWidth(TabInd As Integer) As Single
' vgl: http://windowssecrets.com/forums/showthread.php/132934-Determine-Width-of-Table
Dim oDoc As Document: Set oDoc = ActiveDocument
Dim tRng As Range, sngWdth As Single

    With oDoc.Tables(TabInd)
        Set tRng = .Rows(1).Range
        tRng.MoveEnd wdCharacter, -1
        sngWdth = -tRng.Information(wdHorizontalPositionRelativeToPage)
        tRng.Start = tRng.End
        CurrentTableWidth = sngWdth + tRng.Information(wdHorizontalPositionRelativeToPage)
    End With
    
End Function

Wenn ich nun das Makro WhatsApp2Doc starte, dann bekomme ich folgende Fehlermeldung:
Ungültiger Prozeduraufruf oder ungültiges Argument

Ich kann leider nicht nachvollziehen wo ?!

Entschuldigt bitt emein dilletantisches Nachfragen, aber ich versuche mich daran gerade rein zu fuchsen und lerne......:-))

Liebe Grüße

Steven

[StevenRott]

Hallo Gerhard,

da fällt mir noch ein, gegen später wird etwas von einer Replacement.doc-Datei geredet......in Langform, die eigentlich auf einem Uploaded-Zugang liegen sollte, aber da gibt es die nicht mehr......hast du die zufällig ???

Grüße

Steven

[Gerhard H]

Hallo Steven,

mir ist völlig unklar, was du bis jetzt hingekriegt hast und was nicht. Mir ist auch unklar, was genau das Ziel ist. Ich reihe einfach ein paar meiner Unklarheiten auf:

• In der verlinkten Diskussion wurde mit einem "Sprechblasenlayout" begonnen und irgendwann auf ein "Tabellenlayout" umgeschwenkt. Welches willst du weiterverfolgen?
• Was ist mit dem "grüne-Kasten-Problem aus Beitrag 4? Geht das jetzt klar? Oder ist es mittlerweile irrelevant?
• Du versuchst "den damaligen Beitrag" nach und nach zu verstehen. Bei welchen (Einzel-) Beitrag stehst du da grad an?
• Du bekommst leider "einen Indexfehler". In welchem Dokument, in welchem Makro, in welcher Zeile tritt der auf?
• "Und jetzt hab ich die Datei wie folgt abgeändert". Ist der Index-Fehler damit behoben?
• "Wenn ich nun das Makro WhatsApp2Doc starte, dann bekomme ich folgende Fehlermeldung: Ungültiger Prozeduraufruf oder ungültiges Argument. Ich kann leider nicht nachvollziehen wo ?"
  Ich auch nicht. Dazu bräuchte ich deine aktuelle Datei mit sämtlichen Makros drin.
• "Gegen später wird etwas von einer Replacement.doc-Datei geredet"
  Nein, ich hab keine der dort hochgeladenen Dateien mehr. Bei welcher Gelegenheit ist dir aufgefallen, dass du die brauchst? In welchem Beitrag (Nr.) wird davon geredet?

Es hat glaub ich auch keinen Sinn, dass du diese komplette Diskussion nachvollziehen willst. Da wurden so viele Sonder- und Detailwünsche behandelt, die du vielleicht gar nicht brauchst oder anders haben willst (ich kann mich im Einzelnen nicht mehr dran erinnern, denn es ist schon ein paar Jahre her und ich war nur zu Anfang mitbeteiligt).

Was mich betrifft, kann ich wohl nur beim Erstellen einer "Basisversion" mithelfen.

Dazu schlage ich dir vor, dass du ein Musterdokument erstellst, das ein dein Ausgangsmaterial enthält (natürlich nur einen Auszug zu Testzwecken) und in dem sämtliche Makros drin sind, die du bisher verwendet hast bzw. verwenden wolltest. Damit wenigstens klar ist, wovon wir reden.

[StevenRott]

Hallo Gerhard,

sorry, das sich mich erst jetzt wieder melde, aber es ging gerade etwas beruflich drunte und drüber, sodass ich die letzten Tage wenig Zeit für mein "Problem" hatte, aber jetzt......also ich habe jetzt mal 2 Dateien, eine was meine Grundlage ist und wo ich einen Teil des Codes aus der "End-Datei " von damals rein kopiert habe.....hier erscheint ein Indexfehler......mein Ziel ist es, dass alles so aussieht wie in der Ziel-Datei, die ihr damals zusammengebastelt habt, das sieht super aus !!:-)
Die Bilder, die nicht gefunden werden, solen entsprechend markiert werden, Bilder, die in einem bestimmten Ordner gefunden werden, sollen dann angezeigt werden.......und als kleines Sahnehäubchen auch Videos, die in dem Ordner legen....
Außerdem sollen Smilies, die in einer TXT-Datei sind durch "echte" Smilies ersetzt werden, eben genau so wie in der Ziel-Datei..
Ich möchte aber verstehen, was ich tue und was passiert, deshalb möchte ich das gerne Schritt für Schritt, anch und nach, programmieren bzw. zusammenstellen.

Es wäre echt super nett von Dir, wen du mir da ein bisschen weiterhelfen könntest......:-)

Ganz liebe Grüße

Steven