VB解决不了的问题?!各路英雄,请进!!!

colorrain 2007-07-11 12:10:11
首先:欢迎各路英雄跟贴。
在上一贴中,特别感谢:VBAdvisor,Tiger_Zhao,zyl910(排名不分先后啊)。上回讨论的问题如下:

VB老鸟:
可能是 Buffer 长度不足,修改如下,测试通过

Public Function GetLineText(ByVal handle As Long, ByVal index As Long) As String
'handle 为richtextbox句柄,index为行号
Dim LineText() As Byte
Dim size As Long
Dim pos As Long
pos = SendMessage(handle, EM_LINEINDEX, index, 0)
size = SendMessage(handle, EM_LINELENGTH, pos, 0)
If size = 0 Then
GetLineText = ""
Else
ReDim LineText((size * 2 - 1) + 1)
CopyMemory LineText(0), size * 2, 2
size = SendMessage(handle, EM_GETLINE, index, LineText(0))
GetLineText = StrConv(LeftB(LineText, size), vbUnicode)
End If
End Function
经测试:是size = SendMessage(handle, EM_LINELENGTH, pos, 0)
返回的长度不够。也就是说,返回的长度是将中英文混排的行文本按英文字符进行处理的。
现在的问题是:怎样才能正确地定位光标的编号呢,怎样才能正确的统计出中英文混排的长度呢。(在richTextbox中,每一行每一列每一个字符都有编号,但很遗憾,SendMessage定位的光标位置编号都是按英文字符处理的)
您有解决办法吗?让大家一起分享的您的成功!!!
...全文
504 17 打赏 收藏 转发到动态 举报
写回复
用AI写文章
17 条回复
切换为时间正序
请发表友善的回复…
发表回复
VBAdvisor 2008-05-30
  • 打赏
  • 举报
回复
http://hi.baidu.com/vbadvisor/blog/item/66e443641b001af5f736543a.html

VBAdvisor announcement: 终于解决获取某一行的unicode文本(GetTextLine),网上流传的方法都不行2008-05-17 09:11'本annocement只有高级VB程序员才明白其中的道理,才明白VB Unicode的重要性及难点之所在

VBScript code


Private Declare Function SendMessageLongA Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Declare Function SendMessageLongW Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

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 Function IsWindowUnicode Lib "user32.dll" (ByVal hwnd As Long) As Long

Public Property Get GetTextFromLine(Optional ByVal LineIndex As Long = -1&) As String

' returns the text for an entire line
' Passing -1 will retrieve the value for the line having the cursor (SelStart)
Dim lValue As Long, arrString() As Byte
Const EM_GETLINE As Long = &HC4

If LineIndex = -1 Then LineIndex = CurrentLine
lValue = SendMessage(m_hWndEB, EM_LINEINDEX, LineIndex, 0&)

If lValue > -1 Then
lValue = SendMessage(m_hWndEB, EM_LINELENGTH, lValue, 0&)
If lValue Then
If IsWindowUnicode(m_hWndEB) Then
GetTextFromLine = String$(lValue, 0)
CopyMemory ByVal StrPtr(GetTextFromLine), lValue, 4&
SendMessageLongW m_hWndEB, EM_GETLINE, LineIndex, StrPtr(GetTextFromLine)
If lValue = 1 Then GetTextFromLine = Left$(GetTextFromLine, 1)
Else
If lValue < 4 Then
ReDim arrString(0 To 3)
Else
ReDim arrString(0 To lValue - 1)
End If
CopyMemory arrString(0), lValue, 4&
SendMessageLongA m_hWndEB, EM_GETLINE, LineIndex, VarPtr(arrString(0))
If lValue < 4 Then ReDim Preserve arrString(0 To lValue - 1)
GetTextFromLine = StrConv(arrString, vbUnicode)
End If
End If
End If
End Property
VBScript code

Public Property Get CurrentLine() As Long

CurrentLine = LineForCharacterIndex(SelStart)

End Property

Public Property Get LineForCharacterIndex(lindex As Long) As Long

LineForCharacterIndex = SendMessageLongA(m_hWndEB, EM_LINEFROMCHAR, lindex, 0)

End Property

Public Property Get SelStart() As Long

Dim lEnd As Long
Dim lStart As Long

If m_hWndEB Then
SendMessageLongA m_hWndEB, EM_GETSEL, VarPtr(SelStart), VarPtr(lEnd)
End If

End Property






'网上流行的所谓支持中文的方法:
'说明:在locale ID为英文(1033)时不能返回中文,locale ID为2052时才可以返回中文,因为调用SendMessage时候,Windows进行了Unicode->ANSI的转换,导致Unicode的破坏)
Public Property Get GetLine(ByVal whichLine As Long) As String
Dim nLen As Long, bArr() As Byte, bArr2() As Byte, lReturn As Long
lReturn = SendMessage(m_hWndEB, EM_LINEINDEX, whichLine, ByVal 0&)
nLen = SendMessage(m_hWndEB, EM_LINELENGTH, lReturn, ByVal 0&)
If nLen > 0 Then
ReDim bArr(2 * nLen + 1) As Byte, bArr2(2 * nLen - 1) As Byte
Call CopyMemory(bArr(0), 2 * nLen, 2) '准备一个存储器,传递消息之前先在存储器的前两个字节填入存储器的长度

