Полезное для программистов:

Фриланс
Новости
Статьи
   
Рубрики:


Как отформатировать текст в свойство Caption формы?

Поиск:
Если вам будет интерестно писал я здесь как то прогу чтобы в форме в свойстве каптион можно было выводить текст и чтобы он был например по середине итд итп выравнивание.. но меня больше инетересовал Юникод.. чтобы китйские знаки показывал smile 

добавит 6 оптиона и две кнопки smile вот и всё в принципе что надо...
а код такой в форме 

Код

Option Explicit

Dim b As Boolean

Private Sub Command1_Click()
    Me.Caption = ""
    If b = False Then
        Init Me.hwnd
        b = True
    End If
End Sub

Private Sub Command2_Click()
    If b = True Then
        UnHookForm Me.hwnd
        b = False
    End If
End Sub

Private Sub Form_Load()
Dim s As String, i As Long
    
    b = False
    SetAlign
    SetColor
    
    s = ""
    For i = 1 To 10
        s = s & ChrW(50000 + i * 10)
    Next i
    Module1.sCaption = s
    Module1.sFontName = Module1.FONT_NAME
End Sub

Private Sub SetAlign()
    If Option1.Value = True Then Module1.lTextAlign = TEXT_ALIGN.Bottom Or TEXT_ALIGN.Left
    If Option2.Value = True Then Module1.lTextAlign = TEXT_ALIGN.Bottom Or TEXT_ALIGN.center
    If Option3.Value = True Then Module1.lTextAlign = TEXT_ALIGN.Bottom Or TEXT_ALIGN.Right
End Sub

Private Sub SetColor()
    If Option4.Value = True Then Module1.lTextColor = vbGreen
    If Option5.Value = True Then Module1.lTextColor = vbWhite
    If Option6.Value = True Then Module1.lTextColor = vbRed
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Command2_Click
End Sub

Private Sub Option1_Click()
SetAlign
Command2_Click
Command1_Click
End Sub

Private Sub Option2_Click()
Option1_Click
End Sub

Private Sub Option3_Click()
Option1_Click
End Sub

Private Sub Option4_Click()
SetColor
Command2_Click
Command1_Click
End Sub

Private Sub Option5_Click()
Option4_Click
End Sub

Private Sub Option6_Click()
Option4_Click
End Sub


а сам модуль таков

Код

Option Explicit

Private Type Size
    cx As Long
    cy As Long
End Type

Private Declare Function GetTextExtentPoint Lib "gdi32.dll" Alias "GetTextExtentPointW" (ByVal hdc As Long, ByVal pszString As Long, ByVal cbString As Long, lpSize As Size) As Long
Private Declare Function GetTextExtentExPoint Lib "gdi32.dll" Alias "GetTextExtentExPointA" (ByVal hdc As Long, ByVal lpszStr As String, ByVal cchString As Long, ByVal nMaxExtent As Long, lpnFit As Long, alpDx As Long, lpSize As Size) As Long

Private Const WM_SIZING As Long = &H214

Private Const SM_CXFRAME As Long = 32
Private Const SM_CXSIZEFRAME As Long = SM_CXFRAME
Private Const SM_CYFRAME As Long = 33
Private Const SM_CYSIZEFRAME As Long = SM_CYFRAME

Private Const SM_CYBORDER As Long = 6
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_SIZEBOX As Long = WS_THICKFRAME

Private Const SM_CXDLGFRAME As Long = 7
Private Const SM_CXFIXEDFRAME As Long = SM_CXDLGFRAME

Private Const SM_CYDLGFRAME As Long = 8
Private Const SM_CYFIXEDFRAME As Long = SM_CYDLGFRAME

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const GWL_EXSTYLE As Long = -20
Private Const GWL_STYLE As Long = -16

Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_EX_TOOLWINDOW As Long = &H80&

Private Const SM_CYSMCAPTION As Long = 51
Private Const SM_CYCAPTION As Long = 4
Private Const SM_CXSMSIZE As Long = 52
Private Const SM_CXSMICON As Long = 49

Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Const DT_SINGLELINE As Long = &H20

