Sie sind aktuell nicht angemeldet.

Funktionen: Einloggen  |  Neu registrieren  |  Suchen

Re: Bist Du sicher,
Autor: Andreasschumann
Datum: 01.05.02 16:28
ach ja der code ist komplett hatte ein benutzersteuerelement vergessen Option Explicit Public Enum BorderStyles [None] = 0 [Fixed Single] = 1 End Enum Private Const DEF_SUFFIX As String = "%" Private Const DEF_BORDERSTYLE As Integer = 1 Private Type GUAGE_DATA Min As Long Max As Long Value As Long Alignment As AlignmentConstants Suffix As String MarkValue As Long UseMark As Boolean MarkColor As Long End Type Private mGuage As GUAGE_DATA ' -- API -- Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Const DT_TOP = &H0 Private Const DT_LEFT = &H0 Private Const DT_CENTER = &H1 Private Const DT_RIGHT = &H2 Private Const DT_VCENTER = &H4 Private Const DT_BOTTOM = &H8 Private Const DT_SINGLELINE = &H20 Private Const DT_CALCRECT = &H400 Private Const DT_NOPREFIX = &H800 Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y 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 CreateSolidBrush Lib "gdi32" (ByVal crColor 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Event MouseDown(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) Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Private Sub UserControl_InitProperties() With UserControl .BorderStyle = DEF_BORDERSTYLE .BackColor = vbWindowBackground .ForeColor = vbBlue End With With mGuage .Min = 0 .Max = 100 .Value = 0 .Alignment = vbCenter .Suffix = DEF_SUFFIX .MarkValue = 0 .UseMark = False End With End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) With PropBag UserControl.BorderStyle = .ReadProperty("BorderStyle", DEF_BORDERSTYLE) UserControl.BackColor = .ReadProperty("BackColor", vbWindowBackground) UserControl.ForeColor = .ReadProperty("ForeColor", vbBlue) UserControl.FillColor = .ReadProperty("FillColor", vbBlue) mGuage.MarkColor = .ReadProperty("MarkColor", vbBlack) ' Set UserControl.Font = .ReadProperty("Font", Ambient.Font) mGuage.Min = .ReadProperty("Min", 0) mGuage.Max = .ReadProperty("Max", 100) mGuage.Value = .ReadProperty("Value", 0) mGuage.Alignment = .ReadProperty("Alignment", vbCenter) mGuage.Suffix = .ReadProperty("Suffix", DEF_SUFFIX) mGuage.MarkValue = .ReadProperty("MarkValue", 0) mGuage.UseMark = .ReadProperty("UseMark", False) End With ' Validate value range If mGuage.Value < mGuage.Min Then mGuage.Value = mGuage.Min ElseIf mGuage.Value > mGuage.Max Then mGuage.Value = mGuage.Max End If If mGuage.MarkValue < mGuage.Min Then mGuage.MarkValue = mGuage.Min ElseIf mGuage.MarkValue > mGuage.Max Then mGuage.MarkValue = mGuage.Max End If End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) With PropBag .WriteProperty "BorderStyle", UserControl.BorderStyle, DEF_BORDERSTYLE .WriteProperty "BackColor", UserControl.BackColor, vbWindowBackground .WriteProperty "ForeColor", UserControl.ForeColor, vbBlue .WriteProperty "FillColor", UserControl.FillColor, vbBlue .WriteProperty "MarkColor", mGuage.MarkColor, vbBlack ' .WriteProperty "Font", UserControl.Font, Ambient.Font .WriteProperty "Min", mGuage.Min, 0 .WriteProperty "Max", mGuage.Max, 100 .WriteProperty "Value", mGuage.Value, 0 .WriteProperty "Alignment", mGuage.Alignment, vbCenter .WriteProperty "Suffix", mGuage.Suffix, DEF_SUFFIX .WriteProperty "MarkValue", mGuage.MarkValue, 0 .WriteProperty "UseMark", mGuage.UseMark, False End With 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_Paint() Dim tRect As RECT, tText As RECT, tMarkText As RECT Dim hWinDC As Long, nWidth As Long, nHeight As Long, wFormat As Long, _ wMarkFormat As Long, nMarkDiff As Long, _ hBrush As Long, nOffset As Long, nRight As Long, nColor As Long, _ nForeColor As Long, nMark As Long Dim sTitle As String, sMarkTitle As String ' Set the text we will draw into a variable sTitle = Trim$(CStr(mGuage.Value) & mGuage.Suffix) ' Work out the co-ords for the percentage bar Call GetClientRect(UserControl.hwnd, tRect) nWidth = tRect.Right nHeight = tRect.Bottom ' If mGuage.Value > mGuage.Min Then nRight = ((nWidth / mGuage.Max) * (mGuage.Value - mGuage.Min)) - 1 Else nRight = -1 End If If mGuage.UseMark Then Select Case mGuage.MarkValue Case mGuage.Min nMark = 0 Case mGuage.Max nMark = nWidth Case mGuage.Min To mGuage.Max nMark = ((nWidth / mGuage.Max) * (mGuage.MarkValue - mGuage.Min)) - 1 Case Else nMark = -1 End Select nMarkDiff = mGuage.Value - mGuage.MarkValue If nMarkDiff <> 0 Then sMarkTitle = IIf(nMarkDiff > 0, "+", "") & Trim$(CStr(nMarkDiff)) wMarkFormat = DT_SINGLELINE + DT_NOPREFIX + DT_VCENTER nOffset = 0 ' Call DrawText(UserControl.hDC, sMarkTitle, Len(sMarkTitle), tText, wMarkFormat + DT_CALCRECT) nOffset = ((tRect.Bottom - tText.Bottom) 2&) - 1 tMarkText = tRect If nOffset > 0 Then Call InflateRect(tMarkText, -nOffset, 0&) If mGuage.Alignment <> vbRightJustify Then tMarkText.Left = tMarkText.Right - tText.Right End If End If ' Remember the DC handle hWinDC = UserControl.hDC ' Calculate text position and format nOffset = 0 wFormat = DT_SINGLELINE + DT_NOPREFIX + DT_VCENTER ' Select Case mGuage.Alignment Case vbRightJustify wFormat = wFormat + DT_RIGHT Case vbCenter wFormat = wFormat + DT_CENTER End Select ' If mGuage.Alignment <> vbCenter Then Call DrawText(hWinDC, sTitle, Len(sTitle), tText, wFormat + DT_CALCRECT) nOffset = ((tRect.Bottom - tText.Bottom) 2&) - 1 End If ' tText = tRect If nOffset > 0 Then Call InflateRect(tText, -nOffset, 0&) nForeColor = UserControl.ForeColor ' Progress fill color If mGuage.Value = mGuage.Max Then UserControl.ForeColor = UserControl.FillColor nColor = (&HFFFFFF Xor GetColor(UserControl.ForeColor)) UserControl.DrawMode = vbCopyPen ' Erase everything by redrawing the background hBrush = CreateSolidBrush(GetColor(UserControl.BackColor)) Call FillRect(hWinDC, tRect, hBrush) Call DeleteObject(hBrush) ' Show the text Call DrawText(hWinDC, sTitle, Len(sTitle), tText, wFormat) If sMarkTitle <> "" Then Call DrawText(hWinDC, sMarkTitle, Len(sMarkTitle), tMarkText, wMarkFormat) ' Show the progress If nRight >= 0 Then UserControl.DrawMode = vbXorPen ' XOr the pen UserControl.Line (0, -1)-(nRight, nHeight), nColor, BF End If If mGuage.UseMark Then UserControl.DrawMode = vbCopyPen UserControl.Line (nMark, -1)-(nMark, nHeight), GetColor(mGuage.MarkColor), BF End If UserControl.ForeColor = nForeColor End Sub Private Function GetColor(ByVal nColor As Long) As Long Const SYSCOLOR_BIT As Long = &H80000000 If (nColor And SYSCOLOR_BIT) = SYSCOLOR_BIT Then nColor = nColor And (Not SYSCOLOR_BIT) GetColor = GetSysColor(nColor) Else GetColor = nColor End If End Function ' ----------------------------------------------------------------------------- Public Property Get BorderStyle() As BorderStyles BorderStyle = UserControl.BorderStyle End Property Public Property Let BorderStyle(ByVal NewValue As BorderStyles) UserControl.BorderStyle = NewValue PropertyChanged "BorderStyle" End Property Public Property Get BackColor() As Long BackColor = UserControl.BackColor End Property Public Property Let BackColor(ByVal NewValue As Long) UserControl.BackColor = NewValue PropertyChanged "BackColor" UserControl_Paint End Property Public Property Get ForeColor() As Long ForeColor = UserControl.ForeColor End Property Public Property Let ForeColor(ByVal NewValue As Long) UserControl.ForeColor = NewValue PropertyChanged "ForeColor" UserControl_Paint End Property Public Property Get MaxColor() As Long MaxColor = UserControl.FillColor End Property Public Property Let MaxColor(ByVal NewValue As Long) UserControl.FillColor = NewValue PropertyChanged "FillColor" UserControl_Paint End Property Public Property Get MarkColor() As Long MarkColor = mGuage.MarkColor End Property Public Property Let MarkColor(ByVal NewValue As Long) mGuage.MarkColor = NewValue PropertyChanged "MarkColor" If mGuage.UseMark Then UserControl_Paint End Property 'Public Property Get Font() As StdFont ' Set Font = UserControl.Font 'End Property 'Public Property Set Font(ByVal NewValue As StdFont) ' Set UserControl.Font = NewValue ' PropertyChanged "Font" ' UserControl_Paint 'End Property Public Property Get Alignment() As AlignmentConstants Alignment = mGuage.Alignment End Property Public Property Let Alignment(ByVal NewValue As AlignmentConstants) mGuage.Alignment = NewValue PropertyChanged "Alignment" UserControl_Paint End Property Public Property Get Suffix() As String Suffix = mGuage.Suffix End Property Public Property Let Suffix(ByVal NewValue As String) mGuage.Suffix = NewValue PropertyChanged "Suffix" UserControl_Paint End Property Public Property Get Min() As Long Min = mGuage.Min End Property Public Property Let Min(ByVal NewValue As Long) If NewValue > mGuage.Max Then Exit Property mGuage.Min = NewValue If mGuage.Value < mGuage.Min Then mGuage.Value = mGuage.Min PropertyChanged "Min" UserControl_Paint End Property Public Property Get Max() As Long Max = mGuage.Max End Property Public Property Let Max(ByVal NewValue As Long) If NewValue < mGuage.Min Then Exit Property mGuage.Max = NewValue If mGuage.Value > mGuage.Max Then mGuage.Value = mGuage.Max PropertyChanged "Max" UserControl_Paint End Property Public Property Get Value() As Long Value = mGuage.Value End Property Public Property Let Value(ByVal NewValue As Long) If NewValue < mGuage.Min Then mGuage.Value = mGuage.Min ElseIf NewValue > mGuage.Max Then mGuage.Value = mGuage.Max Else mGuage.Value = NewValue End If PropertyChanged "Value" UserControl_Paint End Property Public Property Get MarkValue() As Long MarkValue = mGuage.MarkValue End Property Public Property Let MarkValue(ByVal NewValue As Long) mGuage.MarkValue = NewValue PropertyChanged "MarkValue" If mGuage.UseMark Then UserControl_Paint End Property Public Property Get UseMark() As Boolean UseMark = mGuage.UseMark End Property Public Property Let UseMark(ByVal NewValue As Boolean) mGuage.UseMark = NewValue PropertyChanged "UseMark" UserControl_Paint End Property

>>>>>>>FEHLER IM CODE BITTE LESEN<&l...	173	Andreasschumann	01.05.02 13:45
Bist Du sicher,	502	unbekannt	01.05.02 16:05
Re: Bist Du sicher,	160	Andreasschumann	01.05.02 16:28
Re: >>>>>>>FEHLER IM CODE BITTE LESEN&l...	92	Andreasschumann	01.05.02 16:26
Re: >>>>>>>FEHLER IM CODE BITTE LESEN&l...	432	unbekannt	01.05.02 16:48
WinSock???	78	E7	01.05.02 16:43

Sie sind nicht angemeldet! Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden. Einloggen  |  Neu registrieren

Funktionen:  Zum Thema  |  Gesamtübersicht

Suchen