Инженер
Профиль
Группа: Экс. модератор
Сообщений: 6003
Регистрация: 26.3.2002
Где: Германия
Репутация: 19
Всего: 99
|
Если вам будет интерестно писал я здесь как то прогу чтобы в форме в свойстве каптион можно было выводить текст и чтобы он был например по середине итд итп выравнивание.. но меня больше инетересовал Юникод.. чтобы китйские знаки показывал  добавит 6 оптиона и две кнопки вот и всё в принципе что надо... а код такой в форме | Код |
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
|
может быть кому интерестно будет посмотреть как работает |
Как отформатировать текст в свойство Caption формы? 
Загрузка ...
