开发过程中的常用自定义函数集锦，欢迎大家来研究。

Question

为什么没有人回复,再贴两个:'转换一个十进制的数到任意(2-32)进制
Public Function ConvertFromDec(ByVal Source As Long, Optional ByVal Exponent As Long = 2) As String
    Dim strResult As String
    Dim lngMod As Long
    
    '判断要转换的进制是否合法
    If Exponent > 32 And Exponent > 2 Then Exit Function
    
    Do
        lngMod = Source Mod Exponent
        Source = Source \ Exponent
        If lngMod > 9 Then
            strResult = "" & Chr(65 + lngMod - 10) & strResult
          Else
            strResult = "" & lngMod & strResult
        End If
    Loop Until Source = 0
    ConvertFromDec = strResult
End Function'转换一个任意(2-32)进制的数到十进制
Public Function ConvertToDec(ByVal Source As String, Optional ByVal Exponent As Long = 2) As Long
    Dim lngResult As Long
    Dim lngFor As Long
    Dim lngCount As Long
    Dim lngByte As Long
       
    '判断要转换的进制是否合法
    If Exponent > 32 And Exponent > 2 Then Exit Function    lngCount = Len(Source)
    For lngFor = 1 To lngCount
        lngByte = Asc(Mid(Source, lngFor, 1))
        Select Case lngByte
            Case 48 To 57:
                lngByte = lngByte - 48
            Case 65 To 90:
                lngByte = lngByte - 55
            Case 97 To 122:
                lngByte = lngByte - 87
            Case Else
                lngByte = -1
        End Select
        If lngByte < 0 Or lngByte > Exponent Then
            Err.Raise 5
        Else
            lngResult = lngResult * Exponent + lngByte
        End If
    Next lngFor
    
    ConvertToDec = lngResult
    Exit Function
End Function

Answer 1

获取一个DWORD类型的高位,何必如此麻烦：高位: 
   lngWord=lngWord mod 65536低位：
   lngWord=lngWord \ 65536

Answer 2

to YHeng(我来也!):
     老大,65535是无符号整形的最大值，DWORD是无符号的长整型。而且即使把65536改了，你的代码也会溢出的。

Answer 3

to YHeng(我来也！):
      对不起，说说错话了，不过用你的方法是不行的，比如&HFFFFFFFF,在long型中值为-1,用你的方法就得不到正确的值。
msgbox &HFFFFFFFF MOD 65536

Answer 4

楼上的都very good~!!!
本菜鸟受益非浅啊￣！！！UP

Answer 5

Public Function LoWord(DWord As Long) As Integer
    LoWord = (DWord And &H7FFF) Or (((DWord And &H8000&) <> 0) And &H8000)
End FunctionPublic Function HiWord(DWord As Long) As Integer
    HiWord = (DWord And &H7FFF0000) \ &H10000 Or (((DWord And &H80000000) <> 0) And &H8000)
End FunctionPublic Function MakeDWord(HiWord As Integer, LoWord As Integer) As Long
    MakeDWord = ((HiWord And &H7FFF) * &H10000 Or (((HiWord And &H8000) <> 0) And &H80000000)) _
            Or ((LoWord And &H7FFF) Or (((LoWord And &H8000) <> 0) And &H8000&))
End Function

Answer 6

Function Dir2Name(Dir As String)
Dim s As String
Dim i As Long
For i = Len(Dir) To 1 Step -1
s = Mid$(Dir, i, 1)
If s = "\" Then
Dir2Name = Right$(Dir, Len(Dir) - i)
Exit For
End If
Next i
End Function
Function FileName2Dir(Filename As String)
Dim s As String
Dim i As Long
For i = Len(Filename) To 1 Step -1
s = Mid$(Filename, i, 1)
If s = "\" Then
FileName2Dir = Left$(Filename, i)
Exit For
End If
Next i
End Function
Function Name2Add(Name As String)
Dim s As String
Dim i As Long
For i = Len(Name) To 1 Step -1
s = Mid$(Name, i, 1)
If s = "." Then
Name2Add = Right$(Name, Len(Name) - i)
Exit For
End If
Next i
End Function
Function OpenDir(Mhwnd As Long)
    Dim bi As BROWSEINFO
    Dim r As Long
    Dim pidl As Long
    Dim path As String
    Dim pos As Integer
    bi.hOwner = Mhwnd
    '展开根目录
    bi.pidlRoot = 0&
    '列表框标题
    bi.lpszTitle = "请选择文件保存路径："
    '规定只能选择文件夹，其他无效
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    '调用API函数显示列表框
    pidl = SHBrowseForFolder(bi)
    '利用API函数获取返回的路径
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal pidl&, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        OpenDir = Left(path, pos - 1)
    Else
        OpenDir = ""
    End If
End Function
--------------------------------------------------------------------
上面是文件路径处理的。
--------------------------------------------------------------------
Function StillRun(ByVal ProgramID) As Boolean
Dim lHProgram As Long
Dim lReturn As Long
Dim hProgram As Long
hProgram = 0
hProgram = OpenProcess(0, False, ProgramID)
If Not hProgram = 0 Then
  StillRun = True
Else
  StillRun = False
