Office: Funktion schneidet Memofeld ab

Hallo zusammen,

ich arbeite mit einem Makro, das schon vor Jahren entwickelt wurde. Es überführt Daten in eine Tabelle, die zur Pflege des Webshops gebraucht wird. In der Ursprungstabelle sind Memofelder, diese werden im Makro irgendwie bei 255 Zeichen abgeschnitten. Das Zielfeld sollte im Makro also ebenfalls ein Memofeld sein, damit auch Texte über 255 Zeichen nicht abgeschitten werden...

Weiss jemand Rat! Danke Flo

Hier das Original

Public Function ListefürInternet()
DoCmd.OpenQuery ("Internet Abfrage")
CloneTable "Internet Temp", "Internet Liste", True, True
DoCmd.DeleteObject acTable, "Internet Temp"
End Function

Public Sub CloneTable(Quelltabelle As String, Zieltabelle As String, Memofelder As Boolean, Überschreiben As Boolean)
'Dupliziert eine Tabelle der aktuellen Datenbank

'Parameter:
'
'Quelltabelle | Tabelle in der aktuellen Datenbank, die dupliziert werden soll
'
'Zieltabelle | Name der Kopie von Quelltabelle in der aktuellen Datenbank
'
'Memofelder | wenn TRUE, werden Memofelder in String(255) gewandelt.
' | Zeilenwechsel wird zu Leerzeichen gewandelt.
' | Wird nach 255. Byte abgeschnitten.
'
'Überschreiben | wenn FALSE erfolgt Abfrage, falls Zieltabelle schon besteht.
' | wenn TRUE wird Zieltabelle ohne Abfrage überschrieben

Dim dbs As Database
Dim q_tdf As TableDef, q_fld As Field 'Struktur Quelltabelle
Dim z_tdf As TableDef, z_fld As Field 'Struktur Zieltabelle
Dim q_rec As Recordset, z_rec As Recordset 'Recordsets Quelle und Ziel
Dim var As Variant

Dim f As Integer

' Verweis auf aktuelle Datenbank holen.
Set dbs = CurrentDb


' TableDef-Objektvariable zurückgeben, die auf die neue Tabelle zeigt.
Set z_tdf = dbs.CreateTableDef(Zieltabelle)

' TableDef-Objektvariable zurückgeben, die auf die zu kopierende Tabelle zeigt.
Set q_tdf = dbs.TableDefs(Quelltabelle)

' Neues Feld in Zieltabelle definieren.
For f = 0 To q_tdf.Fields.Count - 1
Set q_fld = q_tdf.Fields(f)
Set z_fld = z_tdf.CreateField(q_fld.Name, q_fld.Type, q_fld.Size)

' Memofelder in String(255) wandeln
'If Memofelder = True Then
'If q_fld.Type = dbMemo Then z_fld.Type = dbText: z_fld.Size = 500
'End If

' Feld an Zieltabelle anfügen.
z_tdf.Fields.Append z_fld
z_tdf.Fields.Refresh
Next f

'Struktur Zieltabelle an TableDefs-Auflistung der Datenbank anfügen.
On Error GoTo Errorhandler
' Wenn Zieltabelle schon existiert, wird Error 3010 ausgelöst -> Errorhandler
dbs.TableDefs.Append z_tdf
On Error GoTo 0
dbs.TableDefs.Refresh

'Daten von Quelle nach Ziel kopieren
Set q_rec = dbs.OpenRecordset(Quelltabelle, dbOpenDynaset)
Set z_rec = dbs.OpenRecordset(Zieltabelle, dbOpenDynaset)
q_rec.MoveLast: q_rec.MoveFirst
While Not q_rec.EOF
z_rec.AddNew
For f = 0 To q_rec.Fields.Count - 1
var = q_rec.Fields(f)
If q_rec.Fields(f).Type = dbMemo Or q_rec.Fields(f).Type = dbText Then
While InStr(var, Chr$(13)) <> 0
var = Mid$(var, 1, InStr(var, Chr$(13)) - 1) + " " + Mid$(var, InStr(var, Chr$(13)) + 2, 255)
Wend
End If
If var = "" Then var = Null
z_rec.Fields(f) = var
Next f
z_rec.Update
q_rec.MoveNext
Wend

'Debug.Print liste.RecordCount


Set dbs = Nothing

Exit Sub

Errorhandler:

Select Case Err.Number
Case 3010 'Die Datei ist schon vorhanden
If Überschreiben = True Then
dbs.TableDefs.Delete Zieltabelle
dbs.TableDefs.Refresh
Resume
Else
If MsgBox("Die Zieltabelle '" + Zieltabelle + "' existiert schon." + _
Chr$(13) + "Überschreiben?", vbOKCancel + vbDefaultButton2, "Tabelle kopieren ...") = vbCancel Then
Exit Sub
Else
dbs.TableDefs.Delete Zieltabelle
dbs.TableDefs.Refresh
Resume
End If



End If
End Select
End Sub

 

Hallo,

offenbar war das Makro für den Fall gedacht, dass in Memofeldern oder Textfeldern nicht mehr als 255 Zeichen stehen dürfen. Du hast dann zwar die Spezialbehandlung bei der Felddefinition für Memofelder als Kommentar deaktiviert, nur hast Du an der Stelle, an der dann tatsächlich die Daten kopiert werden, die Beschränkung auf 255 Zeichen beibehalten:

Code:

While InStr(var, Chr$(13)) <> 0
  var = Mid$(var, 1, InStr(var, Chr$(13)) - 1) + " " + Mid$(var, InStr(var, Chr$(13)) + 2, 255)
Wend

Genau dieser 255er am Ende der 2.Zeile des vorigen Codes bewirkt diese Beschränkung. Wenn Du das davorstehende Komma samt 255 entfernst, müsste das Problem beseitigt sein.

Code:

While InStr(var, Chr$(13)) <> 0
  var = Mid$(var, 1, InStr(var, Chr$(13)) - 1) + " " + Mid$(var, InStr(var, Chr$(13)) + 2)
Wend

Wenn Du nicht eine total vorsintflutliche ACCESS-Version hast, wäre es am besten, gleich diese 3 vorherigen Zeilen durch folgende Zeile zu ersetzen:

Code:

var = Replace(var, vbCrLf, " ")