Call SendMessage(m_hWndEB, EM_GETLINE, whichLine, bArr(0))
Call CopyMemory(bArr2(0), bArr(0), 2 * nLen)
GetLine = String$(UBound(bArr2) + 1, vbNullChar)
CopyMemory ByVal GetLine, bArr2(0), UBound(bArr) + 1
Else
GetLine = vbNullString
End If
End Property


嗷嗷叫的老马 2007-07-20
  • 打赏
  • 举报
回复
.........我在晕

再晕一会

楼下继续........
PctGL 2007-07-19
  • 打赏
  • 举报
回复
这个题目讨论到现在是在讨论什么???
是在讨论光标下提取字符?
是在讨论插入符下提取字符?
是在讨论提取后字符的识别???
VBAdvisor 2007-07-18
  • 打赏
  • 举报
回复
This is impossible mission!
http://community.csdn.net/Expert/TopicView3.asp?id=5648720
http://community.csdn.net/Expert/TopicView3.asp?id=5646744

重申:
(不考虑Win9x,因为更复杂)对于XP英文/中文系统,如果你的Non-Unicode设定是English, SendMessage 根本就不可能得到中文.但如果Non-Unicode设定是Chinese (PRC),上面的编码可以取得中文。原因在于SendMessage有经过Unicode到ANSI/DBCS的几次转换,造成Unicode的丢失。

我挣扎多年都没成功!!!不信你们将你的non-Unicode设定为English!!!
Control Panel --> Language and Region options --> Advance Tab ---> English as non-Unicode

'RichEdit GetLine Function From VBAdvisor
Public Type TEXTRANGE
chrg As CHARRANGE
lpstrText As Long
End Type

Public Function GetLineText(Byval hWnd as long,ByVal LineNum As Long) As String
Dim LineCount As Long
Dim lc As Long, j As Long
Dim charFrom As Long
Dim charEnd As Long
Dim CR As CHARRANGE
Dim TR As TEXTRANGE

LineCount = SendMessageLong(hWnd, EM_GETLINECOUNT, ByVal 0&, ByVal 0&)
If LineNum > LineCount Then
GetLineText = vbNullString
Exit Function
End If
charFrom = SendMessageLong(hWnd, EM_LINEINDEX, LineNum, ByVal 0&)
lc = SendMessageLong(hWnd, EM_LINELENGTH, ByVal charFrom, ByVal 0&)
If lc = 0 Then
GetLineText = vbNullString
Exit Function
End If

GetLineText = TextInRange(charFrom, charFrom + lc)

End Function

Public sub TextInRange(Byval hWnd as long,ByVal lStart As Long, ByVal lEnd As Long)

Dim TR As TEXTRANGE
Dim sText As String
Dim lR As Long
Dim B() As Byte

TR.chrg.cpMin = lStart
TR.chrg.cpMax = lEnd

' VB won't do the terminating null for you!
sText = String$(lEnd - lStart + 1, 0)
B = sText
ReDim Preserve B(0 To (lEnd - lStart + 1)) As Byte
TR.lpstrText = VarPtr(B(0))

lR = SendMessageLong(hWnd, EM_GETTEXTRANGE, 0, VarPtr(TR))

If (lR > 0) Then
' lstrlen assumes that lpString is a NULL-terminated string !!!
CopyMemory ByVal sText, ByVal TR.lpstrText, lR
TextInRange = Left$(sText, lR)
End If

End Sub

'TextBox GetLine Function From VBAdvisor
Public Function GetLine(Byval hWnd As long,ByVal whichLine As Long) As String

Dim nLen As Long, bArr() As Byte, bArr2() As Byte, lReturn As Long

lReturn = SendMessage(hWnd , EM_LINEINDEX, whichLine, ByVal 0&)

nLen = SendMessage(hWnd , EM_LINELENGTH, lReturn, ByVal 0&)

If nLen > 0 Then
ReDim bArr(2 * nLen + 1) As Byte, bArr2(2 * nLen - 1) As Byte
Call CopyMemory(bArr(0), 2 * nLen, 2)
Call SendMessage(hWnd , EM_GETLINE, whichLine, bArr(0))
Call CopyMemory(bArr2(0), bArr(0), 2 * nLen)

GetLine = String$(UBound(bArr2) + 1, vbNullChar)
CopyMemory ByVal GetLineString, bArr2(0), UBound(bArr) + 1

Else
GetLine = vbNullString
End If

End Function
清晨曦月 2007-07-12
  • 打赏
  • 举报
回复
。。。。以前写过一个类似代码,也存在类似问题。。。。。。。

换个角度想想,你能不能知道插入符前后的字符呢,,,,,,,,

英文和中文的字符是有差异的吧,例如你用ASC函数,得到的结果。。。。。。

不知道,我是新人,猜测而。
colorrain 2007-07-11
  • 打赏
  • 举报
