AW: Offset im Kombinationsfeld?
28.01.2009 13:44:09
1.Merlin
Der Vollständigkeit halber hier noch das Klick-Ereignis:
Public Type TransferString
Value As String
FontName As String
FontStyle As String
Size As Integer
SuperScript As Boolean
SubScript As Boolean
End Type
Public Type TransferValue
Length As Integer
Value As String
End Type
Private Sub CmbBxGlasses_Click()
Application.ScreenUpdating = False
ActiveSheet.Unprotect
On Error GoTo ErrHandler
Dim Adresse As String
With Me.CmbBxGlasses
Adresse = Replace(.List(.ListIndex, 3), "$", "")
End With
Sheets("All-Reports").Select
ActiveSheet.Range(Adresse).Select
Dim TV As TransferValue
With ActiveCell
TV.Length = Len(.Value)
TV.Value = .Value
End With
ReDim TS(TV.Length) As TransferString
Dim inti As Integer
For inti = 0 To TV.Length - 1
TS(inti).Value = Mid(ActiveCell.Value, inti + 1, 1)
With ActiveCell.Characters(Start:=inti + 1, Length:=1).Font
TS(inti).FontName = .Name
TS(inti).FontStyle = .FontStyle
TS(inti).Size = .Size
TS(inti).SuperScript = .SuperScript
TS(inti).SubScript = .SubScript
End With
Next inti
Application.Goto Reference:="Eintrag"
ActiveCell.Value = TV.Value
For inti = 0 To TV.Length - 1
With ActiveCell.Characters(Start:=inti + 1, Length:=1).Font
.Name = TS(inti).FontName
' .FontStyle = TS(inti).FontStyle
' .Size = TS(inti).Size
.SuperScript = TS(inti).SuperScript
.SubScript = TS(inti).SubScript
End With
Next inti
Err.Clear
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
On Error Resume Next
Application.ScreenUpdating = True
MsgBox Err.Description, vbCritical, "Konnte Zelle 'Eintrag' nicht formatieren"
Application.Goto Reference:="EintragGlas"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Err.Clear
Exit Sub
End Sub