Live-Forum - Die aktuellen Beiträge
Datum
Titel
17.05.2024 11:03:10
Ganze Zahl in Ganz-Zahl Kombinationen aufteilen (ohne Rest)
17.05.2024 10:40:53
Tabellen (formatiert) über VBA auswählen
17.05.2024 10:13:05
Excel Tabelle - Ort/Stadt nur einmal pro Kunde zählen?
17.05.2024 09:40:47
Warum geht das Fenster aktualisieren auf
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1948to1952
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1948to1952
1948to1952
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Bindestriche verschwinden von Email Adresse

Bindestriche verschwinden von Email Adresse
26.10.2023 08:19:13
Anton
Guten Morgen liebes Forum,

ich bin mittlerweile am Verzweifeln, weil ich es nicht wirklich verstehe, wo genau ist ein Fehler mache. Ist es bei euch auch schon vorgekommen, wenn in der Zelle eine Email kopiert wurde z.B. Test-Info@Email-Adresse.de wenn ich diese von einer Zelle in Outlook per VBA hinzufüge wird die Email ohne Bindestriche angezeigt z.B. TestInfo@EmailAdresse.de, warum das passiert kann ich mir nicht erklären. Unter Debug.print in der Console wird die richtige Email Adresse (Test-Info@Email-Adresse.de) angezeigt. Unter Label und TextBox wird die falsche Email (TestInfo@EmailAdresse.de) angezeigt.

Habe ein kleine VBA geschrieben mit dem Hilfsprogramm pdftotext.exe, das eine Kostenvoranschlag PDF in TXT umwandelt und ich diese TXT auslese tue und ich einige Eckdaten in verschiedene Zellen zu schreiben. Wie z.B. Firmenname, Seriennummer, PLZ, Email, Email CC, Ansprechpartner, Betrag. Das funktioniert soweit alles einwandfrei.
Nur wie gesagt wenn ich auf dem Button "Email Senden" klicke, wir die Email einfach kastriert.

Hier der Code, die Codes wurden vom Internet übernommen und für meine Verhältnisse angepasst:

Ich weiss nicht ob der Quellcode euch was bringt, ich kopiere euch mal ein Teil rein.

Der Code zum umwandeln der PDF in eine TXT Datei. (Kann hier schon der Fehler liegen, das das Umwandlungstool was damit zu tun hat?) 

