Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1112to1116
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
Text in einem Excel-Textfeld verändern
Sibylle
Guten Abend,
ein mehrzeiliger Text der in einem Excel-Textfeld steht, soll "verfremdet" , verschlüsselt werden, indem der Zeichencode verändert wird und in einem 2. Textfeld gespeichert wird.
Ich stehe mit VBA so ziemlich am Anfang und hoffe auf Vorschläge oder auf eine Lösung.
Wer kann helfen?
Gruß
Sibylle

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Text in einem Excel-Textfeld verändern
08.11.2009 19:36:34
Josef
Hallo Sibylle,
die Textfelder heissen "TextFeld 1", bzw. "Textfeld 2".
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
'original by nepumuk
Private aDecTab(0 To 255) As String
Private Const sEncTab As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

Sub verschluesseln()
  With Sheets("Tabelle1")
    .Shapes("Textfeld 2").TextFrame.Characters.Text = EncodeStr64(.Shapes("Textfeld 1").TextFrame.Characters.Text)
    .Shapes("Textfeld 1").TextFrame.Characters.Text = ""
  End With
End Sub

Sub entschluesseln()
  With Sheets("Tabelle1")
    .Shapes("Textfeld 1").TextFrame.Characters.Text = DecodeStr64(.Shapes("Textfeld 2").TextFrame.Characters.Text)
    .Shapes("Textfeld 2").TextFrame.Characters.Text = ""
  End With
End Sub

Public Function EncodeStr64(sInput As String) As String
  Dim sOutput As String, sLast As String
  Dim b(0 To 2) As String
  Dim j As Byte
  Dim i As Integer, nLen As Integer, nQuants As Integer
  Dim iIndex As Integer
  nLen = Len(sInput)
  nQuants = nLen \ 3
  sOutput = ""
  iIndex = 0
  For i = 0 To nQuants - 1
    For j = 0 To 2
      b(j) = Asc(Mid(sInput, (i * 3) + j + 1, 1))
    Next
    sOutput = sOutput & EncodeQuantum(b)
    iIndex = iIndex + 4
  Next
  Select Case nLen Mod 3
    Case 0
      sLast = ""
    Case 1
      b(0) = Asc(Mid(sInput, nLen, 1))
      b(1) = 0
      b(2) = 0
      sLast = EncodeQuantum(b)
      sLast = Left(sLast, 2) & "=="
    Case 2
      b(0) = Asc(Mid(sInput, nLen - 1, 1))
      b(1) = Asc(Mid(sInput, nLen, 1))
      b(2) = 0
      sLast = EncodeQuantum(b)
      sLast = Left(sLast, 3) & "="
  End Select
  EncodeStr64 = sOutput & sLast
End Function

Public Function DecodeStr64(sEncoded As String) As String
  Dim sDecoded As String
  Dim d(0 To 3) As Integer
  Dim C As Integer
  Dim di As Integer
  Dim i As Integer
  Dim nLen As Integer
  Dim iIndex As Integer
  nLen = Len(sEncoded)
  sDecoded = ""
  iIndex = 0
  di = 0
  Call MakeDecTab
  For i = 1 To Len(sEncoded)
    C = Cbyte(Asc(Mid(sEncoded, i, 1)))
    C = aDecTab(C)
    If C >= 0 Then
      d(di) = C
      di = di + 1
      If di = 4 Then
        sDecoded = sDecoded & DecodeQuantum(d)
        iIndex = iIndex + 3
        If d(3) = 64 Then
          sDecoded = Left(sDecoded, Len(sDecoded) - 1)
          iIndex = iIndex - 1
        End If
        If d(2) = 64 Then
          sDecoded = Left(sDecoded, Len(sDecoded) - 1)
          iIndex = iIndex - 1
        End If
        di = 0
      End If
    End If
  Next
  DecodeStr64 = sDecoded
End Function

Private Function EncodeQuantum(b() As String) As String
  Dim sOutput As String
  Dim C As Integer
  sOutput = ""
  C = SHR2(b(0)) And &H3F
  sOutput = sOutput & Mid(sEncTab, C + 1, 1)
  C = SHL4(b(0) And &H3) Or (SHR4(b(1)) And &HF)
  sOutput = sOutput & Mid(sEncTab, C + 1, 1)
  C = SHL2(b(1) And &HF) Or (SHR6(b(2)) And &H3)
  sOutput = sOutput & Mid(sEncTab, C + 1, 1)
  C = b(2) And &H3F
  sOutput = sOutput & Mid(sEncTab, C + 1, 1)
  EncodeQuantum = sOutput
End Function

Private Function DecodeQuantum(d() As Integer) As String
  Dim sOutput As String
  Dim C As Integer
  sOutput = ""
  C = SHL2(d(0)) Or (SHR4(d(1)) And &H3)
  sOutput = sOutput & Chr(C)
  C = SHL4(d(1) And &HF) Or (SHR2(d(2)) And &HF)
  sOutput = sOutput & Chr(C)
  C = SHL6(d(2) And &H3) Or d(3)
  sOutput = sOutput & Chr(C)
  DecodeQuantum = sOutput
End Function

Private Function MakeDecTab()
  Dim t As Integer
  Dim C As Integer
  For C = 0 To 255
    aDecTab(C) = -1
  Next
  t = 0
  For C = Asc("A") To Asc("Z")
    aDecTab(C) = t
    t = t + 1
  Next
  For C = Asc("a") To Asc("z")
    aDecTab(C) = t
    t = t + 1
  Next
  For C = Asc("0") To Asc("9")
    aDecTab(C) = t
    t = t + 1
  Next
  C = Asc("+")
  aDecTab(C) = t
  t = t + 1
  C = Asc("/")
  aDecTab(C) = t
  t = t + 1
  C = Asc("=")
  aDecTab(C) = t
End Function

Public Function SHL2(ByVal bytValue)
  SHL2 = (bytValue * &H4) And &HFF
End Function

Public Function SHL4(ByVal bytValue)
  SHL4 = (bytValue * &H10) And &HFF
End Function

Public Function SHL6(ByVal bytValue)
  SHL6 = (bytValue * &H40) And &HFF
End Function

Public Function SHR2(ByVal bytValue)
  SHR2 = bytValue \ &H4
End Function

Public Function SHR4(ByVal bytValue)
  SHR4 = bytValue \ &H10
End Function

Public Function SHR6(ByVal bytValue)
  SHR6 = bytValue \ &H40
End Function

Gruß Sepp

Anzeige
AW: Text in einem Excel-Textfeld verändern
08.11.2009 19:45:04
Sibylle
Hallo Sepp,
das Programm funktioniert super. Vielen Dank dafür.
Jetzt muss es nur noch verstanden werden, eine wirklich harte Nuss.
Einen schönen Abend.
Gruß
Sibylle
@Sepp: Könntest Du den Code mal...
09.11.2009 02:13:52
Jens
Hi Sepp
... genauer erläutern?
Danke Dir.
Gruß Jens
AW: @Sepp: Könntest Du den Code mal...
09.11.2009 17:27:50
Josef
Hallo Jens,
was soll ich da erklären?
Erstens ist der Code nicht von mir und zweitens ist das so spannent wie Farbe beim trocknen zusehen.
Gehe den Code im Einzelschritt durch und du siehst was passiert.
Im Netz findest du hunderte Seiten die sich mit Verschlüsselungsverfahren beschäftigen.
Gruß Sepp

Anzeige

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige