●一起分享VB源代码◆立即可用于你的工程●你也发布一些经验代码吧
要求使用“插入源代码，选择VB方式”，代码要求全测试过能用的
相同的功能，有不少设计思路，有的很简单却运行慢，有的很复杂，却运行速度快，有的代码量又少，速度又快
集百家之长，不管咋样，===能立即拿来用才是最实在的，其实运行一下速度快点慢点，对一般人来说基本没影响
我先分享一些
- VB code
'┏〓〓〓〓〓〓〓〓〓 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 = iCountEnd Function'┗〓〓〓〓〓〓〓〓〓 FindCount,end 〓〓〓〓〓〓〓〓〓┛
[解决办法]
Function FindStrCount(Str1 As String, FindStr As String) As Long
'帮你写函数，帮你写代码，帮你写模块，帮你设计软件
'--需要什么函数或功能，可以联系我。
FindStrCount = (len(str1)-len(replace(str1,findstr,"")))/len(findstr)
End Function
[解决办法]
- VB code
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 = jEnd Function
[解决办法]
[解决办法]
[解决办法]
结贴吧，我来接分
[解决办法]
[解决办法]
说实在的，lz的想法不对。
如果代码可以被复用，你应该做的是，封装成函数、库、对象或者控件，而不是搞一堆代码，还“要用了就可以复制下”，这完全是代码民工的想法。
[解决办法]
结贴吧，我来接分
[解决办法]
[解决办法]
- 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 FunctionPublic 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 FunctionPublic 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 FunctionPublic 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 FunctionPublic 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 FunctionPublic 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