●一起分享VB源代码◆立即可用于你的工程●你也发布一些经验代码吧,该怎么处理

'┏〓〓〓〓〓〓〓〓〓 FindStrCount,start 〓〓〓〓〓〓〓〓〓┓
'［简介］：
'怎样取得一个字符串在另外一个字符串中出现的次数？
Function FindStrCount(Str1 As String, FindStr As String) As Long
   '帮你写函数，帮你写代码，帮你写模块，帮你设计软件
   '--需要什么函数或功能，可以联系我。
   FindStrCount = UBound(Split(Str1, FindStr))
End Function
'┗〓〓〓〓〓〓〓〓〓  FindStrCount,end  〓〓〓〓〓〓〓〓〓┛

'┏〓〓〓〓〓〓〓〓〓 FindCount,start 〓〓〓〓〓〓〓〓〓┓
'［简介］：
'怎样取得一个字符串在另外一个字符串中出现的次数？
Function FindCount(String1 As String, String2 As String) As Long
   '帮你写函数，帮你写代码，帮你写模块，帮你设计软件
   '--需要什么函数或功能，可以联系我。
         Dim I As Long, iCount As Long
         Dim LenStr As Long
         Dim LenFind As Integer
         LenFind = Len(String2)
         LenStr = Len(String1)
         I = 1
         I = InStr(I, String1, String2, vbTextCompare)
         While I > 0
                iCount = iCount + 1
                I = InStr(I + LenFind, String1, String2, vbTextCompare)
                'Debug.Print iCount & Chr(9) & I
         Wend
   DoEND:
         FindCount = iCount
End Function
'┗〓〓〓〓〓〓〓〓〓  FindCount,end  〓〓〓〓〓〓〓〓〓┛

Private Function SumHanZi(sFile As String) As Long
    '返回字符串中含有的汉字个数
    Dim s As String, s1 As String, i As Long, j As Long
    s = sFile
    For i = 1 To Len(s)
        s1 = Mid(s, i, 1)
        If Asc(s1) < 0 Then j = j + 1
    Next
    SumHanZi = j
End Function

------解决方案--------------------

------解决方案--------------------

VB code

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