精华内容
下载资源
问答
  • 界面:

    界面:

    展开全文
  • VB自制进度条控件

    2021-03-22 18:00:47
    一、“添加用户控件”,命名为"ProgressBar",代码如下: Option Explicit Public Enum U_TextAlignments ...[Center Bottom] = 6 [Right Top] = 7 [Right Middle] = 8 [Right Bottom] = 9 End Enum Publi.

    在这里插入图片描述

    一、“添加用户控件”,命名为"ProgressBar",代码如下:
    Option Explicit

    Public Enum U_TextAlignments
    [Left Top] = 1
    [Left Middle] = 2
    [Left Bottom] = 3
    [Center Top] = 4
    [Center Middle] = 5
    [Center Bottom] = 6
    [Right Top] = 7
    [Right Middle] = 8
    [Right Bottom] = 9
    End Enum

    Public Enum U_TextEffects
    [Normal] = 1
    [Embossed] = 2
    [Engraved] = 3
    [OutLine] = 4
    [Shadow] = 5
    End Enum

    Public Enum U_OrientationsS
    [Horizontal] = 1
    [Vertical] = 2

    End Enum

    Public Enum U_TextStyles
    [PBValue] = 1
    [PBPercentage] = 2
    [CustomText] = 3
    [PBNoneText] = 4
    End Enum

    Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
    End Type

    Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
    End Type

    Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
    End Type

    Private Type cRGB
    Blue As Byte
    Green As Byte
    Red As Byte
    End Type

    Enum U_Themes
    [IceOrange] = 1
    [IceYellow] = 2
    [IceGreen] = 3
    [IceCyan] = 4
    [IceBangel] = 5
    [IcePurple] = 6
    [IceRed] = 7
    [IceBlue] = 8
    [Vista] = 9
    [Custome] = 10
    End Enum
    Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
    End Type

    Public Enum GRADIENT_DIRECT
    [Left to Right] = &H0
    [Top to Bottom] = &H1
    End Enum

    Private Type TRIVERTEX
    x As Long
    y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
    End Type

    Private Declare Function CreateRoundRectRgn Lib “gdi32” (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
    Private Declare Function SetWindowRgn Lib “user32” (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
    Private Declare Function RoundRect Lib “gdi32” (ByVal hDC As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
    Private Declare Function SetDIBitsToDevice Lib “gdi32” (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
    Private Declare Function GradientFillRect Lib “msimg32” Alias “GradientFill” (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
    Private Declare Function SetRect Lib “user32” (lpRect As RECT, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long

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

    Const GRADIENT_FILL_RECT_H As Long = &H0
    Const GRADIENT_FILL_RECT_V As Long = &H1
    Private Const BI_RGB = 0&
    Private Const DIB_RGB_COLORS = 0

    Private U_TextStyle As U_TextStyles
    Private U_Theme As U_Themes
    Private U_Orientation As U_OrientationsS
    Private U_Text As String
    Private U_TextColor As OLE_COLOR
    Private U_TextAlign As U_TextAlignments
    Private U_TextFont As Font
    Private U_TextEC As OLE_COLOR
    Private U_TextEffect As U_TextEffects
    Private U_RoundV As Long
    Private U_Min As Long
    Private U_Value As Long
    Private U_Max As Long
    Private U_Enabled As Boolean
    Private c(16) As Long
    Private U_PBSCC1 As OLE_COLOR
    Private U_PBSCC2 As OLE_COLOR

    Private Sub UserControl_Initialize()
    UserControl.AutoRedraw = True
    End Sub

    Private Sub UserControl_Resize()
    Bar_Draw
    End Sub

    Public Property Let Value(ByVal NewValue As Long)
    If NewValue > U_Max Then NewValue = U_Max
    If NewValue < U_Min Then NewValue = U_Min
    U_Value = NewValue

    PropertyChanged "Value"
    Bar_Draw
    

    End Property

    Public Property Get Value() As Long
    Value = U_Value
    End Property

    Public Property Let Max(ByVal NewValue As Long)
    If NewValue < 1 Then NewValue = 1
    If NewValue <= U_Min Then NewValue = U_Min + 1
    U_Max = NewValue
    If Value > U_Max Then Value = U_Max
    PropertyChanged “Max”
    Bar_Draw
    End Property
    Public Property Get Max() As Long
    Max = U_Max
    End Property

    Public Property Let Min(ByVal NewValue As Long)
    If NewValue >= U_Max Then NewValue = Max - 1
    If NewValue < 0 Then NewValue = 0
    U_Min = NewValue
    If Value < U_Min Then Value = U_Min

    PropertyChanged "Min"
    Bar_Draw
    

    End Property
    Public Property Get Min() As Long
    Min = U_Min
    End Property
    Public Property Get RoundedValue() As Long
    RoundedValue = U_RoundV
    End Property

    Public Property Let RoundedValue(ByVal NewValue As Long)
    U_RoundV = NewValue
    PropertyChanged “RoundedValue”
    Bar_Draw
    End Property

    Public Property Get Enabled() As Boolean
    Enabled = U_Enabled
    End Property

    Public Property Let Enabled(ByVal NewValue As Boolean)
    U_Enabled = NewValue
    PropertyChanged “Enabled”
    Bar_Draw
    End Property
    Private Sub UserControl_InitProperties()
    Max = 100
    Min = 0
    Value = 50
    RoundedValue = 5
    Enabled = True
    Theme = 1
    TextForeColor = vbBlack
    Text = “U11D ProgressBar”
    TextAlignment = [Center Middle]
    TextEffect = Shadow
    TextEffectColor = vbWhite
    TextStyle = CustomText
    Orientations = Horizontal
    Set TextFont = Ambient.Font
    End Sub
    Public Property Let Theme(ByVal NewValue As U_Themes)

    U_Theme = NewValue
    PropertyChanged "Theme"
    

    Bar_Draw
    End Property

    Public Property Get Theme() As U_Themes
    Theme = U_Theme
    End Property

    Public Property Let TextStyle(ByVal NewValue As U_TextStyles)
    U_TextStyle = NewValue
    PropertyChanged “TextStyle”
    Bar_Draw
    End Property
    Public Property Get TextStyle() As U_TextStyles
    TextStyle = U_TextStyle
    End Property

    Public Property Get Orientations() As U_OrientationsS
    Orientations = U_Orientation
    End Property

    Public Property Let Orientations(ByVal NewValue As U_OrientationsS)
    U_Orientation = NewValue
    PropertyChanged “Orientations”
    Bar_Draw
    End Property

    Public Property Get TextAlignment() As U_TextAlignments
    TextAlignment = U_TextAlign
    End Property

    Public Property Let TextAlignment(ByVal NewValue As U_TextAlignments)
    U_TextAlign = NewValue
    PropertyChanged “TextAlignment”
    Bar_Draw
    End Property

    Public Property Get Text() As String
    Text = U_Text
    End Property

    Public Property Let Text(ByVal NewValue As String)
    U_Text = NewValue
    PropertyChanged “Text”
    Bar_Draw
    End Property
    Public Property Get TextEffectColor() As OLE_COLOR
    TextEffectColor = U_TextEC
    End Property

    Public Property Let TextEffectColor(ByVal NewValue As OLE_COLOR)
    U_TextEC = NewValue
    PropertyChanged “TextEffectColor”
    Bar_Draw
    End Property

    Public Property Get TextEffect() As U_TextEffects
    TextEffect = U_TextEffect
    End Property

    Public Property Let TextEffect(ByVal NewValue As U_TextEffects)
    U_TextEffect = NewValue
    PropertyChanged “TextEffect”
    Bar_Draw
    End Property

    Public Property Get TextForeColor() As OLE_COLOR
    TextForeColor = U_TextColor
    End Property

    Public Property Let TextForeColor(ByVal NewValue As OLE_COLOR)
    U_TextColor = NewValue
    PropertyChanged “TextForeColor”
    Bar_Draw
    End Property
    Public Property Get TextFont() As Font
    Set TextFont = U_TextFont
    End Property

    Public Property Set TextFont(ByVal NewValue As Font)
    Set U_TextFont = NewValue
    Set UserControl.Font = NewValue
    PropertyChanged “TextFont”
    Bar_Draw
    End Property

    Public Property Get PBSCustomeColor1() As OLE_COLOR
    PBSCustomeColor1 = U_PBSCC1
    End Property

    Public Property Let PBSCustomeColor1(ByVal NewValue As OLE_COLOR)
    U_PBSCC1 = NewValue
    PropertyChanged “PBSCustomeColor1”
    Bar_Draw
    End Property
    Public Property Get PBSCustomeColor2() As OLE_COLOR
    PBSCustomeColor2 = U_PBSCC2
    End Property

    Public Property Let PBSCustomeColor2(ByVal NewValue As OLE_COLOR)
    U_PBSCC2 = NewValue
    PropertyChanged “PBSCustomeColor2”
    Bar_Draw
    End Property
    Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    On Error Resume Next
    With PropBag

    Max = .ReadProperty("Max", 100)
    Min = .ReadProperty("Min", 0)
    Value = .ReadProperty("Value", 50)
    RoundedValue = .ReadProperty("RoundedValue", 5)
    Enabled = .ReadProperty("Enabled", True)
    Theme = .ReadProperty("Theme", 1)
    TextStyle = .ReadProperty("TextStyle", 1)
    Orientations = .ReadProperty("Orientations", Horizontal)
    Text = .ReadProperty("Text", Ambient.DisplayName)
    TextEffectColor = .ReadProperty("TextEffectColor", RGB(200, 200, 200))
    TextEffect = .ReadProperty("TextEffect", 1)
    TextAlignment = .ReadProperty("TextAlignment", 5)
    Set TextFont = .ReadProperty("TextFont", Ambient.Font)
    TextForeColor = .ReadProperty("TextForeColor", 0)
    PBSCustomeColor2 = .ReadProperty("PBSCustomeColor2", vbBlack)
    PBSCustomeColor1 = .ReadProperty("PBSCustomeColor1", vbBlack)
    End With
    

    End Sub

    Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    With PropBag
    .WriteProperty “Orientations”, U_Orientation, Horizontal
    .WriteProperty “Max”, U_Max, 100
    .WriteProperty “Min”, U_Min, 0
    .WriteProperty “Value”, U_Value, 50
    .WriteProperty “RoundedValue”, U_RoundV, 5
    .WriteProperty “Enabled”, U_Enabled, True
    .WriteProperty “Theme”, U_Theme, 1
    .WriteProperty “TextStyle”, U_TextStyle, 1
    .WriteProperty “TextFont”, U_TextFont, Ambient.Font
    .WriteProperty “TextForeColor”, U_TextColor, vbBlack
    .WriteProperty “TextAlignment”, U_TextAlign, 5
    .WriteProperty “Text”, U_Text, “”
    .WriteProperty “TextEffectColor”, U_TextEC, RGB(200, 200, 200)
    .WriteProperty “TextEffect”, U_TextEffect, 1
    .WriteProperty “PBSCustomeColor2”, U_PBSCC2, vbBlack
    .WriteProperty “PBSCustomeColor1”, U_PBSCC1, vbBlack
    End With
    End Sub

    Private Sub Bar_Draw()
    On Error Resume Next
    Dim i, S, z, y, q As Long
    Dim U_LRECT As Long

    U_LRECT = CreateRoundRectRgn(0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, U_RoundV, U_RoundV)
    SetWindowRgn UserControl.hwnd, U_LRECT, True

    i = U_Max: S = U_Value: z = U_Max
    y = (S * 100 / z)
    q = (y * UserControl.ScaleWidth / 100)
    

    If Orientations = Vertical Then q = (y * UserControl.ScaleHeight / 100)

    CheckTheme

    If Enabled = False Then
    Dim II As Byte
    For II = 0 To 16
    c(II) = ColourTOGray(c(II))
    Next II
    End If

    UserControl.Cls

    If U_Orientation = Horizontal Then

    GradientTwoColour UserControl.hDC, [Top to Bottom], c(0), c(2), 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight / 2
    GradientTwoColour UserControl.hDC, [Top to Bottom], c(4), c(6), 0, UserControl.ScaleHeight / 2, UserControl.ScaleWidth, UserControl.ScaleHeight

    'DrawGradientFourColour UserControl.hDC, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight / 2, c(0), c(1), c(2), c(3)
    'DrawGradientFourColour UserControl.hDC, 0, UserControl.ScaleHeight / 2, UserControl.ScaleWidth, UserControl.ScaleHeight / 2 - 1, c(4), c(5), c(6), c(7)

    If Value >= 1 Then

    GradientTwoColour UserControl.hDC, [Top to Bottom], c(8), c(10), 0, 0, q, UserControl.ScaleHeight / 2
    GradientTwoColour UserControl.hDC, [Top to Bottom], c(12), c(14), 0, UserControl.ScaleHeight / 2, q, UserControl.ScaleHeight
    'DrawGradientFourColour UserControl.hDC, 0, 0, q, UserControl.ScaleHeight / 2, c(8), c(9), c(10), c(11)
    'DrawGradientFourColour UserControl.hDC, 0, UserControl.ScaleHeight / 2, q, UserControl.ScaleHeight / 2 - 1, c(12), c(13), c(14), c(15)
    End If

    ElseIf U_Orientation = Vertical Then

    GradientTwoColour UserControl.hDC, [Left to Right], c(0), c(2), 0, 0, UserControl.ScaleWidth / 2, UserControl.ScaleHeight
    GradientTwoColour UserControl.hDC, [Left to Right], c(4), c(6), UserControl.ScaleWidth / 2, 0, UserControl.ScaleWidth, UserControl.ScaleHeight

    'DrawGradientFourColour UserControl.hDC, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight / 2, c(0), c(1), c(2), c(3)
    'DrawGradientFourColour UserControl.hDC, 0, UserControl.ScaleHeight / 2, UserControl.ScaleWidth, UserControl.ScaleHeight / 2 - 1, c(4), c(5), c(6), c(7)

    If Value >= 1 Then

    GradientTwoColour UserControl.hDC, [Left to Right], c(8), c(10), 0, 0, UserControl.ScaleWidth / 2, q
    GradientTwoColour UserControl.hDC, [Left to Right], c(12), c(14), UserControl.ScaleWidth / 2, 0, UserControl.ScaleWidth, q
    'DrawGradientFourColour UserControl.hDC, 0, 0, q, UserControl.ScaleHeight / 2, c(8), c(9), c(10), c(11)
    'DrawGradientFourColour UserControl.hDC, 0, UserControl.ScaleHeight / 2, q, UserControl.ScaleHeight / 2 - 1, c(12), c(13), c(14), c(15)
    End If
    End If

    UserControl.ForeColor = c(16)
    RoundRect UserControl.hDC, 0, 0, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1, U_RoundV, U_RoundV

    If TextStyle = PBValue Then
    DrawCaptionText Value, U_TextAlign
    ElseIf TextStyle = PBPercentage Then
    DrawCaptionText y & “%”, U_TextAlign
    ElseIf TextStyle = CustomText Then
    DrawCaptionText U_Text, U_TextAlign
    ElseIf TextStyle = PBNoneText Then
    End If
    End Sub

    Private Sub CheckTheme()
    If Theme = 1 Then
    'BACK
    c(0) = RGB(248, 246, 242)
    c(1) = RGB(248, 246, 242)
    c(2) = RGB(233, 227, 211)
    c(3) = RGB(233, 227, 211)

    c(4) = RGB(226, 215, 182)
    c(5) = RGB(226, 215, 182)
    c(6) = RGB(239, 233, 215)
    c(7) = RGB(239, 233, 215)
    'FRONT
    c(8) = RGB(251, 244, 223)
    c(9) = RGB(251, 244, 223)
    c(10) = RGB(239, 213, 133)
    c(11) = RGB(239, 213, 133)

    c(12) = RGB(203, 166, 57)
    c(13) = RGB(203, 166, 57)
    c(14) = RGB(237, 224, 187)
    c(15) = RGB(237, 224, 187)
    'FORE COLOUR
    c(16) = RGB(204, 168, 62)
    ElseIf Theme = 2 Then
    'BACK
    c(0) = RGB(247, 248, 242)
    c(1) = RGB(247, 248, 242)
    c(2) = RGB(231, 233, 211)
    c(3) = RGB(231, 233, 211)

    c(4) = RGB(222, 226, 182)
    c(5) = RGB(222, 226, 182)
    c(6) = RGB(237, 239, 215)
    c(7) = RGB(237, 239, 215)
    'FRONT
    c(8) = RGB(249, 251, 223)
    c(9) = RGB(249, 251, 223)
    c(10) = RGB(230, 239, 133)
    c(11) = RGB(230, 239, 133)

    c(12) = RGB(190, 203, 57)
    c(13) = RGB(190, 203, 57)
    c(14) = RGB(233, 237, 187)
    c(15) = RGB(233, 237, 187)
    'FORE COLOUR
    c(16) = RGB(192, 204, 62)
    ElseIf Theme = 3 Then
    'BACK
    c(0) = RGB(242, 248, 243)
    c(1) = RGB(242, 248, 243)
    c(2) = RGB(211, 233, 213)
    c(3) = RGB(211, 233, 213)

    c(4) = RGB(182, 226, 186)
    c(5) = RGB(182, 226, 186)
    c(6) = RGB(215, 239, 217)
    c(7) = RGB(215, 239, 217)
    'FRONT
    c(8) = RGB(223, 251, 225)
    c(9) = RGB(223, 251, 225)
    c(10) = RGB(133, 239, 142)
    c(11) = RGB(133, 239, 142)

    c(12) = RGB(57, 203, 70)
    c(13) = RGB(57, 203, 70)
    c(14) = RGB(187, 237, 191)
    c(15) = RGB(187, 237, 191)
    'FORE COLOUR
    c(16) = RGB(62, 204, 74)
    ElseIf Theme = 4 Then
    'BACK
    c(0) = RGB(242, 248, 247)
    c(1) = RGB(242, 248, 247)
    c(2) = RGB(211, 233, 231)
    c(3) = RGB(211, 233, 231)

    c(4) = RGB(182, 226, 222)
    c(5) = RGB(182, 226, 222)
    c(6) = RGB(215, 239, 237)
    c(7) = RGB(215, 239, 237)
    'FRONT
    c(8) = RGB(223, 251, 249)
    c(9) = RGB(223, 251, 249)
    c(10) = RGB(133, 239, 230)
    c(11) = RGB(133, 239, 230)

    c(12) = RGB(57, 203, 190)
    c(13) = RGB(57, 203, 190)
    c(14) = RGB(187, 237, 233)
    c(15) = RGB(187, 237, 233)
    'FORE COLOUR
    c(16) = RGB(62, 204, 192)
    ElseIf Theme = 5 Then
    'BACK
    c(0) = RGB(243, 242, 248)
    c(1) = RGB(243, 242, 248)
    c(2) = RGB(213, 211, 233)
    c(3) = RGB(213, 211, 233)

    c(4) = RGB(186, 182, 226)
    c(5) = RGB(186, 182, 226)
    c(6) = RGB(217, 215, 239)
    c(7) = RGB(217, 215, 239)
    'FRONT
    c(8) = RGB(225, 223, 251)
    c(9) = RGB(225, 223, 251)
    c(10) = RGB(142, 133, 239)
    c(11) = RGB(142, 133, 239)

    c(12) = RGB(70, 57, 203)
    c(13) = RGB(70, 57, 203)
    c(14) = RGB(191, 187, 237)
    c(15) = RGB(191, 187, 237)
    'FORE COLOUR
    c(16) = RGB(74, 62, 204)
    ElseIf Theme = 6 Then
    'BACK
    c(0) = RGB(248, 242, 247)
    c(1) = RGB(248, 242, 247)
    c(2) = RGB(233, 211, 231)
    c(3) = RGB(233, 211, 231)

    c(4) = RGB(226, 182, 222)
    c(5) = RGB(226, 182, 222)
    c(6) = RGB(239, 215, 237)
    c(7) = RGB(239, 215, 237)
    'FRONT
    c(8) = RGB(251, 223, 249)
    c(9) = RGB(251, 223, 249)
    c(10) = RGB(239, 133, 230)
    c(11) = RGB(239, 133, 230)

    c(12) = RGB(203, 57, 190)
    c(13) = RGB(203, 57, 190)
    c(14) = RGB(237, 187, 233)
    c(15) = RGB(237, 187, 233)
    'FORE COLOUR
    c(16) = RGB(204, 62, 192)
    ElseIf Theme = 7 Then
    'BACK
    c(0) = RGB(248, 242, 242)
    c(1) = RGB(248, 242, 242)
    c(2) = RGB(233, 211, 211)
    c(3) = RGB(233, 211, 211)

    c(4) = RGB(226, 182, 182)
    c(5) = RGB(226, 182, 182)
    c(6) = RGB(239, 215, 215)
    c(7) = RGB(239, 215, 215)
    'FRONT
    c(8) = RGB(251, 223, 223)
    c(9) = RGB(251, 223, 223)
    c(10) = RGB(239, 133, 133)
    c(11) = RGB(239, 133, 133)

    c(12) = RGB(203, 57, 57)
    c(13) = RGB(203, 57, 57)
    c(14) = RGB(237, 187, 187)
    c(15) = RGB(237, 187, 187)
    'FORE COLOUR
    c(16) = RGB(204, 62, 62)
    ElseIf Theme = 8 Then
    'BACK
    c(0) = RGB(250, 253, 254)
    c(1) = RGB(250, 253, 254)
    c(2) = RGB(228, 243, 252)
    c(3) = RGB(228, 243, 252)

    c(4) = RGB(199, 230, 249)
    c(5) = RGB(199, 230, 249)
    c(6) = RGB(237, 247, 253)
    c(7) = RGB(237, 247, 253)
    'FRONT
    c(8) = RGB(225, 247, 255)
    c(9) = RGB(225, 247, 255)
    c(10) = RGB(67, 208, 255)
    c(11) = RGB(67, 208, 255)

    c(12) = RGB(63, 112, 233)
    c(13) = RGB(63, 112, 233)
    c(14) = RGB(63, 226, 246)
    c(15) = RGB(63, 226, 246)
    'FORE COLOUR
    c(16) = RGB(23, 139, 211)
    ElseIf Theme = 9 Then
    'BACK
    c(0) = RGB(231, 243, 232)
    c(1) = RGB(231, 243, 232)
    c(2) = RGB(225, 219, 225)
    c(3) = RGB(225, 219, 225)

    c(4) = RGB(179, 189, 179)
    c(5) = RGB(179, 189, 179)
    c(6) = RGB(226, 238, 226)
    c(7) = RGB(226, 238, 226)
    'FRONT
    c(8) = RGB(223, 251, 223)
    c(9) = RGB(223, 251, 223)
    c(10) = RGB(108, 255, 108)
    c(11) = RGB(108, 255, 108)

    c(12) = RGB(26, 228, 26)
    c(13) = RGB(26, 228, 26)
    c(14) = RGB(217, 244, 217)
    c(15) = RGB(217, 244, 217)
    'FORE COLOUR
    c(16) = RGB(188, 184, 188)
    ElseIf Theme = 10 Then

    'BACK
    c(0) = LightenColor(U_PBSCC2, 180)
    c(1) = LightenColor(U_PBSCC2, 180)
    c(2) = LightenColor(U_PBSCC2, 50)
    c(3) = LightenColor(U_PBSCC2, 50)

    c(4) = U_PBSCC2
    c(5) = U_PBSCC2
    c(6) = LightenColor(U_PBSCC2, 80)
    c(7) = LightenColor(U_PBSCC2, 80)
    'FRONT
    c(8) = LightenColor(U_PBSCC1, 180)
    c(9) = LightenColor(U_PBSCC1, 180)
    c(10) = LightenColor(U_PBSCC1, 50)
    c(11) = LightenColor(U_PBSCC1, 50)

    c(12) = U_PBSCC1
    c(13) = U_PBSCC1
    c(14) = LightenColor(U_PBSCC1, 80)
    c(15) = LightenColor(U_PBSCC1, 80)
    'FORE COLOUR
    c(16) = U_PBSCC1
    End If
    End Sub

    Private Sub DrawCaptionText(ByVal TextString As String, ByVal Alignment As U_TextAlignments)
    Dim lonStartWidth As Long, lonStartHeight As Long
    Dim PBTCN, PBTCS As Long

    If Enabled = True Then
    PBTCN = U_TextColor
    PBTCS = U_TextEC
    Else
    PBTCN = ColourTOGray(U_TextColor)
    PBTCS = ColourTOGray(U_TextEC)
    End If

    UserControl.ForeColor = PBTCN

    If Alignment = 1 Then
    lonStartWidth = 1
    lonStartHeight = 0
    ElseIf Alignment = 2 Then
    lonStartWidth = 1
    lonStartHeight = (UserControl.ScaleHeight / 2) - (UserControl.TextHeight(TextString) / 2) - 1
    ElseIf Alignment = 3 Then
    lonStartWidth = 1
    lonStartHeight = (UserControl.ScaleHeight - UserControl.TextHeight(TextString)) - 1

    ElseIf Alignment = 4 Then
    lonStartWidth = (UserControl.ScaleWidth / 2) - (UserControl.TextWidth(TextString) / 2) - 1
    lonStartHeight = 0
    ElseIf Alignment = 5 Then
    lonStartWidth = (UserControl.ScaleWidth / 2) - (UserControl.TextWidth(TextString) / 2) - 1
    lonStartHeight = (UserControl.ScaleHeight / 2) - (UserControl.TextHeight(TextString) / 2) - 1
    ElseIf Alignment = 6 Then
    lonStartWidth = (UserControl.ScaleWidth / 2) - (UserControl.TextWidth(TextString) / 2) - 1
    lonStartHeight = (UserControl.ScaleHeight - UserControl.TextHeight(TextString)) - 1

    ElseIf Alignment = 7 Then
    lonStartWidth = (UserControl.ScaleWidth - UserControl.TextWidth(TextString)) - 3
    lonStartHeight = 0
    ElseIf Alignment = 8 Then
    lonStartWidth = (UserControl.ScaleWidth - UserControl.TextWidth(TextString)) - 3
    lonStartHeight = (UserControl.ScaleHeight / 2) - (UserControl.TextHeight(TextString) / 2) - 1
    ElseIf Alignment = 9 Then
    lonStartWidth = (UserControl.ScaleWidth - UserControl.TextWidth(TextString)) - 3
    lonStartHeight = (UserControl.ScaleHeight - UserControl.TextHeight(TextString)) - 1
    End If

    If U_TextEffect = Normal Then
        UserControl.CurrentX = lonStartWidth
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
    ElseIf U_TextEffect = Engraved Then
        UserControl.ForeColor = PBTCS
        UserControl.CurrentX = lonStartWidth + 1
        UserControl.CurrentY = lonStartHeight + 1
        UserControl.Print TextString
        UserControl.ForeColor = RGB(128, 128, 128)
        UserControl.CurrentX = lonStartWidth - 1
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
        UserControl.ForeColor = PBTCN
        UserControl.CurrentX = lonStartWidth
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
        
    ElseIf U_TextEffect = Embossed Then
        UserControl.ForeColor = PBTCS
        UserControl.CurrentX = lonStartWidth - 1
        UserControl.CurrentY = lonStartHeight - 1
        UserControl.Print TextString
        UserControl.ForeColor = RGB(128, 128, 128)
        UserControl.CurrentX = lonStartWidth + 1
        UserControl.CurrentY = lonStartHeight + 1
        UserControl.Print TextString
        UserControl.ForeColor = PBTCN
        UserControl.CurrentX = lonStartWidth
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
    ElseIf U_TextEffect = OutLine Then
        UserControl.ForeColor = PBTCS
        UserControl.CurrentX = lonStartWidth + 1
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
        UserControl.CurrentX = lonStartWidth - 1
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
        UserControl.CurrentY = lonStartHeight - 1
        UserControl.CurrentX = lonStartWidth
        UserControl.Print TextString
        UserControl.CurrentY = lonStartHeight + 1
        UserControl.CurrentX = lonStartWidth
        UserControl.Print TextString
        UserControl.ForeColor = PBTCN
        UserControl.CurrentX = lonStartWidth
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
        
    ElseIf U_TextEffect = Shadow Then
        UserControl.ForeColor = PBTCS
        UserControl.CurrentX = lonStartWidth + 1
        UserControl.CurrentY = lonStartHeight + 1
        UserControl.Print TextString
        UserControl.ForeColor = PBTCN
        UserControl.CurrentX = lonStartWidth
        UserControl.CurrentY = lonStartHeight
        UserControl.Print TextString
    End If
    

    End Sub

    Public Function DrawGradientFourColour(ObjectHDC As Long, Left As Long, Top As Long, Width As Long, Height As Long, TopLeftColour As Long, TopRightColour As Long, BottomLeftColour As Long, BottomRightColour As Long)
    Dim bi24BitInfo As BITMAPINFO
    Dim bBytes() As Byte
    Dim LeftGrads() As cRGB
    Dim RightGrads() As cRGB
    Dim MiddleGrads() As cRGB
    Dim TopLeft As cRGB
    Dim TopRight As cRGB
    Dim BottomLeft As cRGB
    Dim BottomRight As cRGB
    Dim iLoop As Long
    Dim bytesWidth As Long

    With TopLeft
        .Red = Red(TopLeftColour)
        .Green = Green(TopLeftColour)
        .Blue = Blue(TopLeftColour)
    End With
    
    With TopRight
        .Red = Red(TopRightColour)
        .Green = Green(TopRightColour)
        .Blue = Blue(TopRightColour)
    End With
    
    With BottomLeft
        .Red = Red(BottomLeftColour)
        .Green = Green(BottomLeftColour)
        .Blue = Blue(BottomLeftColour)
    End With
    
    With BottomRight
        .Red = Red(BottomRightColour)
        .Green = Green(BottomRightColour)
        .Blue = Blue(BottomRightColour)
    End With
    
    GradateColours LeftGrads, Height, TopLeft, BottomLeft
    GradateColours RightGrads, Height, TopRight, BottomRight
    
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = Width
        .biHeight = 1
    End With
    
    ReDim bBytes(1 To bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3) As Byte
    
    bytesWidth = (Width) * 3
    
    For iLoop = 0 To Height - 1
        GradateColours MiddleGrads, Width, LeftGrads(iLoop), RightGrads(iLoop)
        CopyMemory bBytes(1), MiddleGrads(0), bytesWidth
        SetDIBitsToDevice ObjectHDC, Left, Top + iLoop, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, 0, 0, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS
    Next iLoop
    

    End Function

    Private Function GradateColours(cResults() As cRGB, Length As Long, Colour1 As cRGB, Colour2 As cRGB)
    Dim fromR As Integer
    Dim toR As Integer
    Dim fromG As Integer
    Dim toG As Integer
    Dim fromB As Integer
    Dim toB As Integer
    Dim stepR As Single
    Dim stepG As Single
    Dim stepB As Single
    Dim iLoop As Long

    ReDim cResults(0 To Length)
    
    fromR = Colour1.Red
    fromG = Colour1.Green
    fromB = Colour1.Blue
    
    toR = Colour2.Red
    toG = Colour2.Green
    toB = Colour2.Blue
    
    stepR = Divide(toR - fromR, Length)
    stepG = Divide(toG - fromG, Length)
    stepB = Divide(toB - fromB, Length)
    
    For iLoop = 0 To Length
        cResults(iLoop).Red = fromR + (stepR * iLoop)
        cResults(iLoop).Green = fromG + (stepG * iLoop)
        cResults(iLoop).Blue = fromB + (stepB * iLoop)
    Next iLoop
    

    End Function

    Private Function Blue(Colour As Long) As Long
    Blue = (Colour And &HFF0000) / &H10000
    End Function
    Private Function Green(Colour As Long) As Long
    Green = (Colour And &HFF00&) / &H100
    End Function

    Private Function Red(Colour As Long) As Long
    Red = (Colour And &HFF&)
    End Function

    Private Function Divide(Numerator, Denominator) As Single
    If Numerator = 0 Or Denominator = 0 Then
    Divide = 0
    Else
    Divide = Numerator / Denominator
    End If
    End Function
    Public Sub GradientTwoColour(ByVal hDC As Long, ByVal Direction As GRADIENT_DIRECT, ByVal StartColor As Long, ByVal EndColor As Long, Left As Long, Top As Long, Width As Long, Height As Long)
    Dim udtVert(1) As TRIVERTEX, udtGRect As GRADIENT_RECT
    Dim UDTRECT As RECT
    'hDCObj.ScaleMode = vbPixels
    'hDCObj.AutoRedraw = True
    SetRect UDTRECT, Left, Top, Width, Height
    With udtVert(0)
    .x = UDTRECT.Left
    .y = UDTRECT.Top
    .Red = LongToSignedShort(CLng((StartColor And &HFF&) * 256))
    .Green = LongToSignedShort(CLng(((StartColor And &HFF00&) \ &H100&) * 256))
    .Blue = LongToSignedShort(CLng(((StartColor And &HFF0000) \ &H10000) * 256))
    .Alpha = 0&
    End With
    With udtVert(1)
    .x = UDTRECT.Right
    .y = UDTRECT.Bottom
    .Red = LongToSignedShort(CLng((EndColor And &HFF&) * 256))
    .Green = LongToSignedShort(CLng(((EndColor And &HFF00&) \ &H100&) * 256))
    .Blue = LongToSignedShort(CLng(((EndColor And &HFF0000) \ &H10000) * 256))
    .Alpha = 0&
    End With
    udtGRect.UpperLeft = 0
    udtGRect.LowerRight = 1
    GradientFillRect hDC, udtVert(0), 2, udtGRect, 1, Direction
    End Sub
    Private Function LongToSignedShort(ByVal Unsigned As Long) As Integer
    If Unsigned < 32768 Then
    LongToSignedShort = CInt(Unsigned)
    Else
    LongToSignedShort = CInt(Unsigned - &H10000)
    End If
    End Function
    Private Function ColourTOGray(ByVal uColor As Long) As Long
    Dim Red As Long, Blue As Long, Green As Long
    Dim gray As Long
    Red = uColor Mod 256
    Green = (uColor Mod 65536) / 256
    Blue = uColor / 65536
    gray = (Red + Green + Blue) / 3
    ColourTOGray = RGB(gray, gray, gray)
    End Function
    Private Function LightenColor(ByVal uColour As ColorConstants, Optional ByVal OffSet As Long = 1) As Long
    Dim intR As Integer, intG As Integer, intB As Integer
    intR = Abs((uColour Mod 256) + OffSet)
    intG = Abs((((uColour And &HFF00) / 256&) Mod 256&) + OffSet)
    intB = Abs(((uColour And &HFF0000) / 65536) + OffSet)
    LightenColor = RGB(intR, intG, intB)
    End Function
    '-------------------------------------------------------------------------------------------------------
    二、Form测试,代码如下:
    Option Explicit
    Dim i As Integer, B As Boolean

    Private Sub Command1_Click()
    ProgressBar1.Value = 0
    B = True
    Do
    DoEvents
    ProgressBar1.Value = i
    i = i + 1
    If i >= 10000 Or B = False Then Exit Do
    Loop
    End Sub

    Private Sub Form_Load()
    ProgressBar1.Max = 10000
    ProgressBar1.Min = 0
    ProgressBar1.Value = 0
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    B = False
    End Sub

    展开全文
  • VB6进度条下载

    2012-04-08 20:31:19
    VB6进度条下载,用inet控件实现读取并下载!
  • ccrprog6 VB进度条控件

    2011-07-26 20:56:51
    这个小控件代替了vb附带的进度条,在功能上上有所增加,如果你不喜欢vb附带的进度条,可以试试这个小控件!
  • 枫枫VB下载演示,带进度条VB6源码,简单的一个下载演示,带进度条的!
  • VB6_XP效果进度条控件

    2009-05-25 10:37:31
    VB6_XP效果进度条控件,效果不错,大家来看看吧。
  • 一个包括了众多常用VB小功能的控件集代码,比如大家常用的SwitchButton按钮、复选框、LED显示屏、ToggleLight电灯开关按钮、进度条、托盘图标以及ToggleSwitch等,全部集成到目前这一个实例中了,在需要时,你可以...
  • VB6.0使用API拷贝文件显示进度条,api拷贝文件并出现进度条,同时还有删除、替换文件的功能,具体实现的功能:  将当前目录中的FileTG.frm文件复制到当前目录下1.frm  将当前目录下的1.frm文件改名位2.frm  将...
  • VB6编写制作一款仿Windows启动画面的彩色进度条效果,一条彩带在Windows启动时显示,由此模拟出本款进度条效果,十分逼真,很漂亮美观,可方便嵌入到你的VB应用程序中,源代码开源免费。用在程序启动画面或程序逻辑...
  • VB实现的 很不错哦 做下载软件或者播放器 之类的 很有用处哦
  • 刚开始学习VB6,请教如何在VB中做动态进度条,如进度条区域可任意调整最大、最小值(有点像动态的起点和终点),点击开始,游标可以从左到右移动。谢谢!
  • 6BA56F0E11D65292!469.entry 2008/6/16 诡异的VB多线程和回调...但是由于需要显示进度条,就把进度条窗口在vb中实现,打算让vc回调vb中的函数,用来实现进度条的滚动。试了一下效果不好,原因是vc的dll在

    原帖出至:http://storespace0930.spaces.live.com/blog/cns!6BA56F0E11D65292!469.entry

    2008/6/16
    诡异的VB多线程和回调函数(给VB程序做进度条真是烦人啊)

    最近做一个项目。项目流程中需要调用一个vc写的dll来做大运算量的工作。但是由于需要显示进度条,就把进度条窗口在vb中实现,打算让vc回调vb中的函数,用来实现进度条的滚动。试了一下效果不好,原因是vc的dll在处理是,vb的界面失去了响应,因此进度条也就失去了意义。解决的方法很明显,就是要为vc中的运算另开一个线程。

    思路很简单,但做起来就异常麻烦。vb6根本就不具备多线程功能,没办法,借助API的 CreateThread函数吧。本来以为就这样结束了,但麻烦远远没有结束。线程创建了,但是dll中的函数却根本就不运行,弄了半天,程序还是不行。一调试,vb6环境就经常崩溃,弄得无比郁闷。上网一查才知道vb中的多线程是极其不稳定的,甚至你的IDE中调试运行可能没有任何问题,但是生成exe 文件后运行就出问题了。

    那怎么办呢?那只能把创建线程移到VC的dll中实现了呗,相比起来这个就容易多了。但是在vb中调用的时候还是有问题,dll中的函数居然还是不运行。这个就搞笑了,试了半天才发现,在调用dll后,vb中的过程不能立即结束,如果立即结束的话,那么dll中的函数就不会运行。但只要在vb调用dll的函数中添加一句   Sleep 100   语句,则dll中的线程就可以建立了。然后我们就可以通过一个Timer控件过一段时间查询一下线程是否结束。

    程序到此,多线程的路子基本通了。还差回调函数,就可以显示进度了。

    回调函数看起来很简单啊,vb中用 AddressOf  把位于标准模块中的某个函数的地址传给dll,dll中再在适当的时候用这个地址回调vb中的函数。但一开始就不顺。发现vb传过去的地址和vc中得到的地址相比老是不对,折腾了半天,才发现在传递地址给dll中的某个函数时,应该把该地址按照 ByVal *** As Long  ,这样dll中就可以得到正确的地址了。

    地址传对了,那vc中就按照如下方式声明函数即可:

        typedef void (__stdcall *FUNCPTR)(int i,BSTR FormTitle,BSTR currBlockName,int currNum,int TotleCount,int ProcessedFaces,int TotalFacesCount);//参数列表要与vb中的对应int→Long,BSTR→String
        FUNCPTR vbFunc;//定义一个函数,呆会就用这个函数进行回调
        vbFunc = (FUNCPTR)CallBackAddress; //CallBackAddress就是我们传递进来的VB函数地址

    到此VC中的声明就成功了

    记住吧VC中的string传递给VB前,一定要转成BSTR类型。具体做法:

        BSTR  temp;
        temp=A2BSTR(string.c_str());

    然后把 temp 返回给VB前,再用SysAllocString ,即:

        vbFunc(0,SysAllocString(string1) ,SysAllocString(string2) ,0,0,0,1);

    到此,你是不是以为进度条可以滚动了?恭喜,在VB6的IDE中进行调试运行时没有任何问题。但是!!!很遗憾,生成EXE后就不能运行了,一到回调的地方就会开始报错,这就让人崩溃了。调试时候好,exe报错,就是说你连错在什么地方都不好找,只能在堆栈中看到说某个系统dll出错。

    就这个问题,我卡了一天,上网找了各种各样的资料后,才找到这么几句话(出自:http://bbs.pfan.cn/post-248211.html)

        1:“你是否中使用了AddressOf来获取函数地址,并把AddressOf获取的地址传递给多线程来使用?如果是的话那恭喜你!
            前些天,偶也是遇到了类似的问题,最后查遍MSDN,在微软的公告里说AddressOf是一个线程安全类型,也就是说AddressOf取得的地址只能由VB创建的线程进行使用,不能传递给由CreateThread”函数或其它的创建线程的函数进行使用。
        附上MSDN中的解释:http://support.microsoft.com/kb/198607/zh-cn”

        2:“没有为什么,因为VB6对多线程的支持不好。
        我也试过很多类似的莫名其妙的东西。
        一点经验:在多线程里面,尽量少操作非线程安全对象(例如COM部件,VB控件),多用些纯API。”

    虽然对线程安全还不懂是什么意思,但是明白了回调函数中不应该对控件进行操作。我的错误就在于在回调中对进度条和标签控件进行了操作。知道了错在什么地方,也就很好解决了。再定义一堆全局变量呗,在回调时的操作只是把回传的值赋给这些变量,然后再由vb本身的程序按这些全局变量进行操作。到这里,滚动条应该可以滚动了吧^_^

    但现实很无情,这下vb报溢出错误,一查,回调是回传的进度参数出了问题,dll中定义成 float ,vb中相应的定义成 single ,按理应该没有问题啊。一查看回传的值也就是   4.34919177519511E-03 这个数肯定在single的表达范围内啊,怎么会溢出呢?找了一下  刘炳文老师的《VB 6.0 win32 API 程序设计.pdf》在 P61找到这么一段话:

    “……要保证所使用的DLL在浮点调用规范上与VB保持兼容。这里所说的兼容包括两个方面,一是编译程序使用的必须是IEEE浮点标准,二是编译程序必须遵守MicroSoft公司的浮点数调用规范”

    我想大概是在调用规范上出了问题,但懒得解决了,既然这个浮点数是在VC中用两个整数除出来的,那我把整数直接传过来在VB中除不就可以了^_^

    不过,虽然这里偷懒把这个问题解决了。但还有个现象我还是要提一下,就是同样是在VB中除,但是如果吧除法的表达式写在让DLL回调的的函数中,即DLL中的线程除完后返回,那么还是会溢出。而如果回调函数中只把这两个整数赋给全局变量。在其他的VB过程中用这两个全局变量相除得出浮点数的话,就没有问题了。看来线程的问题还不是那么简单的。但我实在是筋疲力尽了,赶紧吧这个项目做完,没时间理会这些东西了=。=

    我的论文啊,你什么时候才能诞生呢???我的实习offer啊,你什么时候才能到我手中啊???

    展开全文
  • 大家都知道COM接口,COM就是一个虚函数表指针,VB6虽然支持COM的thiscall调用,可必需通过引用,而如果一些COM接口没有给基于VB6的引用,那VB6就残了,比如IStream之类的,这次的ITaskbarList3也是一样。 我们先...
    如果说上次我发的那个直接调用R0函数的是鸡肋的话,这次这个就是有很好的实际应用的东西。
    大家都知道COM接口,COM就是一个虚函数表指针,VB6虽然支持COM的thiscall调用,可必需通过引用,而如果一些COM接口没有给基于VB6的引用,那VB6就残了,比如IStream之类的,这次的ITaskbarList3也是一样。

    我们先看看看一个COM接口在内存中的结构,这里我用VB6的方式写,大家理解起来会很简单。
    如果我们声明一个变量,这个变量是一个COM对象,然后调用xx函数真正初始化了这个对象,COM指针就指向一个虚函数表,此时COM在Win32内存中是这样的,伪代码如下:
    Type Com
    Type IUnknown
    QueryInterface + 0
    AddRef + 4
    Release + 8
    End Type
    Function1 + 12
    Function2 + 16
    Function3 + 20
    ···
    End Type
    恩,可以理解为COM指针就是一个表的内存区域,然后这个内存区域里面就是这样一张虚函数表,调用时,编译器根据索引*4取得需要调用的虚函数的地址,然后进行调用。

    我们再追寻下一个COM对象的诞生过程:
    声明COM对象变量(x86下这是一个4字节的指针)
    调用**函数初始化这个变量,**函数进行一个new class操作,IUnknown引用+1,初始化class内的各种此对象需要内部变量之类的等等,这就是为什么call这个COM成员函数时需要压入COM指针,因为那就是一个伪class指针,记录了一些这个class需要使用的数据。
    此时一个新的class数据被分配出来,建立虚函数表,把class的基地址写入4字节的程序内变量。
    程序调用class的某个成员函数,根据虚函数表取到函数地址,压入class基地址,函数代码内从这个class提取相关变量等,执行代码。

    我们再来看看一个COM函数的原形:
    void test(int a,int b);
    真正的原形是:
    void test(this,int a,int b);
    this即为class指针,这是对程序员不可见的。我们称此为thiscall,也就是stdcall的一个变种。(可以去看看cdecl、stdcall、thiscall的文章)

    我随便找了一个程序,截取其调用一个COM成员函数时的代码:

    好了,理解了这些基本的东西,我们就可以动手了。
    ITaskbarList3这个COM对象的声明在Windows 7 SDK的Shobjidl.h文件中,C style如下:

        typedef struct ITaskbarList3Vtbl
        {
            BEGIN_INTERFACE
            
            HRESULT ( STDMETHODCALLTYPE *QueryInterface )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in REFIID riid,
                /* [annotation][iid_is][out] */ 
                __RPC__deref_out  void **ppvObject);
            
            ULONG ( STDMETHODCALLTYPE *AddRef )( 
                __RPC__in ITaskbarList3 * This);
            
            ULONG ( STDMETHODCALLTYPE *Release )( 
                __RPC__in ITaskbarList3 * This);
            
            HRESULT ( STDMETHODCALLTYPE *HrInit )( 
                __RPC__in ITaskbarList3 * This);
            
            HRESULT ( STDMETHODCALLTYPE *AddTab )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd);
            
            HRESULT ( STDMETHODCALLTYPE *DeleteTab )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd);
            
            HRESULT ( STDMETHODCALLTYPE *ActivateTab )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd);
            
            HRESULT ( STDMETHODCALLTYPE *SetActiveAlt )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd);
            
            HRESULT ( STDMETHODCALLTYPE *MarkFullscreenWindow )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ BOOL fFullscreen);
            
            HRESULT ( STDMETHODCALLTYPE *SetProgressValue )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ ULONGLONG ullCompleted,
                /* [in] */ ULONGLONG ullTotal);
            
            HRESULT ( STDMETHODCALLTYPE *SetProgressState )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ TBPFLAG tbpFlags);
            
            HRESULT ( STDMETHODCALLTYPE *RegisterTab )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwndTab,
                /* [in] */ __RPC__in HWND hwndMDI);
            
            HRESULT ( STDMETHODCALLTYPE *UnregisterTab )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwndTab);
            
            HRESULT ( STDMETHODCALLTYPE *SetTabOrder )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwndTab,
                /* [in] */ __RPC__in HWND hwndInsertBefore);
            
            HRESULT ( STDMETHODCALLTYPE *SetTabActive )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwndTab,
                /* [in] */ __RPC__in HWND hwndMDI,
                /* [in] */ DWORD dwReserved);
            
            HRESULT ( STDMETHODCALLTYPE *ThumbBarAddButtons )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ UINT cButtons,
                /* [size_is][in] */ __RPC__in_ecount_full(cButtons) LPTHUMBBUTTON pButton);
            
            HRESULT ( STDMETHODCALLTYPE *ThumbBarUpdateButtons )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ UINT cButtons,
                /* [size_is][in] */ __RPC__in_ecount_full(cButtons) LPTHUMBBUTTON pButton);
            
            HRESULT ( STDMETHODCALLTYPE *ThumbBarSetImageList )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ __RPC__in_opt HIMAGELIST himl);
            
            HRESULT ( STDMETHODCALLTYPE *SetOverlayIcon )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ __RPC__in HICON hIcon,
                /* [string][unique][in] */ __RPC__in_opt_string LPCWSTR pszDescription);
            
            HRESULT ( STDMETHODCALLTYPE *SetThumbnailTooltip )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [string][unique][in] */ __RPC__in_opt_string LPCWSTR pszTip);
            
            HRESULT ( STDMETHODCALLTYPE *SetThumbnailClip )( 
                __RPC__in ITaskbarList3 * This,
                /* [in] */ __RPC__in HWND hwnd,
                /* [in] */ __RPC__in RECT *prcClip);
            
            END_INTERFACE
        } ITaskbarList3Vtbl;
    SetProgressValue为第10个函数,那函数地址就是(10-1)*4,为了更易懂,我们可以把一个COM函数的Vtbl列成VB6里面的Enum。
    添加一个Module1,复制代码:

    Private Declare Function CallWindowProcW& Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long)
    Private Declare Function LocalAlloc& Lib "kernel32" (ByVal f&, ByVal s&)
    Private Declare Function LocalFree& Lib "kernel32" (ByVal m&)
    Private Declare Sub PutMem1 Lib "msvbvm60" (ByVal Ptr As Long, ByVal NewVal As Byte)
    Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Ptr As Long, ByVal NewVal As Integer)
    Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal NewVal As Long)
    Private Declare Sub PutMem8 Lib "msvbvm60" (ByVal Ptr As Long, ByVal NewVal As Currency)
    Public Function CallCOMInterface&(ByVal CComPtr&, ByVal dwMemberIndex&, ParamArray pParam())
    Dim i%, offset&
    Dim hMem&
    hMem = LocalAlloc(0, ((UBound(pParam) + 2) * 5) + 5 + 6 + 1) '//申请代码内存
    offset = hMem
    For i = UBound(pParam) To 0 Step -1 '//压入参数
    PutMem1 offset, &H68 'push Param
    offset = offset + 1
    PutMem4 offset, pParam(i)
    offset = offset + 4
    Next
    PutMem1 offset, &H68 'push COM point,压入COM指针
    PutMem4 offset + 1, CComPtr
    offset = offset + 5
    PutMem1 offset, &HA1 'mov eax,dword ptr ds:CComPtr,eax=CComPtr指针第一个函数地址
    PutMem4 offset + 1, CComPtr
    offset = offset + 5
    PutMem1 offset, &HFF 'call dword ptr ds:eax + dwMemberIndex * 4,根据Win32下COM表结构,一个函数地址长度4字节
    PutMem1 offset + 1, &H90
    PutMem4 offset + 2, dwMemberIndex * 4
    offset = offset + 6
    PutMem1 offset, &HC3 'retn
    PutMem1 offset + 1, &H90 '//nop一行代码
    CallCOMInterface = CallWindowProcW(hMem, 0, 0, 0, 0) 'call
    LocalFree hMem '//释放内存
    End Function
    
    再添加一个Form1,一个Command1,复制代码:

    Private i&
    Private Enum ITaskbarList3
    QueryInterface
    AddRef
    Release
    'IUnknown
    HrInit
    AddTab
    DeleteTab
    ActivateTab
    SetActiveAlt
    MarkFullscreenWindow
    SetProgressValue
    SetProgressState
    RegisterTab
    UnregisterTab
    SetTabOrder
    SetTabActive
    ThumbBarAddButtons
    ThumbBarUpdateButtons
    ThumbBarSetImageList
    SetOverlayIcon
    SetThumbnailTooltip
    SetThumbnailClip
    End Enum
    Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
    End Type
    Private Declare Function IIDFromString& Lib "ole32 " (ByVal ID As Long, ByVal IDs As Long)
    Private Declare Function CLSIDFromString& Lib "ole32 " (ByVal ID As Long, ByVal IDs As Long)
    Private Declare Function CoCreateInstance& Lib "ole32 " (ByVal CLSID As Long, ByVal Outer As Long, ByVal Context As Long, ByVal IID As Long, Obj As Any)
    Private Function CreateW7Task&()
    Dim CID As GUID, IID As GUID, objW7Task&
    CLSIDFromString StrPtr("{56FDF344-FD6D-11d0-958A-006097C9A090}"), VarPtr(CID)
    IIDFromString StrPtr("{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}"), VarPtr(IID)
    CoCreateInstance VarPtr(CID), 0, 1, VarPtr(IID), objW7Task
    CreateW7Task = objW7Task
    End Function
    
    Private Sub Command1_Click()
    Dim j&
    For j = 0 To 10000
    Me.Caption = CallCOMInterface(i, SetProgressValue, Me.hWnd, j, 0, 10000, 0)
    Next
    End Sub
    
    Private Sub Form_Load()
    i = CreateW7Task
    End Sub
    
    点击Command1测试效果。
    这代码就是根据ITaskbarList3的CLSID和IID通过CoCreateInstance创建出来一个COM对象指针,然后调用里面的虚函数,实现Windows7下任务栏进度条效果。
    关于ITaskbarList3的其他函数说明自己看MSDN就行了,理解套用代码就一样调用,其他的COM接口也一样。比如什么XMLLite的那些东西。。。

    有人会问,上面的SetProgressValue不是3个参数么,为什么我们调用的时候传入了5个参数?!
    看原形,SetProgressValue是一个dword的hwnd,2个ULONGULONG的进度参数,ULONGULONG这个玩意是8字节,压栈的时候分2个4字节压,所以我们就写成了4个参数,也就是分开了。就像那个FILETIME差不多。再简单一点,一个ULONGULONG=2个ULONG=2个dword

    好了、长篇大论就写到这里,撸管睡觉去。
    展开全文
  •  ^^ 创建setup类型的进度条vb6) ^^新建一个工程增加一个picture box和command button 加入下面的代码:Dim tenth As Long条件编译#If Win32 ThenPrivate Declare Function BitBlt Lib "gdi32" _(ByVal ...
  • 呵呵,这个还是不错阿,看起来有渐变和模糊效果。支持前景色,背景色设置。
  • [VB]多色彩主题水晶进度条2007 VB6测试通过 ,非常好的进度条.
  • 6) ^^ 新建一个工程 增加一个picture box和command button 加入下面的代码:Dim tenth As Long'条件编译#If Win32 ThenPrivate Declare Function BitBlt Lib "gdi32" _(ByVal hDestDC As Long, ByVal x As Long, ...
  • 19、vb6进度条的使用A.txt 20、vb6进度条的使用B.txt 21、vb6禁止改变窗口大小(允许最大化和最小化).txt 22、vb6模拟按键.txt 23、vb6模拟键盘输入的N种方法.txt 24、vb6判断鼠标左键被按下.txt 25、vb6屏幕任意截图...
  • 如题,希望结合成一个模板,必须支持下载路径为中文的,请各位贴代码时先帮忙测试,应为本人已经在网上找过N个代码了,都是不支持中文的,也没有支持进度条,很希望找到这个代码,感激~~~ 如果确实API无法实现,...
  • URLDownloadToFile函数下载远程文件,可以实现断点续传,通过progressbar也可以实现进度条显示,下载百分比,下载速度的显示,另外也包含读取,写入ini文件的源码..通过setup factory7的文件打包,实现了通过网络更新本地...
  • 老东西了,喜欢复习的人可以看: [url=http://blog.csdn.net/a1875566250/article/details/7584677][/url]
  • VB6的一个奇技淫巧

    千次阅读 2017-08-04 17:28:59
    貌似是百度贴吧VB6,精巧犀利。。。。。 https://tieba.baidu.com/p/4731580018 VB6这么老旧的语言平台,不要以为很垃圾,有时候写精巧小代码还是一个很顺手的得力工具。 回归正题,不但能模拟彩色进度条,还...
  • Qt是开源的简单的C++编程工具,而且开源免费。我是从VB6过来的,概念上容易传承,推荐使用。 有时在长时间循环中需要全占(即不能做其他事)进度条,这时就要用对话框式进度条(我起的名字)了。在Qt中很简单。
  • vb.net多线程例子

    2020-01-13 08:15:40
    对于vb6来讲,实现多线程相对较麻烦(实际上就是模拟多线程),但是对于vb.net来讲就容易多了,我们只需要 Imports System.Threading 即可。 实例 实例很简单,一个按钮,三个文本框,两个进度条。 下载地址:...
  • VB6 仿写的Windows磁盘碎片整理程序,是一个免费开源的软件,不保证对您的系统造成损坏,整理系统页文件,不支持 64-bit 或 Vista 或更高系统  程序有几个配置选项:  完成后重新启动系统  记录日至文件  运行...
  • 范例1-3 带进度条的窗体 范例1-4 工作区透明的窗体 ∷相关函数:SetWindowLongcGetWindowLong 范例1-5 带洞的窗体 ∷相关函数:CreateRectRgn ombineRgncSetWindowRgn 范例1-6 窗体百叶窗效果 ∷相关函数...

空空如也

空空如也

1 2 3 4
收藏数 80
精华内容 32
关键字:

vb6进度条