●一行分享VB源代码◆立即可用于你的工程●你也发布一些经验代码吧

●一起分享VB源代码◆立即可用于你的工程●你也发布一些经验代码吧
要求使用“插入源代码，选择VB方式”，代码要求全测试过能用的
相同的功能，有不少设计思路，有的很简单却运行慢，有的很复杂，却运行速度快，有的代码量又少，速度又快
集百家之长，不管咋样，===能立即拿来用才是最实在的，其实运行一下速度快点慢点，对一般人来说基本没影响


我先分享一些

 
 
[解决办法]

[解决办法]

Public Function Color_RGBtoARGB(ByVal RGBColor As Long, ByVal Opacity As Long) As Long

    ' GDI+ color conversion routines. Most GDI+ functions require ARGB format vs standard RGB format
    ' This routine will return the passed RGBcolor to RGBA format

    If (RGBColor And &H80000000) Then RGBColor = GetSysColor(RGBColor And &HFF&)
    Color_RGBtoARGB = (RGBColor And &HFF00&) Or ((RGBColor And &HFF&) * &H10000) Or ((RGBColor And &HFF0000) \ &H10000)
    If Opacity < 128 Then 
 
        If Opacity < 0& Then Opacity = 0&
        Color_RGBtoARGB = Color_RGBtoARGB Or Opacity * &H1000000
    Else
        If Opacity > 255& Then Opacity = 255&
        Color_RGBtoARGB = Color_RGBtoARGB Or (Opacity - 128&) * &H1000000 Or &H80000000
    End If
    
End Function

Public Function Color_ARGBtoRGB(ByVal ARGBcolor As Long, Optional ByRef Opacity As Long) As Long

    ' This routine is the opposite of Color_RGBtoARGB
    ' Returned color is always RGB format, Opacity parameter will contain RGBAcolor opacity (0-255)

   If (ARGBcolor And &H80000000) Then
        Opacity = (ARGBcolor And Not &H80000000) \ &H1000000 Or &H80
    Else
        Opacity = (ARGBcolor \ &H1000000)
    End If
    Color_ARGBtoRGB = (ARGBcolor And &HFF00&) Or ((ARGBcolor And &HFF&) * &H10000) Or ((ARGBcolor And &HFF0000) \ &H10000)

End Function
Public Function ArrayToPicture(arrayVarPtr As Long, lSize As Long) As IPicture
    
    ' function creates a stdPicture from the passed array
    ' Note: The array was already validated as not empty before this was called
    
    Dim aGUID(0 To 3) As Long
    Dim IIStream As IUnknown
    
    On Error GoTo ExitRoutine
    Set IIStream = IStreamFromArray(arrayVarPtr, lSize)
    
    If Not IIStream Is Nothing Then
        aGUID(0) = &H7BF80980    ' GUID for stdPicture
        aGUID(1) = &H101ABF32
        aGUID(2) = &HAA00BB8B
        aGUID(3) = &HAB0C3000
        Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, 0&, aGUID(0), ArrayToPicture)
    End If
    
ExitRoutine:
End Function

Public Function HandleToStdPicture(ByVal hImage As Long, ByVal imgType As PictureTypeConstants) As IPicture

    ' function creates a stdPicture object from an image handle (bitmap or icon)
    
    'Private Type PictDesc
    '    Size As Long 
 
    '    Type As Long
    '    hHandle As Long
    '    lParam As Long       for bitmaps only: Palette handle
    '                         for WMF only: extentX (integer) & extentY (integer)
    '                         for EMF/ICON: not used
    'End Type
    
    Dim lpPictDesc(0 To 3) As Long, aGUID(0 To 3) As Long
    
    lpPictDesc(0) = 16&
    lpPictDesc(1) = imgType
    lpPictDesc(2) = hImage
    ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    aGUID(0) = &H7BF80980
    aGUID(1) = &H101ABF32
    aGUID(2) = &HAA00BB8B
    aGUID(3) = &HAB0C3000
    ' create stdPicture
    Call OleCreatePictureIndirect(lpPictDesc(0), aGUID(0), True, HandleToStdPicture)
    
End Function

Public Function IStreamFromArray(ArrayPtr As Long, Length As Long) As stdole.IUnknown
    
    ' Purpose: Create an IStream-compatible IUnknown interface containing the
    ' passed byte aray. This IUnknown interface can be passed to GDI+ functions
    ' that expect an IStream interface -- neat hack
    
    On Error GoTo HandleError
    Dim o_hMem As Long
    Dim o_lpMem  As Long
     
    If ArrayPtr = 0& Then
        CreateStreamOnHGlobal 0&, 1&, IStreamFromArray
    ElseIf Length <> 0& Then
        o_hMem = GlobalAlloc(&H2&, Length)
        If o_hMem <> 0 Then
            o_lpMem = GlobalLock(o_hMem)
            If o_lpMem <> 0 Then
                CopyMemory ByVal o_lpMem, ByVal ArrayPtr, Length
                Call GlobalUnlock(o_hMem)
                Call CreateStreamOnHGlobal(o_hMem, 1&, IStreamFromArray)
            End If
        End If 
 
    End If
    
HandleError:
End Function

Public Function IStreamToArray(hStream As Long, arrayBytes() As Byte) As Boolean

    ' Return array of bytes contained in an IUnknown interface (stream)
    
    Dim o_hMem As Long, o_lpMem As Long
    Dim o_lngByteCount As Long
    
    If hStream Then
        If GetHGlobalFromStream(ByVal hStream, o_hMem) = 0 Then
            o_lngByteCount = GlobalSize(o_hMem)
            If o_lngByteCount > 0 Then
                o_lpMem = GlobalLock(o_hMem)
                If o_lpMem <> 0 Then
                    ReDim arrayBytes(0 To o_lngByteCount - 1)
                    CopyMemory arrayBytes(0), ByVal o_lpMem, o_lngByteCount
                    GlobalUnlock o_hMem
                    IStreamToArray = True
                End If
            End If
        End If
    End If
    
End Function