...一行的内容并这一行内容的数字添加到另一个文本框?

发布网友 发布时间：2024-10-24 00:24

我来回答

共4个回答

热心网友 时间：2024-10-27 23:32

Private Sub Text1_Click() '文本框Text1的单击事件
Dim I As Long
Dim SPos As Long '每一行文字的起始字位置
Dim EPos As Long '每一行文字的结束字位置
Dim S As String '存储文本框的内容，方便引用
Dim Flag As Boolean '判断某个字符是不是数字的标志：是=True 否=False

S = Text1.Text '取得文本内容
SPos = Text1.SelStart '默认起始字位置为光标所在位置
EPos = Text1.SelStart '默认结束字位置为光标所在位置

'确定所点击行的起始字位置：判断方法是起始字的位置为1或者其前一个字符为回车符(vbCr)
Do While SPos > 0 '循环条件是起始字的位置大于0
If Mid(S, SPos, 1) = vbCr Then '找到回车符(vbCr)后
Exit Do '退出循环
End If
SPos = SPos - 1 '将光标往回移动
Loop
SPos = SPos + 1 '确定所点击行的起始字位置

'确定所点击行的结束字位置：判断方法是结束字的位置为1或者其后一个字符为回车符(vbCr)
If EPos = 0 Then '如果结束字的位置为0，则
EPos = 1 '结束字的位置设置为1（因为考虑了回车符的位置）
End If
Do While EPos < Len(S) '循环条件是结束字的位置小于字符串的长度
If Mid(S, EPos, 1) = vbCr Then '找到回车符(vbCr)后
Exit Do '退出循环
End If
EPos = EPos + 1 '将光标往回移动
Loop

S = Mid(S, SPos, EPos - SPos + 1) '取得当前点击位置所在行的整行文本内容
Text2.Text = "" '清除文本框Text2的原有内容

For I = 1 To Len(S) '对所取得的整行文本内容进行逐个字符判断，看是不是数字
If IsNumeric(Mid(S, I, 1)) = True Then '如果某个字符是数字，则
Flag = True '数字标志为True
Else
Flag = False '否则数字标志为False
End If

If Flag = True Then '数字标志为True，说明当前判断的字符是数字
Text2.Text = Text2.Text & Mid(S, I, 1) '将数字显示在文本框Text2中
Else
Text2.Text = Trim(Text2.Text) & " " '数字标志为False，说明当前判断的字符不是数字，用1个空格代替
End If
Next I

Text2.Text = Trim(Text2.Text) '清除文本框Text2中内容的前后空格
End Sub

注意：
执行以上代码之前，应该将文本框Text1的属性设置为多行文本显示格式，即将Text1的MultiLine属性设置为True，以及ScrollBars属性设置为2-Vertical（显示垂直滚动条）。

另：
对于取得的数字我进行了如下格式的处理：（举例）
假设文本框Text1中某行的内容为:fafaf43435desfra35465fafa324
则取得的数字在文本框Text2中是这样显示的：43435 35465 324（即如果该行的数字不是连续的话就用一个空格分开）

你可以根据自己的实际需要进行处理。。。

热心网友 时间：2024-10-27 23:25

选择，复制，粘贴

热心网友 时间：2024-10-27 23:29

cc

热心网友 时间：2024-10-27 23:25

Const EM_GETLINE = &HC4
Const EM_LINELENGTH = &HC1
Const EM_LINEINDEX = &HBB
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const EM_GETLINECOUNT = &HBA
Private Sub Command1_Click()
Dim lineCount As Long
On Local Error Resume Next
lineCount = SendMessageLong(Text1.hWnd, EM_GETLINECOUNT, 0&, 0&)
Dim s As String
For ii = 0 To lineCount - 1
Call TB_GetLine(Text1.hWnd, ii, s)
For i = 1 To Len(s)
l = Mid(s, i, 1)
If Chr(48) <= l And l <= Chr(57) Then t = t & l
Next i
If s <> "" Then If Right(s, 1) = Chr(10) Or Chr(13) Then t = t & vbCrLf
Text2.Text = t
Next ii
End Sub
Sub TB_GetLine(ByVal hWnd As Long, ByVal whichLine As Long, Line As String)
Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Long
lc = SendMessage(hWnd, EM_LINEINDEX, whichLine, ByVal 0&)
length = SendMessage(hWnd, EM_LINELENGTH, lc, ByVal 0&)
If length > 0 Then
ReDim bArr(length + 1) As Byte, bArr2(length - 1) As Byte
Call RtlMoveMemory(bArr(0), length, 2)
Call SendMessage(hWnd, EM_GETLINE, whichLine, bArr(0))
Call RtlMoveMemory(bArr2(0), bArr(0), length)
Line = StrConv(bArr2, vbUnicode)
Else
Line = ""
End If
End Sub

=============或者~~ 鼠标选中~

Private Sub Command1_Click()
t = Text1.SelText
For i = 1 To Len(t)
l = Mid(t, i, 1)
If t <> "" Then If Chr(48) <= l And l <= Chr(57) Then s = s & l
Next i
Text2.Text = s
End Sub
=====================第三种方法~~就是题目要求的
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Const EM_GETLINE = &HC4
Const EM_LINELENGTH = &HC1
Const EM_LINEINDEX = &HBB
Const EM_CHARFROMPOS = &HD7
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim pos As Long, lc As Long, num As Long
Dim Line As Integer, CharPos As Integer, i As Integer
Dim sz() As String
pos = X / Screen.TwipsPerPixelX + Y / Screen.TwipsPerPixelY * 65536
lc = SendMessage(Text1.hWnd, EM_CHARFROMPOS, 0, ByVal pos)
Line = lc \ 65536
CharPos = lc Mod 65536
sz = Split(Text1.Text, vbCrLf)
For i = 0 To Line - 1
num = num + LenB(StrConv(sz(i), vbFromUnicode)) + 2
Next i
Dim s As String
Call TB_GetLine(Text1.hWnd, Line, s)
For i = 1 To Len(s)
l = Mid(s, i, 1)
If s <> "" Then If Chr(48) <= l And l <= Chr(57) Then t = t & l
Next i
Text2.Text = Text2 & t
End Sub
Sub TB_GetLine(ByVal hWnd As Long, ByVal whichLine As Long, Line As String)
Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Long
lc = SendMessage(hWnd, EM_LINEINDEX, whichLine, ByVal 0&)
length = SendMessage(hWnd, EM_LINELENGTH, lc, ByVal 0&)
If length > 0 Then
ReDim bArr(length + 1) As Byte, bArr2(length - 1) As Byte
Call RtlMoveMemory(bArr(0), length, 2)
Call SendMessage(hWnd, EM_GETLINE, whichLine, bArr(0))
Call RtlMoveMemory(bArr2(0), bArr(0), length)
Line = StrConv(bArr2, vbUnicode)
Else
Line = ""
End If
End Sub

===========

这3种方法都记得将 text的multiline 改为true