电平柱状动态图

最新推荐文章于 2024-04-16 15:36:51 发布

DrunkAlone

最新推荐文章于 2024-04-16 15:36:51 发布

阅读量822

点赞数

分类专栏： VB 文章标签： VB

本文链接：https://blog.csdn.net/cl9212/article/details/10275957

版权

VB 专栏收录该内容

1 篇文章 0 订阅

订阅专栏

1：声明变量

Dim mdc As Long
Dim ddc As Long
Dim ldc As Long
Dim bmpResult As Long
Dim bmpLite As Long
Dim bmpDark As Long
Dim pos As Long

2：应用系统相关方法

Const LR_DEFAULTCOLOR = 0
Const LR_MONOCHROME = 1
Const LR_COLOR = 2
Const LR_COPYRETURNORG = 4
Const LR_COPYDELETEORG = 8
Const LR_LOADFROMFILE = 16
Const LR_LOADTRANSPARENT = 32
Const LR_DEFAULTSIZE = 64
Const LR_VGACOLOR = 128
Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
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 ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

3：创建图片缓存；如果不创建会出现不断闪烁

Private Sub creatImge()
    Dim dc As Long
    Dim old As Long
    pos = 0
    bmpDark = LoadImage(0, App.path & "\GUI\dark.bmp", 0, 0, 0, LR_LOADFROMFILE)
    bmpLite = LoadImage(0, App.path & "\GUI\lite.bmp", 0, 0, 0, LR_LOADFROMFILE)
    dc = GetDC(Me.hWnd)
    mdc = CreateCompatibleDC(dc)
    ldc = CreateCompatibleDC(dc)
    ddc = CreateCompatibleDC(dc)
    'box.Width = 640
    bmpResult = CreateCompatibleBitmap(dc, 4, 214)
    ReleaseDC Me.hWnd, dc
    old = SelectObject(mdc, bmpResult)
    If old <> 0 Then
        DeleteObject old
    End If
    old = SelectObject(ldc, bmpLite)
    If old <> 0 Then
        DeleteObject old
    End If
    old = SelectObject(ddc, bmpDark)
    If old <> 0 Then
        DeleteObject old
    End If
    
End Sub

last:使用；具体参数慢慢分析

Public Function setBitBlt(x As Integer, pos As Integer)

 If pos = 214 Then
        pos = 0
    End If
    
 Dim dc As Long
    'pos = pos + 10
    If pos > 214 Then
        pos = 214
    End If
    If mdc <> 0 Then
        BitBlt mdc, 0, 0, 4, 214, ddc, 0, 0, vbSrcCopy
       ' If pos < 320 Then
            BitBlt mdc, 0, 214 - pos, 4, pos, ldc, 0, 214 - pos, vbSrcCopy
             ' End If
       ' Else
           ' BitBlt mdc, 0, 0, 49, pos, ldc, 49, 0, vbSrcCopy
       ' End If
        dc = GetDC(Me.hWnd)
        If mdc <> 0 Then
            BitBlt dc, x, 190, 4, 214, mdc, 0, 0, vbSrcCopy  '173
            'BitBlt dc, box.Left, box.Top, 320, 240, mdc, 0, 0, vbSrcCopy
            'BitBlt dc, 0, 0, 320, 20, ddc, 0, 0, vbSrcCopy
            'BitBlt dc, 0, 0, pos, 20, ldc, 0, 0, vbSrcCopy
            'BitBlt dc, 100, 100, 320, 20, ddc, 0, 0, vbSrcCopy
            'BitBlt dc, 100, 100, pos, 20, ldc, 0, 0, vbSrcCopy
        End If
        ReleaseDC Me.hWnd, dc
    End If
    If pos = 214 Then
        pos = 0
    End If

End Function