Private Const DT_BOTTOM As Long = &H8
Private Const DT_CENTER As Long = &H1
Private Const DT_LEFT As Long = &H0
Private Const DT_RIGHT As Long = &H2
Private Const DT_RTLREADING As Long = &H20000
Private Const DT_TOP As Long = &H0
Private Const DT_VCENTER As Long = &H4

Public Enum TEXT_ALIGN
    Left = DT_LEFT
    Right = DT_RIGHT
    Top = DT_TOP
    Bottom = DT_BOTTOM
    vcenter = DT_VCENTER
    center = DT_CENTER
    RtLreading = DT_RTLREADING
End Enum

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function RestoreDC Lib "gdi32.dll" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Private Declare Function SaveDC Lib "gdi32.dll" (ByVal hdc As Long) As Long

Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32.dll" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function SystemParametersInfo Lib "user32.dll" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long

Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Private Const GWL_WNDPROC = (-4)

Private Const SM_CXBORDER As Long = 5
Private Const SM_CXSIZE As Long = 30
Private Const SM_CYSIZE As Long = 31
Private Const TRANSPARENT As Long = 1

Private Const WM_NCACTIVATE As Long = &H86
Private Const WM_NCPAINT As Long = &H85
Private Const WM_SETTEXT As Long = &HC
Private Const WM_SYSCOMMAND As Long = &H112

Private Declare Function DrawText Lib "user32.dll" Alias "DrawTextW" (ByVal hdc As Long, ByVal pStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Const DEFAULT_CHARSET As Long = 1

Private Const LF_FACESIZE  As Long = 32

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End Type

Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type

Private Const SPI_GETNONCLIENTMETRICS As Long = 41

Dim hFont As Long, x As Long, y As Long

Public Const FONT_NAME As String = "Arial Unicode MS"

Public sCaption As String
Public lTextColor As Long
Public lTextAlign As Long
Public sFontName As String

Dim pPrevProc As Long

Dim xLeft As Long, xRight As Long
Dim yTop As Long, yBottom

Public Function Init(ByVal hwnd As Long) As Long
Dim tNonClient As NONCLIENTMETRICS, tFont As LOGFONT, i As Long
Dim lStyle As Long, xButton As Long

    tNonClient.cbSize = Len(tNonClient)
    If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Len(tNonClient), ByVal VarPtr(tNonClient), 0) = 0 Then Exit Function
    
    tFont = tNonClient.lfCaptionFont
    For i = 1 To LF_FACESIZE
        If i <= Len(sFontName) Then
            tFont.lfFaceName(i) = Asc(Mid(sFontName, i, 1))
        Else
            tFont.lfFaceName(i) = 0
        End If
    Next i
    tFont.lfCharSet = DEFAULT_CHARSET
    
    hFont = CreateFontIndirect(tFont)
    If hFont = 0 Then Exit Function

    xLeft = 0
    xRight = 0
    
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
    xRight = GetSystemMetrics(SM_CXSIZE)
    If (lStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then xRight = xRight + GetSystemMetrics(SM_CXSIZE)
    If (lStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX Then xRight = xRight + GetSystemMetrics(SM_CXSIZE)


    If (lStyle And WS_SYSMENU) = WS_SYSMENU Then xLeft = GetSystemMetrics(SM_CXSMICON)
    
    If (lStyle And WS_SIZEBOX) = WS_SIZEBOX Then
        
        xLeft = xLeft + GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CXSIZEFRAME)
        xRight = xRight + GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CXSIZEFRAME)
        
        yTop = GetSystemMetrics(SM_CYSIZEFRAME) + GetSystemMetrics(SM_CYBORDER)
        yBottom = GetSystemMetrics(SM_CYCAPTION)
        
    Else
        xLeft = xLeft + GetSystemMetrics(SM_CXFIXEDFRAME) + GetSystemMetrics(SM_CXBORDER)
        xRight = xRight + GetSystemMetrics(SM_CXFIXEDFRAME) + GetSystemMetrics(SM_CXBORDER)
        
        yTop = GetSystemMetrics(SM_CYFIXEDFRAME) + GetSystemMetrics(SM_CYBORDER)
        yBottom = GetSystemMetrics(SM_CYCAPTION)
        
    End If
    
    pPrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
    Init = pPrevProc
    
    SendMessage hwnd, WM_NCPAINT, 0, ByVal 0
    
