| Вопрос: текст под наклоном | Добавлено: 28.09.04 17:54 |
Автор вопроса:  night-roll
|
|
необходимо написать текст не важно где (на форме, в лейбле ...) только надо под наклоном (наклоном не тем, что а-ля курсив), т.е. нужен наклонный текст, а не наклон букв, текст вдоль наклонной прямой если хотите.
усть другой вариант, повернуть лейбл на определенный угол... КАК это сделать??? ------------------------------------ СПАСИБО! заранее благодарю! з.ы. я говорю только про плоскость! на плоскости, господа! а то придётся занимать ненужным флудом с теми, кто в бронепоезде. БЛАГОДАРЮ ЗА ВНИМАНИЕ. |
| Ответы | Всего ответов: 4 |
|
Номер ответа: 1 Автор ответа:  sne Разработчик Offline Client ICQ: 233286456 Вопросов: 34 Ответов: 5445 |
Web-сайт: Профиль | | #1 | Добавлено: 28.09.04 18:20 |
|
Обычный TextOut, только за шрифтом самому прийдется следить.
Вот возможная реализация контрола: VERSION 5.00 Begin VB.UserControl iLabel AutoRedraw = -1 'True CanGetFocus = 0 'False ClientHeight = 3600 ClientLeft = 0 ClientTop = 0 ClientWidth = 4800 ScaleHeight = 3600 ScaleWidth = 4800 End Attribute VB_Name = "iLabel" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '******************************************************************** '* Написано в 2003 году (Team HomeWork) * '* e-mail: sne_pro@mail.ru * '******************************************************************** Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long Private Declare Function GetWindowPlacement Lib "user32" (ByVal hWnd As Long, lpwndpl As WINDOWPLACEMENT) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fItalic As Long, ByVal fUnderline As Long, ByVal fStrikeOut As Long, ByVal fCharSet As Long, ByVal fOutPrecision As Long, ByVal fClipPrecision As Long, ByVal fQuality As Long, ByVal fPitchAndFamily As Long, ByVal lpszFace As String) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long Private Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long Private Type TEXTMETRIC tmHeight As Long tmAscent As Long tmDescent As Long tmInternalLeading As Long tmExternalLeading As Long tmAveCharWidth As Long tmMaxCharWidth As Long tmWeight As Long tmOverhang As Long tmDigitizedAspectX As Long tmDigitizedAspectY As Long tmFirstChar As Byte tmLastChar As Byte tmDefaultChar As Byte tmBreakChar As Byte tmItalic As Byte tmUnderlined As Byte tmStruckOut As Byte tmPitchAndFamily As Byte tmCharSet As Byte End Type 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 Type Size cx As Long cy As Long End Type Private Type WINDOWPLACEMENT Length As Long Flags As Long showCmd As Long ptMinPosition As POINTAPI ptMaxPosition As POINTAPI rcNormalPosition As RECT End Type Private Type hwTextOut fnSize As Long fnName As String fnBold As Boolean fnItal As Boolean fnUnde As Boolean Escapement As Integer End Type Public Enum gblBorder ilNormal = 0 ilConvex = 1 ilNone = 2 End Enum Public Enum gbUse ShowTime = 0 ShowMoney = 1 End Enum 'Public Enum gbGetTime ' gHours = 0 ' gMinuties = 1 ' gSeconds = 2 ' gRoubles = 3 ' gCopeck = 4 ' gNameValue1 = 5 ' gNameValue2 = 6 'End Enum Private hFnt As Long, _ hOldFnt As Long, _ hwTxtOut As hwTextOut Private m_BorderStyle As gblBorder, _ m_Transp As Boolean, _ m_Value As Currency, _ m_Curr As String, _ m_Use As gbUse, _ m_Text As String Private Const Square = &H1 Or &H2 Or &H4 Or &H8 Private Const pi As Double = 3.1415926 Public Event Click() Public Event DblClick() Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) '// ----------------------------------------------------------------------------- Private Function SetFont(Optional fName As String = "MS Sans Serif", Optional Size As Long = 8, Optional Bold As Boolean = False, Optional Italic As Boolean = False, Optional UnderLine As Boolean = False, Optional fColor As ColorConstants = vbBlack, Optional Escapement As Integer = 0) As Long If hFnt Then Call DelFont hFnt = CreateFont(IIf(Size, Size, 8), 0&, Escapement, 0&, IIf(Bold, 700, 400), Italic, UnderLine, 0&, &H1, 0&, 0&, 0&, 0&, fName) hOldFnt = SelectObject(UserControl.hdc, hFnt) SetFont = SetTextColor(UserControl.hdc, fColor) End Function Private Sub DelFont() Call SelectObject(UserControl.hdc, hOldFnt) Call DeleteObject(hFnt): hFnt = 0 Call SetTextColor(UserControl.hdc, vbBlack) End Sub Private Function ChangeFont(lColor As Long) As Long ChangeFont = SetFont(hwTxtOut.fnName, hwTxtOut.fnSize, hwTxtOut.fnBold, hwTxtOut.fnItal, hwTxtOut.fnUnde, lColor, hwTxtOut.Escapement) End Function Public Sub SetFontParam(Optional fName As String = "MS Sans Serif", Optional Size As Long = 15, Optional Bold As Boolean = False, Optional Italic As Boolean = False, Optional UnderLine As Boolean = False, Optional Escapement As Integer = 0& 
With hwTxtOut .fnName = fName .fnSize = Size .fnBold = Bold .fnItal = Italic .fnUnde = UnderLine .Escapement = Escapement End With  rawControl
End Sub '// ----------------------------------------------------------------------------- Private Sub UserControl_Click() RaiseEvent Click End Sub Private Sub UserControl_DblClick() RaiseEvent DblClick End Sub Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseDown(Button, Shift, X, Y) End Sub Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseMove(Button, Shift, X, Y) End Sub Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseUp(Button, Shift, X, Y) End Sub '// ----------------------------------------------------------------------------- Private Sub UserControl_Resize() rawControl
End Sub Private Sub UserControl_Show() UserControl_Resize End Sub '// ----------------------------------------------------------------------------- Public Property Get BorderStyle() As gblBorder BorderStyle = m_BorderStyle End Property Public Property Let BorderStyle(NewValue As gblBorder) m_BorderStyle = NewValue: DrawControl End Property Public Property Get BackColor() As OLE_COLOR BackColor = UserControl.BackColor End Property Public Property Let BackColor(NewValue As OLE_COLOR) UserControl.BackColor = NewValue: DrawControl End Property Public Property Get ForeColor() As OLE_COLOR ForeColor = UserControl.ForeColor End Property Public Property Let ForeColor(NewValue As OLE_COLOR) UserControl.ForeColor = NewValue: DrawControl End Property Public Property Get Transparent() As Boolean Transparent = m_Transp End Property Public Property Let Transparent(NewValue As Boolean) m_Transp = NewValue: DrawControl End Property Public Property Get Value() As Currency Value = m_Value End Property Public Property Let Value(NewValue As Currency) m_Value = NewValue: DrawControl End Property Public Property Get Curr() As String Curr = m_Curr End Property Public Property Let Curr(NewValue As String) If Len(NewValue) = 0 Then NewValue = ".;." m_Curr = NewValue: Call DrawControl End Property Public Property Get Used() As gbUse Used = m_Use End Property Public Property Let Used(New_Use As gbUse) m_Use = New_Use: DrawControl End Property Public Property Get MouseIcon() As Picture Set MouseIcon = UserControl.MouseIcon End Property Public Property Set MouseIcon(ByVal New_MouseIcon As Picture) Set UserControl.MouseIcon = New_MouseIcon End Property Public Property Get MousePointer() As MousePointerConstants MousePointer = UserControl.MousePointer End Property Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants) UserControl.MousePointer() = New_MousePointer End Property Public Property Get hWnd() As Long hWnd = UserControl.hWnd End Property '// ----------------------------------------------------------------------------- Private Sub UserControl_ReadProperties(PropBag As PropertyBag) UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F) m_BorderStyle = PropBag.ReadProperty("BorderStyle", 0) UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012) Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing) UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0) m_Value = PropBag.ReadProperty("Value", 0) m_Use = PropBag.ReadProperty("Used", 0) m_Curr = PropBag.ReadProperty("Curr", ".;."
m_Transp = PropBag.ReadProperty("Transparent", False) End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F) Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, 0) Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012) Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing) Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0) Call PropBag.WriteProperty("Value", m_Value, 0) Call PropBag.WriteProperty("Used", m_Use, 0) Call PropBag.WriteProperty("Curr", m_Curr, ".;."
Call PropBag.WriteProperty("Transparent", m_Transp, False) End Sub '// ----------------------------------------------------------------------------- Public Sub DrawControl() On Error Resume Next im WinPl As WINDOWPLACEMENT, Rgn As RECT, TxtWH As Size, txt As TEXTMETRIC, s As Long
With UserControl .Cls If m_Transp Then _ WinPl.Length = Len(WinPl): _ Call GetWindowPlacement(.hWnd, WinPl): _ Call BitBlt(.hdc, 0, 0, .Width / Screen.TwipsPerPixelX, .Height / Screen.TwipsPerPixelY, .Parent.hdc, WinPl.rcNormalPosition.Left, WinPl.rcNormalPosition.Top, vbSrcCopy) Call GetClientRect(UserControl.hWnd, Rgn) If Not m_BorderStyle = ilNone Then Call DrawEdge(UserControl.hdc, Rgn, IIf(m_BorderStyle = ilNormal, 2, 4), Square) If m_Use = ShowTime Then m_Text = TimeCounter Else m_Text = MoneyCounter Call SetTextAlign(.hdc, 6& Or 24& Or 0&
Call ChangeFont(.ForeColor) Call GetTextExtentPoint32(.hdc, m_Text, Len(m_Text), TxtWH) Call GetTextMetrics(.hdc, txt) s = hwTxtOut.fnSize * (txt.tmDescent / txt.tmAscent) Call TextOut(.hdc, (Rgn.Right - Rgn.Left) \ 2 + s * Cos(hwTxtOut.Escapement / 1800 * pi - pi / 2), (Rgn.Bottom - Rgn.Top) \ 2 - s * Sin(hwTxtOut.Escapement / 1800 * pi - pi / 2) + IIf(m_Use = ShowTime, 1, 0), m_Text, Len(m_Text)) End With End Sub Private Function TimeCounter(Optional Hour As Long, Optional Min As Long, Optional Sec As Long) As String Hour = m_Value \ 3600: Min = Abs((m_Value \ 60) Mod 60): Sec = Abs(m_Value Mod 60) TimeCounter = Format$(Hour & ":" & Min & ":" & Sec, "hh:mm:ss"
End Function Private Function MoneyCounter(Optional Rouble As String, Optional Copeck As String) As String If Not m_Use = ShowMoney Then Exit Function im r As Long, c As Long
r = m_Value \ 100: c = Abs(m_Value - r * 100) Rouble = r: Copeck = Format$(c, "00"
MoneyCounter = Rouble & Split(m_Curr, ";" (0) & Copeck & Split(m_Curr, ";"(1)
End Function Public Function Text() As String Text = m_Text End Function Public Function GetIlabelInfo(Index As Long) As Long Select Case Index Case Is = 0: Call TimeCounter(, , GetIlabelInfo) Case Is = 1: Call TimeCounter(, GetIlabelInfo) End Select End Function |
||
|
Номер ответа: 2 Автор ответа: AgentFireICQ: 192496851 Вопросов: 75 Ответов: 3178 |
Профиль | | #2 | Добавлено: 28.09.04 23:09 |
|
[B][I]
УУУУУУУУУУУХХХХХХХХХХХХХХХХХХХ!!!!!!!!!!!!!!!!!!!!!!! НИ ФИГА БЛИН!!!!!! [/B][/I] |
||
|
Номер ответа: 3 Автор ответа: sneРазработчик Offline Client ICQ: 233286456 Вопросов: 34 Ответов: 5445 |
Web-сайт: Профиль | | #3 | Добавлено: 28.09.04 23:15 |
Павел, исправляй баги = теги, срочно  ))
|
||
|
Номер ответа: 4 Автор ответа: night-roll Вопросов: 36 Ответов: 326 |
Профиль | | #4 | Добавлено: 24.10.04 12:52 |
|
нашёл! пример! (правда осх)
качайте: http://vbcorner.narod.ru/control/rotlabel.zip или пишите мне вышлю! всем спасибо! |
||
Страница: 1 |