Ejemplos usando el Api de windows para Visual basic

251 - visualizar número de líneas en un Text Box

Contenido:

Ejemplo 1 - Con un TextBox
Ejemplo 2 - Con un RichTextBox
Relacionados

Ejemplo 1 - Con textBox

Ejemplo que permite visualizar los números de líneas al costado de un textbox , y el número de linea actual ,por ejemplo como el ide de vb.

Este proyecto, ( que puede ser útil por ejemplo para editores de texto, editores de scripts etc...) está extraido de un componente activex programado por Visual basic Accelerator , y como muestra las siguientes imágenes , en un picturebox que se ubica al costado del TBox, se dibujan los números de líneas de acuerdo al contenido y se remarca el número de linea actual , es decir donde se encuentra ubicado el cursor o caret, y también remarcando los números de lineas cuando se selecciona una porción de texto

Pasos para crear el ejemplo

Agregar un control TextBox llamado text1 el form
También un control PictureBox llamado Picture1
Al text1 colocarle la propiedad Multiline con el valor true, y la propiedad ScrollBars
Agregar un módulo bas

Código fuente en el módulo bas

Option Explicit '''''''''''''''''''''''''''''''''''''''''''' ' Autor : http://www.vbaccelerator.com/ '''''''''''''''''''''''''''''''''''''''''''' ' declaraciones Api, Udt, constantes ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Type RECT Left As Long TOp As Long Right As Long Bottom As Long End Type Private Type POINTAPI x As Long y As Long End Type Private Declare Function GetClientRect Lib "USER32" ( _ ByVal hWnd As Long, _ lpRect As RECT) As Long Private Declare Function OffsetRect Lib "USER32" ( _ lpRect As RECT, _ ByVal x As Long, _ ByVal y As Long) As Long Private Declare Function FillRect Lib "USER32" ( _ ByVal hdc As Long, _ lpRect As RECT, _ ByVal hBrush As Long) As Long Private Declare Function OleTranslateColor Lib "oleaut32.dll" ( _ ByVal lOleColor As Long, _ ByVal lHPalette As Long, _ lColorRef As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetTextColor Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal crColor As Long) As Long Private Declare Function DrawText Lib "USER32" Alias "DrawTextA" ( _ ByVal hdc As Long, _ ByVal lpStr As String, _ ByVal nCount As Long, _ lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Function MoveToEx Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ lpPoint As POINTAPI) As Long Private Declare Function LineTo Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long) As Long Private Declare Function CreatePen Lib "gdi32" ( _ ByVal nPenStyle As Long, _ ByVal nWidth As Long, _ ByVal crColor As Long) As Long Private Declare Function SelectObject Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal hObject As Long) As Long Private Const PS_SOLID = 0 Private Const DT_CALCRECT = &H400 Private Const DT_RIGHT = &H2 Private Const DT_VCENTER = &H4 Private Const DT_SINGLELINE = &H20 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 Private Const EM_GETLINECOUNT = &HBA Private Const EM_LINEFROMCHAR = &HC9 Private Const EM_GETFIRSTVISIBLELINE = &HCE Private Const EM_SETMARGINS& = &HD3 Private Const EC_LEFTMARGIN& = &H1 Private Const EC_RIGHTMARGIN& = &H2 Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" ( _ ByVal hWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" ( _ ByVal hWnd As Long, _ ByVal nIndex As Long) As Long Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_RTLREADING = &H2000& Private Const WS_EX_LTRREADING = &H0 ' Fin de declaraciones '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Property Get TextBoxRTL(txtThis As TextBox) Dim lStyle As Long lStyle = GetWindowLong(txtThis.hWnd, GWL_EXSTYLE) If (lStyle And WS_EX_RTLREADING) = WS_EX_RTLREADING Then TextBoxRTL = True End If End Property Public Sub DrawLines(picTo As PictureBox, txtThis As TextBox) Dim lLine As Long Dim lCount As Long Dim lCurrent As Long Dim hBr As Long Dim lEnd As Long Dim lhDC As Long Dim bComplete As Boolean Dim tR As RECT, tTR As RECT Dim oCol As OLE_COLOR Dim lStart As Long Dim lEndLine As Long Dim tPO As POINTAPI Dim lLineHeight As Long Dim hPen As Long Dim hPenOld As Long 'Debug.Print "DrawLines" lhDC = picTo.hdc DrawText lhDC, "Hy", 2, tTR, DT_CALCRECT lLineHeight = tTR.Bottom - tTR.TOp + 1 lCount = LineCount(txtThis.hWnd) lCurrent = LineForCharacterIndex(txtThis.hWnd, txtThis.SelStart) lStart = txtThis.SelStart lEnd = txtThis.SelStart + txtThis.SelLength - 1 If (lEnd > lStart) Then lEndLine = LineForCharacterIndex(txtThis.hWnd, lEnd) Else lEndLine = lCurrent End If lLine = FirstVisibleLine(txtThis.hWnd) GetClientRect picTo.hWnd, tR lEnd = tR.Bottom - tR.TOp hBr = CreateSolidBrush(TranslateColor(picTo.BackColor)) FillRect lhDC, tR, hBr DeleteObject hBr tR.Left = 2 tR.Right = tR.Right - 2 tR.TOp = 0 tR.Bottom = tR.TOp + lLineHeight SetTextColor lhDC, TranslateColor(vbButtonShadow) tR.Right = tR.Right - 2 Do ' Ensure correct colour: If (lLine = lCurrent) Then SetTextColor lhDC, TranslateColor(vbWindowText) ElseIf (lLine = lEndLine + 1) Then SetTextColor lhDC, TranslateColor(vbButtonShadow) End If ' Draw the line number: DrawText lhDC, CStr(lLine + 1), -1, tR, DT_RIGHT ' Increment the line: lLine = lLine + 1 ' Increment the position: OffsetRect tR, 0, lLineHeight If (tR.Bottom > lEnd) Or (lLine + 1 > lCount) Then bComplete = True End If Loop While Not bComplete ' Draw a line... tR.Right = tR.Right + 2 MoveToEx lhDC, tR.Right, 0, tPO hPen = CreatePen(PS_SOLID, 1, TranslateColor(vbButtonShadow)) hPenOld = SelectObject(lhDC, hPen) LineTo lhDC, tR.Right, lEnd SelectObject lhDC, hPenOld DeleteObject hPen If picTo.AutoRedraw Then picTo.Refresh End If End Sub Private Function TranslateColor(ByVal clr As OLE_COLOR, _ Optional hPal As Long = 0) As Long If OleTranslateColor(clr, hPal, TranslateColor) Then TranslateColor = -1 End If End Function Private Property Get LineCount(ByVal hWnd As Long) LineCount = SendMessageLong(hWnd, EM_GETLINECOUNT, 0&, 0&) End Property Private Property Get LineForCharacterIndex(ByVal hWnd As Long, _ ByVal lIndex As Long) As Long LineForCharacterIndex = SendMessageLong(hWnd, EM_LINEFROMCHAR, lIndex, 0) End Property Private Property Get FirstVisibleLine(ByVal hWnd As Long) As Long FirstVisibleLine = SendMessageLong(hWnd, EM_GETFIRSTVISIBLELINE, 0, 0) End Property Public Sub SetMargins(ByVal hWnd As Long, ByVal lLeft As Integer, _ ByVal lRight As Integer) Dim lMargins As Long lMargins = MakeDWord(lRight, lLeft) SendMessageLong hWnd, EM_SETMARGINS, _ ByVal (EC_LEFTMARGIN Or EC_RIGHTMARGIN), _ lMargins End Sub Private Function MakeDWord(wHi As Integer, wLo As Integer) As Long If wHi And &H8000& Then MakeDWord = (((wHi And &H7FFF&) * 65536) Or (wLo And &HFFFF&)) Or &H80000000 Else MakeDWord = (wHi * 65536) + wLo End If End Function

