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