Zurück zur Homepage

Unicodezeichen in eine Zelle einfügen

Beispieldatei (Unicodedialog.zip 14 kB)

Unicodezeichen lassen sich in einer Zelle eines Tabellenblattes darstellen. Dazu muss ein Unicodezeichensatz wie der von Microsoft Office "Arial Unicode MS" installiert sein.

Leider lassen sich die Zeichen nur über den Umweg Zwischenablage einfügen, eine Lösung wie beispielsweise die mit Alt und der Eingabe von 065 auf der numerischen Tastatur gibt es nicht.

Mit ein paar  Prozeduren kann man dem abhelfen. Folgender Code fügt dem Kontextmenü >Cell< zwei Menüpunkte hinzu. In den zwei zugehörigen Prozeduren kann man den Zeichencode als Hex- oder als Dezimalstring eingeben, der fertige Unicodestring wird in die Aktive Zelle eingefügt.

Damit diese Menüpunkte auch wieder verschwinden, werden sie in der Ereignisprozedur >Workbook_BeforeClose< entfernt und in der >Workbook_Open< neu gesetzt. Diese Prozeduren werden in das Klassenmodul >DieseArbeitsmappe< eingefügt. Der Rest kommt in ein allgemeines Modul.

 

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim objCommandBarButton As CommandBarButton
    
On Error Resume Next
    
With Application.CommandBars("Cell")
      
For Each objCommandBarButton In .Controls
         
With objCommandBarButton
            
If .Tag = "Unicodedialog Dezimal" Or _
               .Tag = 
"Unicodedialog Hex" Then .Delete
         
End With
      
Next
   
End With
End Sub


Private Sub Workbook_Open()
   KontextmenüErgänzen
End Sub

' In ein Modul

Option Explicit
Private Declare Function MessageBox Lib "user32" _
    
Alias "MessageBoxW" ( _
    
ByVal hwnd As Long, _
    
ByVal lpText As Long, _
    
ByVal lpCaption As Long, _
    
ByVal wType As Long _
    ) 
As Long

Public Sub KontextmenüErgänzen()
Dim objCommandBarButton As CommandBarButton
    
On Error Resume Next
    
With CommandBars("Cell")
      
For Each objCommandBarButton In .Controls
         
With objCommandBarButton
            
If .Tag = "Unicodedialog Dezimal" Or _
               .Tag = 
"Unicodedialog Hex" Then .Delete
         
End With
      
Next
      
Set objCommandBarButton = .Controls.Add(msoControlButton)
      
With objCommandBarButton
         .Caption = 
"Unicodedialog Dezimal"
         .OnAction = 
"UnicodedialogDez"
         .Tag = 
"Unicodedialog Dezimal"
         .Move before:=1
      
End With
      
Set objCommandBarButton = .Controls.Add(msoControlButton)
      
With objCommandBarButton
         .Caption = 
"Unicodedialog Hex"
         .OnAction = 
"UnicodedialogHez"
         .Tag = 
"Unicodedialog Hex"
         .Move before:=1
      
End With
    
End With
End Sub

Public Sub UnicodedialogDez()
Dim strRet        As String
Dim astrText()    As String
Dim i             As Long
   
On Error Resume Next
   strRet = InputBox( _
      
"Geben Sie die Buchstaben als Zahlencode ein," & _
      vbCrLf & _
      
"einzelne Buchstaben bitte durch Komma (,) trennen")
   astrText = Split(strRet, 
",")
   strRet = 
""
   
For i = 0 To UBound(astrText)
      strRet = strRet & ChrW(
CLng(astrText(i)))
   
Next
   Application.EnableEvents = 
False
   
With ActiveCell
      
Select Case MessageBox(0, StrPtr( _
         
"Wollen Sie die folgenden Zeichen an den Text anfügen (Ja)," _
         & vbCrLf & _
         
"oder wollen Sie den Zellinhalt ersetzen (Nein)?" _
         & vbCrLf & vbCrLf _
         & strRet), _
         StrPtr(
"Unicodezeichen"), _
         vbYesNoCancel)
         
         
Case vbYes
            .Value = .Value & strRet
            .Font.Name = 
"Arial Unicode MS"
         
Case vbNo
            .Value = strRet
            .Font.Name = 
"Arial Unicode MS"
         
Case Else
      
End Select
   
End With
   Application.EnableEvents = 
True
End Sub

Public Sub UnicodedialogHez()
Dim strRet        As String
Dim astrText()    As String
Dim i             As Long
   
On Error Resume Next
   strRet = InputBox( _
      
"Geben Sie die Buchstaben als Hexcode ein," & _
      vbCrLf & _
      
"einzelne Buchstaben bitte durch Komma (,) trennen")
   astrText = Split(strRet, 
",")
   strRet = 
""
   
For i = 0 To UBound(astrText)
      strRet = strRet & ChrW(
"&H" & astrText(i))
   
Next
   Application.EnableEvents = 
False
   
With ActiveCell
      
Select Case MessageBox(0, StrPtr( _
         
"Wollen Sie die folgenden Zeichen an den Text anfügen (Ja)," _
         & vbCrLf & _
         
"oder wollen Sie den Zellinhalt ersetzen (Nein)?" _
         & vbCrLf & vbCrLf _
         & strRet), _
         StrPtr(
"Unicodezeichen"), _
         vbYesNoCancel)
         
         
Case vbYes
            .Value = .Value & strRet
            .Font.Name = 
"Arial Unicode MS"
         
Case vbNo
            .Value = strRet
            .Font.Name = 
"Arial Unicode MS"
         
Case Else
      
End Select
   
End With
   Application.EnableEvents = 
True
End Sub