回复
To:PctGL
谢谢您的参与。VB老鸟就是提出的解决方法。
现在的问题是:在richTextBox中中英文混排时该怎样定位光标所在字符的编号。
PctGL 2007-07-11
  • 打赏
  • 举报
回复
晕,错了
CopyMemory LineText(0), size * 2, size * 2
这句干什么用的??? 数据缓冲???
redim 后,数据已经缓冲了,不用在次缓冲了
把CopyMemory LineText(0), size * 2, size * 2 删了吧
PctGL 2007-07-11
  • 打赏
  • 举报
回复
代码我没做验证,我有个想法,楼主可以考虑试试

直接将 size * 2 做为缓冲区

VB 的内码是 Unicode ,数据直接复制到指定的内存,不论是否是字母汉字都是2字节表示

所以将缓冲区直接乘以2做为缓冲区

原文代码,
ReDim LineText((size * 2 - 1) + 1)
CopyMemory LineText(0), size * 2, 2
size = SendMessage(handle, EM_GETLINE, index, LineText(0))
GetLineText = StrConv(LeftB(LineText, size), vbUnicode)

建议代码:
ReDim LineText((size * 2)
CopyMemory LineText(0), size * 2, size * 2
size = SendMessage(handle, EM_GETLINE, index, LineText(0))
GetLineText = LineText


另外考虑是不是sendmessageA的问题,试试替换为 sendmessageW
colorrain 2007-07-11
  • 打赏
  • 举报
回复
请各路大虾到http://community.csdn.net/Expert/topic/5648/5648720.xml?temp=.4943201
参与讨论
colorrain 2007-07-11
  • 打赏
  • 举报
回复
欲知前贴如何,请http://community.csdn.net/Expert/topic/5646/5646744.xml?temp=.4248926
colorrain 2007-07-11
  • 打赏
  • 举报
回复
VBAdvisor给出的方法,在文本为英文情况下,是正确的
colorrain 2007-07-11
  • 打赏
  • 举报
回复
可能我描述的有问题:
在光标前是中英文混排,在获取光标列时,返回的值有问题。不管光标前面有多少中文字符,都是按英文字符进行处理。
colorrain 2007-07-11
  • 打赏
  • 举报
回复
To:VBAdvisor
中英文混排时,还是按英文方式进行定位的
amandag 2007-07-11
  • 打赏
  • 举报
回复
up
VBAdvisor 2007-07-11
  • 打赏
  • 举报
回复
Private Function GetCurPos(ByRef TextControl As Control) As POINTAPI
Dim LineIndex As Long
Dim SelRange As CHARRANGE
Dim TempStr As String
Dim TempArray() As Byte
Dim CurRow As Long
Dim CurPos As POINTAPI

TempArray = StrConv(TextControl.Text, vbFromUnicode)
Call SendMessage(TextControl.hWnd, EM_EXGETSEL, 0, SelRange)
CurRow = SendMessage(TextControl.hWnd, EM_LINEFROMCHAR, SelRange.cpMin, 0)
LineIndex = SendMessage(TextControl.hWnd, EM_LINEINDEX, CurRow, 0)
If SelRange.cpMin = LineIndex Then
GetCurPos.x = 1
Else
TempStr = String(SelRange.cpMin - LineIndex, 13)
CopyMemory ByVal StrPtr(TempStr), ByVal StrPtr(TempArray) + LineIndex, SelRange.cpMin - LineIndex
TempArray = TempStr
ReDim Preserve TempArray(SelRange.cpMin - LineIndex - 1)
TempStr = StrConv(TempArray, vbUnicode)
GetCurPos.x = Len(TempStr) + 1
End If
GetCurPos.y = CurRow + 1
End Function

Private Sub RTB_Click()
Debug.Print "y=" & GetCurPos(RTB).y
Debug.Print "x=" & GetCurPos(RTB).x
End Sub
Tiger_Zhao 2007-07-11
  • 打赏
  • 举报
回复
最好将你测试的代码帖出来。

既然取得的字符位置是按照 Ansi 格式计数的的,那么你先不要用 strconv 函数将字符进行转化,大致思路如下:

假设你已经取得当前光标的为置是 Ansi 格式的第 3 行第 9 列,那么 Unicode 的格式应该也是第 3 行,第 x 列用 ColA2W 取得:

'取得整行的 Ansi 字符串
Public Function GetLineTextA(ByVal handle As Long, ByVal index As Long) As String
。。。其他都一样
GetLineTextA = LeftB(LineText, size)
。。。
End Function

public function ColA2W(byval handle as long, byval row as long, byval colA as long) as long
'取得 Ansi 字符串,取得光标前的 colA 个 Ansi 字符,转化为 Unicode,统计长度
'至于列号和字符数是否存在 ±1 的问题,自己测一下再完善一下代码
ColA2W = len(strconv(leftB(getlinetexta(handle, row), col),vbunicode))
end sub
VBAdvisor 2007-07-11
  • 打赏
  • 举报
回复
你的问题真多,应该多看看MSDN,自己研究,不要什么事都问别人。在这里没人有义务去回答你的每个问题。

1,485

社区成员

发帖
与我相关
我的任务
社区描述
VB API
社区管理员
  • API
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