"Special Character"

[Fennek]

Hallo,

die Formel in A1

Code:

=UNIZEICHEN(77824)

ergibt das erste von ca. 1.000 Alt-Ägyptischen Hieroglyphen.

Wie kann man diesen UniCode-Wert mit VBA auslesen?

Mein Versuch:

Code:

Sub Read_Unicode()
Dim UC1 As Long, UC2 As Long, ll As Integer, Tx As String

Tx = Cells(2, 2)
ll = Len(Tx)
UC1 = AscW(Left(Tx, 1))
UC2 = AscW(Right(Tx, 1))

Debug.Print ll, UC1, UC2
End Sub

ergibt     -10228        -9216 


Danke und

mfg

[RPP63]

Moin!
Das naheliegendste dürfte folgendes sein:

PHP-Code:

?WorksheetFunction.Unicode(Cells(2, 2)) 


Gruß Ralf

[Fennek]

Hallo Ralf,

die Antwort ist smart.

Meine Überlegung war, ob es auch in Word möglich ist, die Umschreibung in Latein, z.B. ein "n" einzugeben und dann die entsprechende Hieroglype ausgeben kann. Die Worksheet.Function würde das für Excel leisten und mit copy/paste ist eine Übertragung nach Word möglich.

Wenn es gelingen würde die Hieroglyphe mit ChrW zusammenzusetzen, wäre es in Word flexibler.

Danke, aber es gibt noch ein paar Schritte.

mfg

[maninweb]

Hallo,

beispielhaft, geht sowas auch mit API. Dafür müsst Du dann die UTF8-Hex-Kodierung (Beispiel) kennen.
Ggf. kann man ja noch einen Algo schreiben, der die Dezimalzahlen entsprechend umwandelt.
Vielleicht kannst ja darauf aufbauen.

Code:

Option Explicit

Private Declare PtrSafe Function apiMultiByteToWideChar Lib "kernel32" _
        Alias "MultiByteToWideChar" (ByVal CodePage As Long, _
                                    ByVal dwFlags As Long, _
                                    ByVal lpMultiByteStr As LongPtr, _
                                    ByVal cchMultiByte As Long, _
                                    ByVal lpWideCharStr As LongPtr, _
                                    ByVal cchWideChar As Long) As Long

Public Function UTF8WriteCharacter(Code As String) As String
 
  Dim c  As Long
  Dim n  As Long
  Dim r  As String
  Dim s  As String
  Dim b() As Byte
 
' Validate...
 
  If Not Len(Code) <> 8 Then
   
'  Count...
   
    c = Len(Code) / 2 - 1
   
'  Resize...
   
    ReDim b(0 To c)
   
'  Bytes...
   
    For n = LBound(b) To UBound(b)
     
      b(n) = CLng("&H" & Mid(Code, 2 * n + 1, 2))
     
    Next
   
'  Encode...
   
    n = 0
    n = apiMultiByteToWideChar(65001, 0&, VarPtr(b(0)), c + 1, 0&, 0&)
    s = String(n, 0)
    n = apiMultiByteToWideChar(65001, 0&, VarPtr(b(0)), c + 1, StrPtr(s), n)
    r = Left(s, n)
   
  Else
   
    r = ""
   
  End If
 
' Result...

  UTF8WriteCharacter = r
 
End Function

Public Sub Test()
 
  Cells(1, 8).Value = UTF8WriteCharacter("F0938080")
  Cells(1, 9).Value = UTF8WriteCharacter("F0A08098")
 
End Sub

Gruß

[Fennek]

Hallo Mourad,

vielen Dank

in der Liste steht das Zeichen mit &H13000, also dezimal 77824.

Ich dachte eigentlich, dass ich Formate umrechnen könnte, aber wie entsteht

                       UTF8WriteCharacter("F0938080")

Powershell liefert:

Code:

$Hx = 'F0938080'

[convert]::ToInt32($Hx,16)

# Ergebnis: -258768768

mfg

Soweit bin ich jetzt:

Code:

Sub Read_Unicode()
Dim UC1 As Long, UC2 As Long, ll As Integer, Tx As String

Tx = Cells(2, 2)            '77824  &H13000
ll = Len(Tx)
UC1 = AscW(Left(Tx, 1))    '-10228
UC2 = AscW(Right(Tx, 1))    '-9216

Debug.Print ll, UC1, UC2
Range("U2") = ChrW(UC1) & ChrW(UC2)
End Sub

[maninweb]

Hallo,

U+13000 entspricht in der UTF-8-Kodierung: 0xF0 0x93 0x80 0x80. Das Konvertieren von F0938080 in 77824 und vice-versa ist wohl nicht ganz so simpel.
Hier https://rosettacode.org/wiki/UTF-8_encode_and_decode findest Du weiter unten auch eine VBA-Prozedur, die ich aber nicht ausprobiert habe.

Hinweis: UTF8WriteCharacter() tut's ja erstmal nur für die Unicode-Hex-Codes der Länge 8 und müsste ggf. angepasst werden.

Gruß

[Fennek]

Hallo,

ich hoffe, dass ich es geschafft habe:

Mit der Übergabe einer Dezimal-Zahl zwischen 0-1080 wird die entsprechende Hieroglyphe ausgegeben. Es wird kein Excel, sondern "nur" VBA für die Bit-Berechenung und die API von Mourad verwendet.

Die unterste "Sub Einfuegen" gibt im Moment 400 Zeichen aus. Mit dem Wissen der Umschreibung im Latin-Alphabet können später auch einzelne Zeichen an der Stelle des Cursors geschrieben werden.

Danke

mfg

[snb]

Vielleicht könntest du etwas ausrichten mit:

Code:

Sub M_snb()
  ThisDocument.Range.InsertSymbol 31000, "Arial MS unicode", True
End Sub

Word 2010 ist beschränkt auf 32126, neuere Version vielleicht anders.

[Fennek]

@snb

Danke

Auch in Office 2019 besteht die Grenze signierten 2 Bytes.

Code:

Sub M_snb1()
  ThisDocument.Range.InsertSymbol 77824, "Segoe UI Historic", True
End Sub

Ging leider nicht, auch mit der Ergänzung "unicode"

mfg