Hallo Wissende,
Unicode umfasst 65536 Zeichen, je nach gewählter Schriftart zeigt Excel bei dem Code:
For Z = 0 to 65535
Cells(z+1,1)=ChrW(Z)
next Z
entweder das Zeichen an, oder wenn das nicht geht ein kleines Quadrat.
Ich mutmaße, das ist in VB gleich, wenn ihr das in eine Tetbox schreiben läßt.
Nun sind das recht viele Quadrate und ich würde gerne alle Zeilen mt diesen Quadraten liquidieren.
Dummerweise geht das nicht mit =AscW(Zelle) diese Quadrate zu erkennen.
Bis heute fand ich, auch mit Nachfrage in Excelforen, keine Möglichkeit, die Zellen mit Quadraten zu entfernen.
Jetzt fand ich aber einen Dreh um sie einigermaßen zu erkennen.
Ich habe Vba-Code zusammengebastelt, der (in Spalte A sind alle 65536 Zeichen untereinander aufgelistet) jede Zelle durchgeht, diese als Bild kopiert, in ein Exceldiagramm als Bild einfügt und dann dieses Bild als .JPG abspeichert.
Ohne den Umweg über ein Diagramm kenne ich keinen Weg eine Zelle als Bild abzuspeichern, nur da gibt es eine Export-Function.
Mit PutInClipboard kann ich nur Text als Text in die Zwischenablage schaufeln, nicht als Bild des Textes.
Dann lese ich die Dateilänge (FileLen) der Bildatei aus undsiehe da, die Bilddateien der Zellen die nur ein Quadrat zeigen haben immer die gleiche Größe.
Abgesehen von wenigen lästigen Ausreißern haben Bilder von Zellen die ausdruckbare Zeichen enthalten eine unterschiedliche Dateigröße.
Das Problem ist nun, der Code dauert mehrere Stunden bei 65536 Zellen 
und sowas ist absolut nix für meine Ungeduld *rumhippel* 
Dann probierte ich etwas anderes, in einer Userform habe ich eine Textbox, in ihr ist Autosize auf True gestellt, dorthinein schreibe ich nacheinander alle 65536 Zeichen aus Unicode und ermittle Widht der Textbox.
Leider haben da vielzuviel Zeichen die gleiche Breite wie ein Quadrat:frowning:
**Was ich also suche ist eine schnelle Funktion
Function IsPrintable(Chraracter as Long, Font as String)
’ das was hier fehlt suche ich
end Function**
Ich freue mich über jede Idee, anderen Ansatz.
Nachfolgend der „langsame“ Code.
Und Nepumuks (ein Excel-Vba-Profi) Code war für etwas anderes bestimmt, ich habe ihn reichlich zerpflückt, beim Testen kriegte ich dann aber massivste Abstürze und es hat teilweise mein Excel zerschossen, an dieser Stelle Dank an die Excelprogrammierer, die Fehlermeldung „Datei fehlt“ finde ich schon super Klasse, da kann ich sofort ablesen welche und wo, in den Verweisen, in den Add-Ins, in der Personl.xls, sonstwo *grummel*
Aus diesem Grund ist mein Code schon vom Aufbau her langsam, aber funktioniert ohne Abstürze, Tuning kommt später.
Ist schon klar, daß 65536 mal ein Blatt anlegen und löschen ein wenig bremst *gg*
Der Absturz kam meist, aber Excel ist da variantenreich, bei:
ActiveSheet.Pictures.Paste Link:=True
und logo, wenn schon denn schon, Pictures wird nicht in der Hilfe erklärt:frowning:
Danke ^ Gruß
Reinhard
Option Explicit
Public B(65535, 1) As String
'
Sub test()
Dim Z As Long
ActiveSheet.UsedRange.ClearContents
Application.ScreenUpdating = False
Call Zeichen
For Z = 1 To 65536
Application.StatusBar = Right("00000" & Z, 5) & " / 65536 Zellen"
Call prcExportTablecopy3(Worksheets("Tabelle1").Cells(Z, 1))
Next Z
ActiveSheet.Range("A1:B65536") = B
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub
'
Public Sub prcExportTablecopy3(Zelle As Range)
'Code ist von Nepumuk. 2006
Dim objChart As Chart
Dim objChartObject As ChartObject
Dim objShape As Shape
Application.ScreenUpdating = False
Zelle.Copy
ActiveSheet.Pictures.Paste Link:=True
'Application.CommandBars("Picture").Visible = False
Application.CutCopyMode = False
Set objShape = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
objShape.CopyPicture Appearance:=2, Format:=-4147
Set objChart = Charts.Add
Set objChartObject = objChart.ChartObjects.Add(0, 0, \_
objShape.Width, objShape.Height)
With objChartObject.Chart
.Paste
.Export FileName:="C:\Bilder\Bild.jpg", \_
FilterName:="JPG", Interactive:=False
End With
'Zelle.Offset(0, 1) = FileLen("C:\Bilder\Bild.jpg")
B(Zelle.Row - 1, 1) = FileLen("C:\Bilder\Bild.jpg")
Kill "C:\Bilder\Bild.jpg"
Application.DisplayAlerts = False
objChart.Delete
objShape.Delete
Application.DisplayAlerts = True
Set objChart = Nothing
Set objChartObject = Nothing
Set objShape = Nothing
End Sub
'
Sub Zeichen()
Dim Z As Long
Application.ScreenUpdating = False
Application.StatusBar = "Bitte warten, Initialisierung läuft..."
For Z = 0 To 65535
'Application.StatusBar = Right("00000" & Z, 5) & " / 65536 Zellen"
B(Z, 0) = ChrW(Z) & ChrW(Z) & ChrW(Z)
Next Z
ActiveSheet.Range("A1:B65536") = B
Application.ScreenUpdating = True
Application.StatusBar = ""
End Sub