Registriert seit: 14.02.2016
Version(en): 2010-2016
Hallo Leute,
ich habe hier im Forum einen Code gefunden, den ich super gut gebrauchen könnte.
http://www.clever-excel-forum.de/thread-2271.html
Code: Option Explicit
Dim lngAZ As Long, lngStart As Long
Dim strCM As String
Private Sub TextBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
lngStart = TextBox1.SelStart
End Sub
Private Sub TextBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
strCM = Data.GetText
lngAZ = Len(strCM)
If Shift <> 2 Then
TextBox1.Text = Application.Replace(TextBox1.Text, lngStart + 1, lngAZ, String(lngAZ, " "))
End If
With TextBox2
If Len(TextBox1.Text) > Len(.Text) Then
.Text = .Text & String(Len(TextBox1.Text) - Len(.Text), " ")
End If
.Text = Application.Replace(.Text, lngStart + 1, lngAZ, strCM)
End With
End Sub
Nun habe ich folgendes Problem. Alles was unter der TextBox2 steht, möchte ich auch entsprechend angepaßt für die TextBoxen 3, 4, 5, und 6 auf meiner Userform gebrauchen. Also würde ich diesen Code gerne in eine Function reinpacken, wo er dann von der jeweiligen TextBox aufgerufen wird. Das Problem, dieser Code übersteigt meine Fähigkeiten und ich weiß weder, wie die Funktion mit den entprechenden Parameternübergaben aussieht noch der Funktionsaufruf selbst.
Registriert seit: 24.10.2015
Version(en): 2010
Hallo VBATartar,
in folgender Weise würde es gehen:
Private Sub TextBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
My_Before "Textbox2"
End Sub
Private Sub TextBox3_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
My_Before "Textbox3"
End Sub
Function My_Before(BoxString)
strCM = Data.GetText
lngAZ = Len(strCM)
If Shift <> 2 Then
TextBox1.Text = Application.Replace(TextBox1.Text, lngStart + 1, lngAZ, String(lngAZ, " "))
End If
With Me.Controls(BoxString)
If Len(TextBox1.Text) > Len(.Text) Then
.Text = .Text & String(Len(TextBox1.Text) - Len(.Text), " ")
End If
.Text = Application.Replace(.Text, lngStart + 1, lngAZ, strCM)
End With
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 14 - mit VBAHTML 12.6.0
Wenn Du die beiden zeilen auch noch in My_Before reinpacken willst, die beiden Variablen halt als Parameter dazuschreiben.
Gruß der AlteDresdner
Gruß der AlteDresdner (Win11, Off2021)
Registriert seit: 14.02.2016
Version(en): 2010-2016
@Hallo AlteDresdner, zunächst schon mal vielen Dank für deine Hilfe. Aber der Code funktioniert leider noch nicht richtig.
Derzeit sieht mein Code insgesamt folgendermaßen aus, hinzu kommt noch eine UserForm mit einigen Textboxen drauf (vgl. Initialisierungsprozeßes Userform_Initialize)
Code: Option Explicit
Dim lngAZ As Long, lngStart As Long
Dim strCM As String
Sub TextBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
lngStart = TextBox1.SelStart
End Sub
Private Sub TextBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
My_Before "Textbox2"
End Sub
Private Sub TextBox3_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
My_Before "Textbox3"
End Sub
Function My_Before(BoxString)
strCM = Data.GetText
lngAZ = Len(strCM)
If Shift <> 2 Then
TextBox1.Text = Application.Replace(TextBox1.Text, lngStart + 1, lngAZ, String(lngAZ, " "))
End If
With Me.Controls(BoxString)
If Len(TextBox1.Text) > Len(.Text) Then
.Text = .Text & String(Len(TextBox1.Text) - Len(.Text), " ")
End If
.Text = Application.Replace(.Text, lngStart + 1, lngAZ, strCM)
End With
End Function
Sub UserForm_Initialize()
Dim i As Integer
Application.WindowState = xlMaximized
With Me
.Height = Application.Height
.Width = Application.Width
End With
For i = 1 To 4
Me.Controls("TextBox" & i).Font.Name = "Courier New"
Me.Controls("TextBox" & i).Font.Size = 10
Me.Controls("TextBox" & i).BackStyle = fmBackStyleTransparent
Me.Controls("TextBox" & i).BorderStyle = fmBorderStyleSingle
Me.Controls("TextBox" & i).BackColor = &H8000000F
Me.Controls("TextBox" & i).DragBehavior = fmDragBehaviorEnabled
Me.Controls("TextBox" & i).Left = 0
Me.Controls("TextBox" & i).Height = 20
Me.Controls("TextBox" & i).Top = i * 30 - 20
Me.Controls("TextBox" & i).Width = Application.Width
Me.Controls("TextBox" & i).Visible = True
Next i
TextBox1.Text = "Dies ist das Clever-Excel Forum, da wird Dir gerne geholfen!"
TextBox1.Tag = TextBox1.Text
End Sub
Das Problem ist folgends, ziehe ich den Text aus der TextBox1 rüber in die TextBox2, oder 3 wird wie gewünscht die Funktion aufgerufen und bei
Code: strCM = Data.GetText
kommt dann die Fehlermeldung Variable nicht definiert.
Registriert seit: 24.10.2015
Version(en): 2010
Halle VBATartar,
da war ich wohl etwas unaufmerksam. Ergänze
Code: Function My_Before(BoxString,Data)
und gib den Paramer Data an alle Aufrufe von My_Before mit (z.B. MyBefore "Textbox2",Data). Dann sollte es wohl gehen.
Gruß der AlteDresdner
Gruß der AlteDresdner (Win11, Off2021)
Registriert seit: 24.05.2016
Version(en): 2007
Einbindung aller Parameter auch Cancel, Effect und Shift in den Funktionsaufruf für funktionierenden Programmablauf.
Code: Option Explicit
Dim lngAZ As Long, lngStart As Long
Dim strCM As String
Sub TextBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal shift As Integer)
lngStart = TextBox1.SelStart
End Sub
Private Sub TextBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal shift As Integer)
My_Before "TextBox2", Cancel, Data, Effect, shift
End Sub
Private Sub TextBox3_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal shift As Integer)
My_Before "TextBox3", Cancel, Data, Effect, shift
End Sub
Private Sub TextBox4_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal shift As Integer)
My_Before "TextBox4", Cancel, Data, Effect, shift
End Sub
Private Sub TextBox5_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal shift As Integer)
My_Before "TextBox5", Cancel, Data, Effect, shift
End Sub
Private Sub TextBox6_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal shift As Integer)
My_Before "TextBox6", Cancel, Data, Effect, shift
End Sub
Function My_Before(BoxString, Cancel, Data, Effect, shift)
Cancel = True
Effect = 1
strCM = Data.GetText
lngAZ = Len(strCM)
If shift <> 2 Then
TextBox1.Text = Application.Replace(TextBox1.Text, lngStart + 1, lngAZ, String(lngAZ, " "))
End If
With Me.Controls(BoxString)
If Len(TextBox1.Text) > Len(.Text) Then
.Text = .Text & String(Len(TextBox1.Text) - Len(.Text), " ")
End If
.Text = Application.Replace(.Text, lngStart + 1, lngAZ, strCM)
End With
End Function
Sub UserForm_Initialize()
Dim i As Integer, vbText As String
Application.WindowState = xlMaximized
With Me
.Height = Application.Height
.Width = Application.Width
End With
For i = 1 To 6
Me.Controls("TextBox" & i).Font.Name = "Courier New"
Me.Controls("TextBox" & i).Font.Size = 10
Me.Controls("TextBox" & i).BackStyle = fmBackStyleTransparent
Me.Controls("TextBox" & i).BorderStyle = fmBorderStyleSingle
Me.Controls("TextBox" & i).BackColor = &H8000000F
Me.Controls("TextBox" & i).DragBehavior = fmDragBehaviorEnabled
Me.Controls("TextBox" & i).Left = 0
Me.Controls("TextBox" & i).Height = 20
Me.Controls("TextBox" & i).Top = i * 30 - 20
Me.Controls("TextBox" & i).Width = Application.Width
Me.Controls("TextBox" & i).Visible = True
Next i
TextBox1.Text = "Dies ist das Clever-Excel Forum, da wird Dir gerne geholfen, ob Anfänger oder fortgeschrittener Programmierer."
TextBox1.SetFocus
End Sub
|