Código fuente en el Form

Option Explicit ' Autor : http://www.vbaccelerator.com/ '''''''''''''''''''''''''''''''''''''''''''' Private Sub Form_Load() Dim datos As String Dim i As Integer ' carga unos datos en el control text For i = 0 To 1000 datos = datos & "Linea : " & i & vbCrLf Next With Text1 .Text = datos .FontName = "Lucida Console" .FontSize = 9 .BorderStyle = 0 End With With Picture1 ' le asigana la misma fuente para los dos controles .Font = Text1.Font .Width = 500 ' Ancho del picbox .BackColor = &H8000000D ' Color de fondo .AutoRedraw = True ' para que semantenga las lineas .BorderStyle = 0 End With ' establece el Margen al text1 con SendMessage SetMargins Text1.hWnd, 4, 4 End Sub Private Sub Form_Resize() On Error Resume Next If (TextBoxRTL(Text1)) Then Text1.Move _ Screen.TwipsPerPixelX, _ Screen.TwipsPerPixelY, _ Me.ScaleWidth - 2 * Screen.TwipsPerPixelX - Picture1.Width, _ Me.ScaleHeight - 2 * Screen.TwipsPerPixelY Picture1.Move Text1.Width + Text1.Left, _ Screen.TwipsPerPixelX, _ Picture1.Width, _ Me.ScaleHeight - 2 * Screen.TwipsPerPixelY Else Picture1.Move Screen.TwipsPerPixelX, _ Screen.TwipsPerPixelX, _ Picture1.Width, _ Me.ScaleHeight - 2 * Screen.TwipsPerPixelY Text1.Move _ Picture1.Left + Picture1.Width, _ Screen.TwipsPerPixelY, _ Me.ScaleWidth - 2 * Screen.TwipsPerPixelX - Picture1.Width, _ Me.ScaleHeight - 2 * Screen.TwipsPerPixelY End If End Sub ' redibuja los números de lineas ''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Picture1_Resize() DrawLines Picture1, Text1 End Sub Private Sub Text1_Change() DrawLines Picture1, Text1 End Sub Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer) DrawLines Picture1, Text1 End Sub Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer) DrawLines Picture1, Text1 End Sub Private Sub Text1_MouseDown(Button As Integer, _ Shift As Integer, x As Single, y As Single) DrawLines Picture1, Text1 End Sub Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, _ x As Single, y As Single) DrawLines Picture1, Text1 End Sub

