VB解决不了的问题？！各路英雄，请进！！！

Question

首先：欢迎各路英雄跟贴。
在上一贴中，特别感谢：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定位的光标位置编号都是按英文字符处理的）
您有解决办法吗？让大家一起分享的您的成功！！！

Answer 1

欲知前贴如何，请http://community.csdn.net/Expert/topic/5646/5646744.xml?temp=.4248926

Answer 2

请各路大虾到http://community.csdn.net/Expert/topic/5648/5648720.xml?temp=.4943201
参与讨论

Answer 3

代码我没做验证,我有个想法,楼主可以考虑试试直接将 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

Answer 4

晕,错了 
CopyMemory LineText(0), size * 2, size * 2 
这句干什么用的??? 数据缓冲???
redim 后,数据已经缓冲了,不用在次缓冲了
把CopyMemory LineText(0), size * 2, size * 2 删了吧

Answer 5

To:PctGL
谢谢您的参与。VB老鸟就是提出的解决方法。
现在的问题是：在richTextBox中中英文混排时该怎样定位光标所在字符的编号。

Answer 6

你的问题真多，应该多看看MSDN，自己研究，不要什么事都问别人。在这里没人有义务去回答你的每个问题。

Answer 7

最好将你测试的代码帖出来。既然取得的字符位置是按照 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 Functionpublic 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

Answer 8

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 FunctionPrivate Sub RTB_Click()
Debug.Print "y=" & GetCurPos(RTB).y
Debug.Print "x=" & GetCurPos(RTB).x
End Sub

Answer 9

To:VBAdvisor
中英文混排时，还是按英文方式进行定位的

Answer 10

VBAdvisor给出的方法，在文本为英文情况下，是正确的

Answer 11

。以前写过一个类似代码，也存在类似问题。换个角度想想，你能不能知道插入符前后的字符呢，，，，，，，，英文和中文的字符是有差异的吧，例如你用ASC函数，得到的结果不知道，我是新人，猜测而。

Answer 12

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 TypePublic 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 TEXTRANGELineCount = 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 IfGetLineText = TextInRange(charFrom, charFrom + lc)End FunctionPublic 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 ByteTR.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 IfEnd Sub'TextBox GetLine Function From VBAdvisor
Public Function GetLine(Byval hWnd As long,ByVal whichLine As Long) As StringDim nLen As Long, bArr() As Byte, bArr2() As Byte, lReturn As LonglReturn = 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) + 1Else
GetLine = vbNullString
End IfEnd Function

Answer 13

http://hi.baidu.com/vbadvisor/blog/item/66e443641b001af5f736543a.htmlVBAdvisor 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 LongPrivate Declare Function SendMessageLongW Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, _
                                                                             ByVal wMsg As Long, _
                                                                             ByVal wParam As Long, _
                                                                             ByVal lParam As Long) As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hwnd As Long) As LongPublic 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 PropertyPublic Property Get LineForCharacterIndex(lindex As Long) As Long    LineForCharacterIndex = SendMessageLongA(m_hWndEB, EM_LINEFROMCHAR, lindex, 0)End PropertyPublic Property Get SelStart() As LongDim lEnd    As Long
Dim lStart  As Long    If m_hWndEB Then
        SendMessageLongA m_hWndEB, EM_GETSEL, VarPtr(SelStart), VarPtr(lEnd)
    End IfEnd 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