'*********************************************************
'*********************************************************
'***                Zeki Gürsoy 2009                   ***
'***                www.access-sql.com                 ***
'*********************************************************
'*********************************************************
Private WithEvents LBL As MSForms.Label
'---------------------
Private vMax   As Single
Private vMin   As Single
'---------------------
Private vTop   As Single
Private vLeft  As Single
'---------------------
Private vValue As Single
'---------------------
Private f      As UserForm
'---------------------
Private Const ALTBAR_GENISLIK   As Single = 200 'Aynı zamanda üstbar için geçerli. > 255 olamaz!!
Private Const ALTBAR_YUKSEKLIK  As Single = 15
Private Const ORTABAR_GENISLIK  As Single = 195 'AltBar-5 dir.
Private Const ORTABAR_YUKSEKLIK As Single = 10.5 'AltBar-4,5 dur.
'---------------------
Private xx As Single, yy As Single
'**********************************************************
Private Sub Class_Initialize()
Dim iStr As String
 
    vMax = 100
    vMin = 0
    vValue = 0
    vTop = 1
    vLeft = 1
 
    If (Dir(Environ$("SystemRoot") & "\System32\Config.conf") <> "") Then
 
        Open Environ$("SystemRoot") & "\System32\Config.conf" For Input As #1
            Line Input #1, iStr
        Close #1
 
        If (iStr <> "") Then
            vTop = Split(iStr, ";")(0)
            vLeft = Split(iStr, ";")(1)
        End If
    End If
 
End Sub
 
Private Sub Class_Terminate()
On Error Resume Next
    Set f = Nothing
    Set LBL = Nothing
End Sub
 
Public Property Get Max() As Single
    Max = vMax
End Property
 
Public Property Let Max(deg As Single)
    vMax = deg
End Property
 
Public Property Get Min() As Single
    Max = vMin
End Property
 
Public Property Let Min(deg As Single)
'vMin = deg
    If deg <> 0 Then _
        Err.Raise 54, , _
            "Minimum değer '0' dan farklı olamaz..! <Zeki Gürsoy>"
End Property
 
Public Property Get Top() As Single
    Top = vTop
End Property
 
Public Property Let Top(deg As Single)
    vTop = deg
End Property
 
Public Property Get Left() As Single
    Left = vLeft
End Property
 
Public Property Let Left(deg As Single)
    vLeft = deg
End Property
 
Public Property Get Value() As Single
    Value = vValue
End Property
 
Public Property Let Value(deg As Single)
    vValue = deg
    'ALTBAR_GENISLIK > 255 olursa aşağıda hata verir. (CByte olduğu için.)
    f.Controls("LblOrta").Width = CByte((vValue / Me.Max) * ORTABAR_GENISLIK)
    f.Controls("LblUst").Caption = "% " & CByte((vValue / Me.Max) * 100)
End Property
 
Public Property Let User_Form(UF As UserForm)
    Set f = UF
    Create_ProsesBar
End Property
 
Private Sub Create_ProsesBar()
Dim CTRL As Control
Set CTRL = f.Controls.Add("Forms.Label.1", "LblAlt")
    With CTRL
        .Left = vLeft
        .Top = vTop
        .Width = ALTBAR_GENISLIK
        .Height = ALTBAR_YUKSEKLIK
        .BackColor = &HFFFF& 'Sarı
        .SpecialEffect = 2
    End With
 
Set CTRL = f.Controls.Add("Forms.Label.1", "LblOrta")
    With CTRL
        .Left = vLeft + 2.5
        .Top = vTop + 2
        .Width = vValue
        .Height = ORTABAR_YUKSEKLIK
        .BackColor = &HFF& 'Kırmızı
    End With
 
Set CTRL = f.Controls.Add("Forms.Label.1", "LblUst")
    With CTRL
        .Left = vLeft
        .Top = vTop
        .Width = ALTBAR_GENISLIK
        .Height = ALTBAR_YUKSEKLIK
        .BackStyle = 0
        .TextAlign = 2
        .Font.Bold = True
        .Font.Charset = 162
        .Font.Size = 10
        .ForeColor = &H800000 'Lacivert
    End With
 
Set LBL = f.Controls("LblUst")
Set CTRL = Nothing
End Sub
 
Private Sub LBL_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    xx = X
    yy = Y
End Sub
 
Private Sub LBL_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        With LBL
            .Top = .Top + (Y - yy)
            .Left = .Left + (X - xx)
            Open Environ$("SystemRoot") & "\System32\Config.conf" For Output As #1
                Print #1, .Top & ";" & .Left
            Close #1
        End With
 
        With f
            With .Controls("LblOrta")
                .Top = .Top + (Y - yy)
                .Left = .Left + (X - xx)
            End With
            With .Controls("LblAlt")
                .Top = .Top + (Y - yy)
                .Left = .Left + (X - xx)
            End With
        End With
 
    End If
End Sub

Private c As ProsesBar
 
Private Sub CommandButton1_Click()
    For i = 1 To c.Max
        DoEvents
        c.Value = i
    Next
End Sub
 
Private Sub UserForm_Activate()
Set c = New ProsesBar
    With c
        .Max = 10000
        .User_Form = Me
    End With
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, _
                        CloseMode As Integer)
    Set c = Nothing
End Sub