End Function

Public Sub UnHookForm(ByVal hwnd As Long)
    DeleteObject hFont
    SetWindowLong hwnd, GWL_WNDPROC, pPrevProc
End Sub

Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
    WindowProc = CallWindowProc(pPrevProc, hwnd, uMsg, wParam, lParam)
    If uMsg = WM_NCPAINT Or uMsg = WM_NCACTIVATE Then DrawCaption hwnd
    
End Function

Public Sub DrawCaption(ByVal hwnd As Long)
Dim hdc As Long, hOldDC As Long, tWinRect As RECT, tCapRect As RECT
Dim tSize As Size, sTemp As String

    hdc = GetWindowDC(hwnd)
    hOldDC = SaveDC(hdc)
    
    GetWindowRect hwnd, tWinRect
    SetRect tCapRect, xLeft, yTop, tWinRect.Right - tWinRect.Left - xRight, yBottom
    
    SelectObject hdc, hFont
    SetBkMode hdc, TRANSPARENT
    SetTextColor hdc, lTextColor
    
    sTemp = sCaption
10:
    GetTextExtentPoint hdc, StrPtr(sTemp), Len(sTemp), tSize
    
    If tCapRect.Right - tCapRect.Left >= tSize.cx Then
        DrawText hdc, StrPtr(sTemp), Len(sTemp), tCapRect, lTextAlign Or DT_SINGLELINE
    Else
        If Mid(sTemp, Len(sTemp) - 2, 3) = "..." Then
            sTemp = Mid(sTemp, 1, Len(sTemp) - 4) & "..."
        Else
            sTemp = Mid(sTemp, 1, Len(sTemp) - 3) & "..."
        End If
        GoTo 10
    End If

    RestoreDC hdc, hOldDC
    ReleaseDC hwnd, hdc
    
End Sub

может быть кому интерестно будет посмотреть как работает smile 
Автор: Gannibal






Просмотров: 3321

 

 

Новые статьи:


Популярные:
  1. Как сделать цикличным проигрывание MIDI-файла?
  2. Создание AVI файла из рисунков
  3. Как устройство "отключить в данной конфигурации"?
  4. Kто в данный момент присоединен через Сеть?
  5. Как узнать количество доступной памяти?
  6. Как реализовать в RichEdit разноцветный текст?
  7. Как скрыть свое приложение от ProcessViewer
  8. Как программно нажать/скрыть/показ кнопку "Start"?
  9. Модуль работы с ресурсами в PE файлах
10. Функции вызова диалоговых окон выбора
11. Проверка граматики средствами Word'а из Delphi.
12. Модуль для упрощенного вызова сообщений
13. Функции для записи и чтение своих данных в, ЕХЕ- файле
14. Рекурсивный просмотр директорий
15. Network Traffic Monitor
16. Разные модули
17. Универсальная функция для обращения к любым экспортируем функциям DLL
18. Библиотека от VladS
19. Протектор для UPX'а
20. Еще об ICQ, сообщения по контакт листу?
21. Использование открытых интерфейсов
22. Теория и практика использования RTTI
23. Работа с TApplication
24. Примеры использования Drag and Drop для различных визуальных компонентов
25. Что такое порт? Правила для работы с портами
26. Симфония на клавиатуре
27. Загрузка DLL
28. Исправление автоинкремента
29. Взаимодействие с чужими окнами
30. Проверить дубляжи в столбце


 

 

 
 
На главную