Ejemplo 2 - Con RichTextBox

También se puede utilizar con un control richtextBox en ves de un text, pero por lo que estube viendo hay que hacer un par de cambios , por ejemplo.

1 - En la función DrawLines, hay que cambiar el parámetro que es de tipo TextBox, por un parámetro válido, puede ser RichTextBox u Object

por ejemplo :

Public Sub DrawLines(picTo As PictureBox, txtThis As Object)

2 - En el evento Resize del form, se deberia ejecutar el segundo bloque no el primero , es decir quedaria asi :

Private Sub Form_Resize()
On Error Resume Next
   

      Picture1.Move Screen.TwipsPerPixelX, _
         Screen.TwipsPerPixelX, _
         Picture1.Width, _
         Me.ScaleHeight - 2 * Screen.TwipsPerPixelY
      RichText.Move _
         Picture1.Left + Picture1.Width, _
         Screen.TwipsPerPixelY, _
         Me.ScaleWidth - 2 * Screen.TwipsPerPixelX - Picture1.Width, _
         Me.ScaleHeight - 2 * Screen.TwipsPerPixelY
End Sub

3 - Al richText, establecerle las propiedades:

BorderStyle en 0 ( rtfNoBorder)
Propiedad apariencia en Flat

Enlaces relacionados

Ocx code Max

Buscar en Recursos vb