End If
CloseHandle hProgram
End Function
--------------------------------------------------------------------
上面是控制进程的，在一个进程结束后再运行另一个进程。
--------------------------------------------------------------------
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Function ReadIni(AppName As String, KeyName As String, Returns As String, Filename As String)
Dim Ret As String
Dim NC As Integer
Ret = String(1024, 0)
NC = GetPrivateProfileString(AppName, KeyName, "", Ret, 1024, Filename)
If NC <> 0 Then Ret = Left$(Ret, NC)
Returns = Ret
End Function
Function WriteIni(AppName As String, KeyName As String, lpString As String, Filename As String)
WritePrivateProfileString AppName, KeyName, lpString, Filename
End Function
Function ReadSystemIni(AppName As String, KeyName As String, Returns As String)
Dim Ret As String
Dim NC As Integer
Ret = String(1024, 0)
NC = GetProfileString(AppName, KeyName, "", Ret, 1024)
If NC <> 0 Then Ret = Left$(Ret, NC)
Returns = Ret
End Function
Function WriteSystemIni(AppName As String, KeyName As String, lpString As String)
WriteProfileString AppName, KeyName, lpString
End Function
Function SystemPath() As String
Dim SystemDirectory As String
Dim X As Long
SystemDirectory = String(1024, 0)
X = GetSystemDirectory(SystemDirectory, 255)
SystemPath = Left$(SystemDirectory, X)
End Function
Function WindowsPath() As String
Dim WindowsDirectory As String
Dim X As Long
WindowsDirectory = String(1024, 0)
X = GetWindowsDirectory(WindowsDirectory, 255)
WindowsPath = Left$(WindowsDirectory, X)
End Function
--------------------------------------------------------------------
与读取ini和取得系统目录有关的。

Answer 7

Sub QuitApp()
   Dim frmTemp as Form
   For each frmTemp in Forms
unload frmTemp
   Next
End Sub
这样退出时候会调用所有form的QueryUnload事件---------------------------------------------------------
Montaque==Digitalboy==Houyongfeng==Monkey

Answer 8

Public Function GetRedValue(COLOR As Long) As Integer
GetRedValue = COLOR And &HFF
End Function
Public Function GetGreenValue(COLOR As Long) As Integer
GetGreenValue = (COLOR And 65280) \ 256
End Function
Public Function GetBlueValue(COLOR As Long) As Integer
GetBlueValue = (COLOR And &HFF0000) \ 65536
End Function
Public Function GetHexColor(Red As Integer, Green As Integer, Blue As Integer) As String
Dim StrRed As String, StrGreen As String, StrBlue As String
  StrRed = Hex(Red)
  StrGreen = Hex(Green)
  StrBlue = Hex(Blue)
  If Red <= 16 Then StrRed = "0" & StrRed
  If Green <= 16 Then StrGreen = "0" & StrGreen
  If Blue <= 16 Then StrBlue = "0" & StrBlue
  GetHexColor = StrRed & StrGreen & StrBlue
End Function
--------------------------------------------------------------------
与颜色有关的，从名字就知道怎么用
--------------------------------------------------------------------
Public Function AppPath() As String
If Right(App.path, 2) = ":\" Then
  AppPath = Left(App.path, Len(App.path) - 1)
Else
  AppPath = App.path
End If
End Function
--------------------------------------------------------------------
EXE路径，弥补App.Path的Bug
--------------------------------------------------------------------
Public Function RaiseText(s As String, X As Integer, Y As Integer, Width As Integer, COLOR As Long, f As Variant)
Dim i As Integer
f.ForeColor = RGB(255, 255, 255)
For i = 1 To Width
f.CurrentX = X - i
f.CurrentY = Y - i
f.Print s
Next i
f.ForeColor = RGB(0, 0, 0)
For i = 1 To Width
f.CurrentX = X + i
f.CurrentY = Y + i
f.Print s
Next i
f.ForeColor = COLOR
f.CurrentX = X
f.CurrentY = Y
f.Print s
End Function
Public Function DecText(s As String, X As Integer, Y As Integer, Width As Integer, COLOR As Long, f As Variant)
Dim i As Integer
f.ForeColor = RGB(0, 0, 0)
For i = 1 To Width
f.CurrentX = X - i
f.CurrentY = Y - i
f.Print s
Next i
f.ForeColor = RGB(255, 255, 255)
For i = 1 To Width
f.CurrentX = X + i
f.CurrentY = Y + i
f.Print s
Next i
f.ForeColor = COLOR
f.CurrentX = X
f.CurrentY = Y
f.Print s
End Function
Public Function SlideText(s As String, X As Integer, Y As Integer, Width As Integer, COLOR As Long, f As Variant)
Dim i As Integer
f.ForeColor = RGB(60, 60, 60)
For i = 1 To Width
f.CurrentX = X + i
f.CurrentY = Y + i
f.Print s
Next i
f.ForeColor = COLOR
f.CurrentX = X
f.CurrentY = Y
f.Print s
End Function
Public Function ShadowText(s As String, X As Integer, Y As Integer, Width As Integer, COLOR As Long, f As Variant)
Dim i As Integer
f.ForeColor = RGB(60, 60, 60)
f.CurrentX = X + Width
f.CurrentY = Y + Width
f.Print s
f.ForeColor = COLOR
f.CurrentX = X
f.CurrentY = Y
f.Print s
End Function
--------------------------------------------------------------------
多字体特效
--------------------------------------------------------------------
Made by Thirdapple's Studio(http://3rdapple.51.net/)