Код VBA с использованием Windows API для раскрашивания текста - PullRequest
Новая
       18

Код VBA с использованием Windows API для раскрашивания текста

0 голосов
/ 22 апреля 2019

Привет, эксперты VBA и Windows API! У меня есть следующий код, который должен установить цвет текущего выделенного текста в текстовом поле расширенного текста, но он работает только частично. Например, он помещает весь текст синим цветом, а не только выделением. Может кто-нибудь определить, где проблема может быть? Я использую VBA 7 - 64 бита - Windows 10

Форма модуля

Private Sub cmdButton_Click() 'Selected Text in Blue Dim lngHandle As Long lngHandle = fhWnd(Me.txtITMrichtxt) RTBSetTextColor lngHandle, vbBlue End Sub

Кодовый модуль 

Option explicit
Public Enum ATTDEFINI
  ATTUNDEF = -3
  ATTDEFAULT = -2
End Enum
Private Type CHARFORMAT2
  cbSize As Long
  dwMask As Long
  dwEffects As Long
  yHeight As Long
  yOffset As Long
  crTextColor As OLE_COLOR
  bCharSet As Byte
  bPitchAndFamily As Byte
  szFaceName As String * LF_FACESIZE
  wWeight As Integer
  sSpacing As Integer
  crBackColor As OLE_COLOR
  lcid As Long
  dwReserved As Long
  sStyle As Integer
  wKerning As Integer
  bUnderLineType As Byte
  bAnimation As Byte
  bRevAuthor As Byte
  bReserved1 As Byte
End Type
Public Enum RTBC_FLAGS 'CharFormat (SCF_) flags for EM_SETCHARFORMAT message.
  RTBC_DEFAULT = 0
  RTBC_SELECTION = 1
  RTBC_WORD = 2      'Combine with RTBC_SELECTION!
  RTBC_ALL = 4
End Enum
Private Const WM_USER As Long = &H400
Private Const EM_SETCHARFORMAT = WM_USER + 68
Private Const CFM_COLOR As Long = &H40000000  '<-> Membre de la structure CHARFORMAT2 ou Attribut de dwEffects
Private Const CFE_AUTOCOLOR = CFM_COLOR
Declare PtrSafe Function apiGetFocus Lib "user32" Alias "GetFocus" () As LongPtr
Declare PtrSafe Function SendMessageWLng Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As Any) As LongPtr

Function fhWnd(iaControl As Control) As LongPtr
On Error Resume Next
iaControl.SetFocus
If Err Then
  fhWnd = 0
Else
  fhWnd = apiGetFocus
End If
On Error GoTo 0
End Function

Public Sub RTBSetTextColor(ByVal ilngHWND As LongPtr, Optional ByVal ilngTextColor As OLE_COLOR = -1, _
                           Optional ByVal Scope As RTBC_FLAGS = RTBC_SELECTION)
Dim cf2Colors As CHARFORMAT2

With cf2Colors
  .cbSize = LenB(cf2Colors)
  .dwMask = CFM_COLOR
  If ilngTextColor = ATTDEFAULT Then
    .dwEffects = CFE_AUTOCOLOR
  Else
    .dwEffects = 0
    .crTextColor = ilngTextColor
  End If
End With
SendMessageWLng ilngHWND, EM_SETCHARFORMAT, Scope, VarPtr(cf2Colors)
End Sub
...