Sub PDF2TXT()

    'PDF Auflisten und in TXT umwandeln

    Dim i As Integer

    Dim strCMDLine As String

    Dim FSO As Object, objSFold As Object, objWks As Object, WSHShell As Object, file As Object

    Dim colPFiles As New Collection

      

    Set WSHShell = CreateObject("WScript.Shell")

    Set FSO = CreateObject("Scripting.FileSystemObject")

    'Set regex = CreateObject("vbscript.regexp")

    'regex.MultiLine = True

    'MsgBox (TextBox3.Text & " " & ThisWorkbook.Path)

    Set objSFold = FSO.GetFolder(TextBox3.Text) '(ThisWorkbook.path)

    

    strCMDLine = """" & ThisWorkbook.Path & "\pdftotext.exe"" -raw -layout -nopgbrk "

        

    For Each file In objSFold.Files                                  ' alle Dateien einlesen

        

        If Right(file.Path, 4) = ".pdf" Then colPFiles.Add file.Path  ' nur *.pdf

    Next

    'MsgBox (colPFiles.Count)

    For i = 1 To colPFiles.Count

         WSHShell.Run strCMDLine & """" & colPFiles.Item(i) & """", 0, True

    Next

 

End Sub

---------------- Jetzt kommt die Text Ausfilterung, wo die ganzen Eckdaten ausgelesen werden und in den Zellen kopiert werden --------------- 

Private Sub TXT_Filtern()

'Textdateien Einlesen und filtern

  Dim Spalte As Integer

  Dim strZeile As String

  Dim sFirma As String      '22.10.2023

  Dim sAnsprech As String '22.10.2023

  Dim sBetrag As String '22.10.2023

  Dim iAnredePos As Integer '22.10.2023

  Dim aEmail() As String

  Dim sNummer As String '22.10.2023

  Dim aPLZa() As String '03.10.2023

  Dim aPLZb() As String '03.10.2023

  Dim aPLZc() As String '21.10.2023

  Dim geschlecht As Integer

  Dim iSerNr_pos As Integer

  Dim i, ii As Integer

  Dim FSO As Object, objSFold As Object, objWks As Object, file As Object

  Dim TSO As Object

  Dim Path As String

  Dim Zeile As Integer

  Dim colTFiles As New Collection

  Dim Firma As String

  'Dim sNummer As String

  Dim iEmailPos1 As Integer '22.10.2023

  Dim iEmailpos2 As Integer '22.10.2023

  Dim sEmail2 As String '22.10.2023

  Dim iPLZzeile As Integer '22.10.2023

  Dim sEmail_nach As String '22.10.2023

  Dim sEmail_vor As String '22.10.2023

  Dim sEmail As String '22.10.2023

  Dim iiii As Integer '22.10.2023

  

  Jahr = Year(Date)

    

  Set FSO = CreateObject("Scripting.FileSystemObject")

  Set objSFold = FSO.GetFolder(TextBox3.Text) '(ThisWorkbook.Path)

    

    For Each file In objSFold.Files                                  ' alle Dateien einlesen

        If Right(file.Path, 4) = ".txt" Then

        i = i + 1

        colTFiles.Add file.Path

        Sheets("Dateien").Cells(1 + i, 1).Value = i

        Sheets("Dateien").Cells(1 + i, 2).Value = file.Path

        Sheets("Dateien").Cells(1 + i, 3).Value = TextBox3.Text ' nur *.pdf

        End If

    Next

   

  Set FSO = CreateObject("Scripting.FileSystemObject")

    For Zeile = 1 To colTFiles.Count 'Sheets("Tabelle1").Cells(30, 1).Value



  Set TSO = FSO.OpenTextFile(colTFiles.Item(Zeile))



  'Range("C:P").Clear

  Spalte = 1

  For ii = 0 To 30

  'Do While Not TSO.AtEndOfStream

     'i = i + 1

     strZeile = TSO.Readline

     

     'Ausgabe KOVO auf Tabelle

     'Cells(3 + ii, Spalte).Value = ii

     'Cells(3 + ii, Spalte + 1).Value = Trim(strZeile) 'ActiveCell = strZeile

      

     '[ 22.10.2023 Suche Firma im Text (funktioniert)

      If ii > 7 And ii  10 Then

      If InStr(strZeile, "Belegnummer") > 0 Then

      sFirma = Mid(strZeile, 1, (InStr(strZeile, "Belegnummer") - 1))

      sFirma = RTrim(sFirma)     'Firma Adresse suchen und finden

      sFirma = LTrim(sFirma)

      Firma = sFirma

      End If

      End If

      '  22.10.2023 Suche Firma im Text ]

     

     '[ 22.10.2023 Suche Ansprechpartner im Text (funktioniert)

     If InStr(strZeile, "Frau") > 0 Or InStr(strZeile, "Herr") > 0 Then

        If InStr(strZeile, "Herr") > 0 Then iAnredePos = InStr(strZeile, "Herr")

        If InStr(strZeile, "Frau") > 0 Then iAnredePos = InStr(strZeile, "Frau")

        sAnsprech = Mid(strZeile, iAnredePos, 25)

        sAnsprech = LTrim(sAnsprech)

        sAnsprech = RTrim(sAnsprech)

     End If

     '[ 22.10.2023 Suche Ansprechpartner im Text (funktioniert)

     

     

     '[ 22.10.2023 Suche Seriennumemr im Text (funktioniert)

     If InStr(strZeile, "Serviceobjekt") > 0 Or InStr(strZeile, "Service object") > 0 Then

        iSerNr_pos = ii

        sNummer = Mid(strZeile, iSerNr_pos, 20)

        sNummer = LTrim(sNummer)

        sNummer = RTrim(sNummer)

     End If

     ' [ 22.10.2023 Suche Seriennumemr im Text] (funktioniert)

     

     '[ 22.10.2023 Suche Betrag im Text (funktioniert)

     If InStr(strZeile, "Gesamtbetrag") > 0 Then

     sBetrag = Mid(strZeile, 18 + InStr(strZeile, "Gesamtbetrag"), 20)

     sBetrag = Replace(sBetrag, "EUR", " ")

     sBetrag = LTrim(sBetrag)

     sBetrag = RTrim(sBetrag)

     'MsgBox (sBetrag)

     End If

    '  22.10.2023 Suche Betrag im Text ]



    ' If ii > 15 Then If InStr(strZeile, "@") > 0 Then aEmail = Split(strZeile, " ")

     

     '[22.10.2023 Email adresse Filtern

     If ii > 16 Then

     '[ 22.10.2023 Hintere Email Adresse bearbeiten nach dem @

     If InStr(strZeile, "@") > 0 Then

     iEmailPos1 = InStr(strZeile, "@")

     'Cells(sZeile + Zeile, Spalte + 20 - 1).Value = iEmailPos1

      sEmail_nach = Mid(strZeile, iEmailPos1, 100)      '24,53

    ' 22.10.2023 Hintere Email Adresse bearbeiten nach dem @ ]

     

     '[ 22.10.2023 Vorder Email bearbeiten vor dem @ Buchstaben zählen bis zum Leerzeichen

     For iiii = 0 To 30 'Überprüfe jeden Buchstaben bis zum Leerzeichen, dann springe ich aus der Schreife

     If InStr(Mid(strZeile, iEmailPos1 - iiii, 1), " ") > 0 Then GoTo 10

     'Debug.Print Mid(strZeile, iEmailPos1 - iiii, 1), iiii

     iiii = iiii + 1

     Next iiii

10   iEmailpos2 = iiii

     sEmail_vor = Trim(Mid(strZeile, iEmailPos1 - iEmailpos2, iEmailpos2))

     'Cells(sZeile + Zeile, Spalte + 21 - 1).Value = sEmail_vor

     'MsgBox ("fertig" & iEmailpos2)

    ' 22.10.2023 Vorder Email bearbeiten vor dem @ Buchstaben zählen bis zum Leerzeichen ]

     

    ' Cells(sZeile + Zeile, Spalte + 25 - 1).Value = sEmail_vor

     'Cells(sZeile + Zeile, Spalte + 22 - 1).Value = sEmail_nach

     sEmail = sEmail_vor & sEmail_nach  'Emailhäften zusammenführen

     'Cells(sZeile + Zeile, Spalte + 23 - 1).Value = sEmail

     aEmail = Split(sEmail, ";")

     aEmail = Split(sEmail, " ")

     If UBound(aEmail) = 1 Then

     'Cells(sZeile + Zeile, Spalte + 24 - 1).Value = aEmail(0)

     'Cells(sZeile + Zeile, Spalte + 25 - 1).Value = aEmail(1)

              

     End If



     End If

     End If

     '22.10.2023 Email adresse Filtern ]

     

    

     '[PLZ für Kundenbetreuer 03.10.2023

      If ii = 10 Then aPLZa = Split(strZeile, " ")

      If ii = 11 Then aPLZb = Split(strZeile, " ")

      If ii = 9 Then aPLZc = Split(strZeile, " ")

      ']



  Next ii

  'Loop

  TSO.Close

  

 

  'Ausgabe

  'Zeilennummer

  ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 2).Value = Zeile                                                            'Zeilennummer

  'Firma

  If sFirma > "" Then ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 3).Value = Firma 'sFirma 'Funktioniert einwandfrei  22.10.2023

  'Ansprechpartner

  If sAnsprech > "" Then ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 9).Value = sAnsprech '22.10.2023

  'Seriennummer

  If sNummer > "" Then ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 4).Value = sNummer  '22.10.2023

   'Seriennummer

  If sBetrag > "" Then '22.10.2023

  ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 8).Value = CDec(sBetrag)

  ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 8).NumberFormat = "#,##0.00 €"  '22.10.2023

  End If

  'Email Adresse/n

  ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 6).Value = sEmail

  If UBound(aEmail) > 0 Then

  ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 6).Value = aEmail(0)

  ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 7).Value = aEmail(1)

  End If

  

'[PLZ für Kundenbetreuer 21.10.2023

  If UBound(aPLZa()) > 0 Then

    If Len(aPLZa(0)) = 5 Then

        'If IsNumeric(aPLZa()) Then

            ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 5).Value = aPLZa(0)

            Sheets("Kundenbetreuer").Range("B2").Value = aPLZa(0)

            Sheets("Email senden").Cells(4 + Zeile, Spalte + 10).Value = Sheets("Kundenbetreuer").Range("H2").Value 'Kundenbetruer

            Sheets("Email senden").Cells(4 + Zeile, Spalte + 11).Value = Sheets("Kundenbetreuer").Range("E2").Value

            'MsgBox ("1a " & aPLZa(0))

        'End If

    End If

 End If

 

 If UBound(aPLZb()) > 0 Then

    If Len(aPLZb(0)) = 5 Then

        'If IsNumeric(aPLZb()) Then

        ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 5).Value = aPLZb(0)

        Sheets("Kundenbetreuer").Range("B2").Value = aPLZb(0)

        Sheets("Email senden").Cells(4 + Zeile, Spalte + 10).Value = Sheets("Kundenbetreuer").Range("H2").Value 'Kundenbetreuer

        Sheets("Email senden").Cells(4 + Zeile, Spalte + 11).Value = Sheets("Kundenbetreuer").Range("E2").Value

            'MsgBox ("2b " & aPLZb(0))

        'End If

    End If

 End If

 

 If UBound(aPLZc()) > 0 Then

    If Len(aPLZc(0)) = 5 Then

        'If IsNumeric(aPLZc()) Then

        ThisWorkbook.Sheets("Email Senden").Cells(4 + Zeile, Spalte + 5).Value = aPLZc(0)

        Sheets("Kundenbetreuer").Range("B2").Value = aPLZc(0)

        Sheets("Email senden").Cells(4 + Zeile, Spalte + 10).Value = Sheets("Kundenbetreuer").Range("H2").Value 'Kundenbetreuer

        Sheets("Email senden").Cells(4 + Zeile, Spalte + 11).Value = Sheets("Kundenbetreuer").Range("E2").Value

            'MsgBox ("2c " & aPLZc(0))

        'End If

    End If

 End If

'PLZ für Kundenbetreuer 21.10.2023]



 '[PDF umbenennen

 Dim strFileExistsP As String

 

 strFileExistsP = Dir(TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".pdf", vbDirectory)

  

    If strFileExistsP = "" Then

        'MsgBox "Die Datei " & TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".pdf" & " existiert nicht"

        'Debug.Print "Die Datei " & TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".pdf" & " existiert nicht"

        Name Mid(colTFiles.Item(Zeile), 1, Len(colTFiles.Item(Zeile)) - 4) & ".pdf" As TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".pdf"

        'Debug.Print "Dateien wurden umbenannt"

    Else

        'Kontrolle

        'Debug.Print TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".pdf" & " vorhanden"

    End If

 'PDF umbenennen]

  

 '[TXT umbenennen

 Dim strFileExistsT As String



 strFileExistsT = Dir(TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".txt", vbDirectory)



    If strFileExistsT = "" Then

        'MsgBox "Die Datei " & TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".txt" & " existiert nicht"

        Name colTFiles.Item(Zeile) As TextBox3.Text & "KOVO - " & Firma & " - " & sNummer & " - " & Jahr & ".txt"

    Else

        'Kontrolle

        'Debug.Print TextBox3.Text & "KOVO - " & sFirma & " - " & sNummer & " - " & Jahr & ".txt" & "vorhanden"

    End If

 'PDF umbenennen]

 

 Next Zeile

 Set TSO = Nothing

 Set FSO = Nothing

 

 With Worksheets("Email Senden")

.Range("A2:Z1000").VerticalAlignment = xlCenter

.Range("C:C").HorizontalAlignment = xlCenter

.Range("E:F").HorizontalAlignment = xlCenter

End With



End Sub


---------------------------------------------------- Hier kommt jetzt Email Senden ----------------------------- 

Sub Email_Senden()

'+++++ Email Button Senden +++++

Dim i, iPos, iPosBetreff, iPosText1, iPosText2, iPosText3, iRow, iStatistik As Integer

Dim sSuchen, sEmail, sCC1, sCC2, sName1, sName2, sAnrede1, sAnrede2, sBetreff, sText1, sText2, sText3, sText4, sText5 As String



iPos = 1: iPosBetreff = 1: iPosText1 = 1: iPosText2 = 1: iPosText3 = 1

Jahr = Year(Date)

'sText4 = "Mit Bitte um Durchsicht und Freigabe des Kostenvoranschlages / der Kostenvoranschläge."

'sText5 = "Mit Bitte um Durchsicht und Freigabe der Kostenvoranschläge."



iPos = ThisWorkbook.Sheets("HilfsTab").Range("B17")

iPosBetreff = ThisWorkbook.Sheets("HilfsTab").Range("B18")

iPosText1 = ThisWorkbook.Sheets("HilfsTab").Range("B19")

iPosText2 = ThisWorkbook.Sheets("HilfsTab").Range("B20")

iPosText3 = ThisWorkbook.Sheets("HilfsTab").Range("B21")



sEmail = Range("G" & iPos).Value

sCC1 = Range("H" & iPos).Value

sCC2 = Range("I" & iPos).Value

sName1 = Range("J" & iPos).Value

sName2 = Range("K" & iPos).Value



sAnrede1 = LCase(Mid(sName1, 1, 4))

'sAnrede2 = LCase(Mid(sName2, 1, 4))



sBetreff = Range("N" & iPosBetreff)



If iPosText1 > "" Then sText1 = Range("S" & iPosText1)

If iPosText2 > "" Then sText2 = Range("S" & iPosText2)

If iPosText3 > "" Then sText3 = Range("S" & iPosText3)



'MsgBox (Sheets("HilfsTab").Range("C15"))



'[

If Sheets("HilfsTab").Range("C15").Value > "" And Sheets("HilfsTab").Range("C15").Value = 1 Then

sBetreff = "Kostenvoranschlag " & ThisWorkbook.Sheets("HilfsTab").Range("B23")

sText1 = "wie gewünscht sende ich Ihnen den Kostenvoranschlag zu."

sText2 = "Mit Bitte um Durchsicht und Freigabe des Kostenvoranschlages."

sText3 = "Folgender Anhang wird mit gesendet: "

sText4 = Anhang

End If



If Sheets("HilfsTab").Range("C15").Value > "" And Sheets("HilfsTab").Range("C15").Value > 1 Then

sBetreff = "Kostenvoranschläge"

sText1 = "wie gewünscht sende ich Ihnen die Kostenvoranschläge zu."

sText2 = "Mit Bitte um Durchsicht und Freigabe der Kostenvoranschläge."

sText3 = "Folgende Anhänge werden mit gesendet: "

sText4 = Anhang

End If



'MsgBox sAnrede, , sAnrede1



'EMail an Kollegen

'If sEmail > "" And sAnrede1 = "hallo" And sAnrede2 = "" Then

'    Call EmailSenden(CStr(sEmail), CStr(sCC1), CStr(sBetreff), "Hallo " & sName1 & ",

" & sText1 & "
" & sText2 & "
" & sText3 & "
" & sText4 & "
" & sText5 & "")

'End If



''''Msg = Msg & "

'EMail an einer Person - männlich

If sEmail > "" And InStr(sName1, "Herr") > 0 Then

'MsgBox ("Mann")

    Call EmailSenden(CStr(sEmail), CStr(sCC1), CStr(sBetreff), "Sehr geehrter " & sName1 & ",

" & sText1 & "

" & sText2 & "

" & sText3 & "
" & sText4 & "")

End If



''EMail an zwei Personen - männlich

'If sEmail > "" And sAnrede1 = "herr" And sAnrede2 = "herr" Then

'    Call EmailSenden(CStr(sEmail), CStr(sCC1), CStr(sBetreff), "Sehr geehrter " & sName1 & ",
" & "Sehr geehrter " & sName2 & ",

" & sText1 & "
" & sText2 & "
" & sText3 & "
" & sText4 & "
" & sText5 & "")

'End If



'EMail an einer Person - weiblich

If sEmail > "" And InStr(sName1, "Herr") = 0 Then

'MsgBox ("Frau")

'MsgBox "Eine Personen " & sEmail

Call EmailSenden(CStr(sEmail), CStr(sCC1), CStr(sBetreff), "Sehr geehrte " & sName1 & ",

" & sText1 & "

" & sText2 & "

" & sText3 & "
" & sText4 & "")

End If



End Sub




--------------------------------------------------- ENDE -----------------------------------------------------

Ich danke euch vielmals für die Bemühungen.

VG Anton

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 08:42:11
bigmayo
Moin Anton,

ich finde in deinem Code keinen Fehler der dein Problem verursachen könnte.
Ich vermute das der Fehler durch das Umwandlungstool verursacht wird.

Es ist wichtig zu beachten, dass die Formatierung von Text in einer PDF-Datei von der PDF-Erstellung und den verwendeten Tools abhängen kann.
Wenn die PDF-Datei bereits eine bestimmte Formatierung der E-Mail-Adresse aufweist, kann es schwierig sein, dies zu ändern.
Die besten Lösungen hängen daher von den Eigenschaften der PDF-Datei und den verfügbaren Tools ab.

Gruß
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 09:10:30
Oberschlumpf
Hi Anton,

anstelle, dass du uns soooooo viel Code ohne Datei zeigst, in der wir deinen Code testen könnten, wäre es vielleicht hilfreicher, wenn du uns...

a) eine Bsp-PDF-Datei per Upload zeigst
b) eine Bsp-Excel-Datei mit allem, was erforderlich ist, um dein Problem zu verstehen, per Upload zeigst

Ich selbst nutze auch das Tool pdftotext.exe zum Auslesen von PDF-Dateien....und ich hab damit absolut gar keine Probleme!

Ach so, bevor du wegen a) monierst, dass du doch nur Original-PDF-Dateien hast und diese wegen Datenschutz hier nicht uploaden kannst, entgegne ich mit dem Argument:

Erstell doch in WORD eine Datei mit Bsp-Texten UND natürlich auch mit eMail-Adressen an den richtigen Stellen und speicher diese WORD-Datei ab als PDF-Datei - und schon hast du eine PDF-Bsp-Datei.

Ciao
Thorsten
Anzeige
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 09:57:28
Anton
Hallo Oberschlumpf,

das ist eine gute Idee, anstatt eine PDF schicke ich euch die bearbeitete (Datenschutz) TXT Datei, die könnt ihr mit dem 2. Button einlesen und in der Spalte AK Zeile 6 siehst du dann die Email Adresse was nicht richtig dargestellt wird.

https://www.herber.de/bbs/user/163746.xlsm
https://www.herber.de/bbs/user/163747.txt

Sieht bissl chaotisch aus :-)

Ich danke euch allen, für die tolle Hilfe.

VG Antonios
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 10:27:33
Oberschlumpf
Hi Antonios,

hab deine Bsp-Dateien getestet, und...ich kann nicht den von dir erwähnten Fehler feststellen :-)

guckst du:
Userbild
hier ein Screenshot aus dem rechten Bereich deiner Tabelle

Userbild
und hier ein Screenshot der Spalte AK

in allen Zellen wird in der Mailadresse auch der Bindestrich gezeigt.

Was nun? :-)

Ciao
Thorsten
Anzeige
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 10:53:20
Anton
Hallo Thorsten,

ich vermute weil ich die TXT im Editor überarbeitet habe. Irgendwas stimmt nicht, denn wenn ich nun jetzt die richtigen umgewandelten Dateien einlese, kommt das bei mir raus. Bei mir geht das nicht, aber ich kann die die PDF und die TXT mit den Daten nicht schicken.

----- Hier Excel ------

Userbild

----- Hier Outlook -----

Userbild


Und wenn ich die Email abschicke ohne diese zu verbessere, kommt dann eine Unzustellbar Nachricht zurück.

Danke für die Hilfe.

VG Anton
Anzeige
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 11:19:05
Anton
Hallo Thorsten,

jetzt nochmal... habe bei der Excel Tabelle eine Textbox hinzugefügt... das "Simuliert" Outlook.
Genau hier siehst du wo das Problem liegt.
Habe mich selbst verwirrt. In die Zelle wird die Email Adresse richtig geschrieben, aber von der Zelle in die TextBox (Outlook) nicht mehr.

https://www.herber.de/bbs/user/163820.xlsm
https://www.herber.de/bbs/user/163747.txt

Danke nochmal.

VG Anton
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 11:57:14
Oberschlumpf
Hi Anton,

ja, danke, die neue Bsp-Datei zeigt auch mir das Problem.
So konnte ich den Code mit F8 schrittweise durchlaufen und hab auch die Zeile gefunden, in der die Textbox die fehlerhafte Mailadresse erhält.

a) ICH weiß leider AUCH NICHT, wieso der Bindestrich bei Übergabe an Textbox "verschluckt" wird
b) trotzdem aber habe ich einen Workaround gefunden, damit es - nicht - zu diesem Fehler kommt

Bevor ich aber Genaueres zu b) schreibe, würd ich dir empfehlen, so Einiges in deinem Code umzuschreiben.
Ändere mindestens diese Codezeile... 
If UBound(aEmail) > 0 Then Cells(sZeile + Zeile, Spalte + 37 - 1).Value = aEmail(0): TextBox1.Text = aEmail(0) Else Cells(sZeile + Zeile, Spalte + 37 - 1).Value = sEmail:: TextBox1.Text = sEmail

...um in... 


If UBound(aEmail) > 0 Then

      Cells(sZeile + Zeile, Spalte + 37 - 1).Value = aEmail(0)

      TextBox1.Text = aEmail(0)

  Else

      Cells(sZeile + Zeile, Spalte + 37 - 1).Value = sEmail

      TextBox1.Text = sEmail

End If

Wie du wahrscheinlich schon selbst gesehen hast, ist der korrigierte Code viel übersichtlicher, als wenn du all den Code in nur 1 Zeile "quetscht" und die einzelnen Befehle nur durch : trennst, oder???
Außerdem....schau dir mal deine Zeile an - ziemlich am Ende sind da 2x : direkt hintereinander eingetragen = hier zwar kein Problem, aber unsauber ist es trotzdem!

So, nun zu "meinem b)"

änder in deinem Code diese Zeile... 


sEmail_nach = Mid(strZeile, iEmailPos1, 100)

...bitte so um... 


sEmail_nach = Mid(strZeile, iEmailPos1, 100)

    If Instr(sEmail_nach, "-") > 0 Then

        sEmail_nach = Replace(sEmail_nach, "-", "--")

    End If

....so wird aus jedem Inhalt von sEmail_nach, der 1 Bindestrich enthält = 2 Bindestriche direkt hintereinander.
Das hat dann bei Übergabe an die Textbox (oder nach Outlook) zur Folge, dass weiterhin 1 Bindestrich "verschluckt" wird, aber der 2. Bindestrich ist ja weiterhin an der richtigen Stelle vorhanden.

Na ja, wenn du sEmail_nach noch woanders verwendest, außer für das Zusammenfügen von sMail = sEmail_vor & sEmail_nach, dann musst du natürlich auch an den anderen Codestellen aufpassen, dass sEmail_nach richtig übergeben wird.

Hilfts denn?

Ciao
Thorsten
Anzeige
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 12:24:13
Anton
Hallo Thorsten,

vielen Dank für deine Mühe, ich werde den Code sobald es funktioniert säubern. Ich versuche mich gerade selbst mit meinem Code, diesen verdammten Bindestrich mit Instr zu finden, jedoch finden der Befehl "0" Bindestriche, suche ich nach einem Buchstabe zeigt es mir alle Positionen an. Es muss irgendwas mit, was auch immer zu tun haben.

--------- Email ist in Zeile 17 -------
Userbild

--------- Habe versucht es auch in einzelne Array Felder aufzusplitten, zeigen tut es mir alles auch in der Console ist der Bindestrich da ----------

Userbild

--------- Die Console zeigt mir an das es mit InStr keinen Bundestich finden kann --------------

Userbild

Habe dann versucht mit CHR$(45), ist ja der ASCII Code aber das findest es auch nicht. Es muss doch ein Zeichen sein.

Hast du eine Idee wie ich mir die Zeichen mit einer For Schleife als Charakter anzeigen kann?

Das ist zum verrückt werden, wenn man nicht weiss woran das liegt :-)

Vielen Dank Torsten für die Unterstützung.

VG Anton
Anzeige
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 14:38:49
Hardy R
Hallo Anton,

wenn ich mit Code() deinen Bindestrich darstellen lasse, erhalte ich als Ergebnis 173 und nicht 45 für den Bindestrich der Tastatur.
Vielleicht hilft es ja nach diesem zu suchen und zu ersetzen.

MfG
Hardy R
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 14:46:04
Anton
Wow Hallo Hardy R,,

das war meine Rettung ich kann die Bindestriche jetzt ersetzten. Wie kommst du auf die Zahl 173, habe in der ASCII Tabelle geschaut da steht der Minusstrich 45 und der Bindestrich 150, also auf 173 wäre ich jetzt nicht gekommen, aber damit kann ich vielleicht ein wenig tricksen.

Ich danke euch allen für eure super Hilfe.

VG Anton
Anzeige
AW: Bindestriche verschwinden von Email Adresse
27.10.2023 06:54:21
Hardy R
Hallo Anton,

habe dein Textfile eingelesen und alles andere bei der Email gelöscht. wenn du jetzt in der Nachbarzelle mit 
=Code(Zelle)
abfragst, kommst du auf das Zeichen

MfG
HardyR
AW: Bindestriche verschwinden von Email Adresse
27.10.2023 07:30:12
Anton
Guten Morgen Handy R,

danke dir für die Lösung, das Programm funktioniert Einwand frei nun :-)

Vielen Dank an alle.

VG Anton
ok, hätte ja klappen können...owT
26.10.2023 11:15:55
Oberschlumpf
AW: Bindestriche verschwinden von Email Adresse
26.10.2023 08:50:28
Anton
Hallo bigmayo,

vielen Dank für deine Antwort.

Das heißt ich kann im es nicht anders Lösen, die PDF wird von unserem Programm AX erstellt, daher nur reiner Text und keine Grafik.
Mhm Schade habe mich rießig gefreut das der Code so wunderbar funktioniert hatte. Leider ist mir nicht bekannt wie ich selbst eine PDF auszulesen könnte ohne ein Hilfetool zu benutzen.

Ich danke dir und wünsche dir noch einen schönen Tag.

VG Anton
Anzeige

Links zu Excel-Dialogen

Frame Label TextBox

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige