收集大家在编程中的模块

Question

我记得以前csdn有个精华是集合了大家平时用的过程，我希望大家能多贡献自己的过程。
帮助像我这样的新手学习。我现在把我的过程发上去

Answer 1

----动态添加窗体
Option Explicit
Dim i As Integer
Dim a(10) As FormPrivate Sub Command1_Click()
For i = 0 To 10
    If Not IsNull(a(i)) Then
    If Not a(i).Visible Then
    a(i).Visible = True
    Exit For
    End If
    End If
Next
End SubPrivate Sub Command2_Click()For i = 0 To 10
Set a(i) = New Form1
Load a(i)
a(i).Caption = i
Next
End SubPrivate Sub Command3_Click()
a(1).Show
End Sub
-----ado使用
Public cn As String
'连接字符串
Public Function AdoSet(sql As String) As ADODB.Recordset
'给一个sql语句返回记录集
Dim re  As ADODB.Recordset
If cn = "" Then
    cnSet
End If
On Error GoTo doexit
    Set re = New ADODB.Recordset
    re.Open sql, cn
doexit:
    Set AdoSet = re
   Set re = Nothing
'    MsgBox sql
End FunctionPublic Sub ExSql(sql As String)
'执行sql语句
Dim com As ADODB.Command
Set com = New ADODB.Command
If cn = "" Then
    cnSet
End If
On Error Resume Next
    com.ActiveConnection = cn
    com.CommandText = sql
    com.Execute
End Sub

Answer 2

等待（doevents）
Public Function Wait(rsngTime As Single)
  'delay rsngTime Second
  Dim sngTimer As Single
      sngTimer = Timer
  Do Until Timer - sngTimer > rsngTime
      DoEvents
  Loop
End Function阻塞等待
Public Function JustWait(rsngTime As Single)
  'delay rsngTime Second
    Dim sngTimer As Single
    sngTimer = Timer
    Do Until Timer - sngTimer > rsngTime
      
    Loop
End Function'完全退出
Public Sub QuitAll()
    Dim i As Integer
    Do Until Forms.Count = 0
        Unload Forms(Forms.Count - 1)
    Loop
End Sub '调用外部exe(阻塞调用)
Public Function CallEXE(rPathName As String, Optional rCommand As String) As Boolean
    Dim pInfo As PROCESS_INFORMATION
    Dim sInfo As STARTUPINFO
    Dim lSuccess As Long
    Dim lRetValue As Long
    Dim sNull As String
    sInfo.cb = Len(sInfo)
    'If IsMissing(rCommand) Or rCommand = "" ThenrCommand
        'lRetValue = CreateProcessA(sNull, rPathName, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, sInfo, pInfo)
        lRetValue = CreateProcessA(rPathName, """""" & rCommand, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, sInfo, pInfo)
        'lRetValue = CreateProcessA("", rPathName & " " & rCommand, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, sInfo, pInfo)
    'Else
     '   lRetValue = CreateProcessA(rPathName, rCommand, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, sInfo, pInfo)
    'End If
    
    If lRetValue = 0 Then
        MsgBox "Error!", vbCritical
        CallEXE = False
        Exit Function
    End If
    WaitForSingleObject pInfo.hProcess, INFINITE
    lRetValue = TerminateProcess(pInfo.hProcess, 0&)
    lRetValue = CloseHandle(pInfo.hThread)
    lRetValue = CloseHandle(pInfo.hProcess)
    CallEXE = True
End Function

Answer 3

怎样关闭一个正在运行的程序　你可以使用API函数FindWindow和PostMessage去寻找指定的窗口，并关闭它。下面的例子教给你怎样找到并关掉一个Caption为“Caluclator”的程序。　Dim winHwnd As LongDim RetVal As LongwinHwnd = FindWindow(vbNullString, "Calculator")Debug.Print winHwndIf winHwnd <> 0 ThenRetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)If RetVal = 0 ThenMsgBox "置入消息错误！"End IfElseMsgBox "Calculator没有打开！"End If　为了让以上的代码工作，你必须在模块文件中什么以下API函数：　Declare Function FindWindow Lib "user32" Alias _"FindWindowA" (ByVal lpClassName As String, _ByVal lpWindowName As String) As Long Declare Function PostMessage Lib "user32" Alias _"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _ByVal wParam As Long, lParam As Any) As Long Public Const WM_CLOSE = &H10

Answer 4

进制转换模块（不是最新版本）http://community.csdn.net/Expert/FAQ/FAQ_Index.asp?id=195169

Answer 5

我写的全部在   http://jinesc.6600.org/myweb/main.asp?room=10&page=1

Answer 6

Option ExplicitPrivate Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_NEWDIALOGSTYLE = &H40
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End TypePrivate Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As LongPrivate Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXPLORER = &H80000
Private Const OFN_FILEMUSTEXIST = &H1000Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer 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
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPublic Function BrowseFolder(ByVal hwnd As Long, ByVal Title As String) As String
    Dim bi As BROWSEINFO
    Dim rtn, pid As Long
    Dim path As String * 512
    Dim pos As Integer
    With bi
        .hOwner = hwnd
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE
        .lpszTitle = Title
    End With
    pid = SHBrowseForFolder(bi)
    rtn = SHGetPathFromIDList(ByVal pid, ByVal path)
    If rtn Then
        pos = InStr(path, Chr(0))
        BrowseFolder = Left(path, pos - 1)
    Else
        BrowseFolder = ""
    End If
End Function
Public Function OpenDlg(hwnd As Long, filter As String, FilterIndex As Integer) As String
    Dim pOpenfilename As OPENFILENAME
    Dim dd As Long, FileName As String, pos As Integer
    With pOpenfilename
        .flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST
        .lpstrTitle = "打开文件"
        .hwndOwner = hwnd
        .hInstance = App.hInstance
        .lpstrFilter = filter
        .lpstrInitialDir = App.path
        .nFilterIndex = FilterIndex
        .lpstrFile = Space(254)
        .nMaxFile = 255
        .lpstrFileTitle = .lpstrFile
        .nMaxFileTitle = 255
        .lStructSize = Len(pOpenfilename)
    End With
    dd = GetOpenFileName(pOpenfilename)
    If dd Then
        pos = InStrRev(pOpenfilename.lpstrFile, vbNullChar)
       FileName = Left(pOpenfilename.lpstrFile, pos - 2)
    Else
        FileName = ""
    End If
    OpenDlg = FileName
End Function

Answer 7

Option ExplicitPublic Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Public Declare Function GetModuleFileNameExA Lib "psapi.dll" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Public Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Type PROCESSENTRY32
     dwSize  As Long
     cntUsage  As Long
     th32ProcessID  As Long
     th32DefaultHeapID  As Long
     th32ModuleID  As Long
     cntThreads  As Long
     th32ParentProcessID  As Long
     pcPriClassBase  As Long
     dwFlags  As Long
     szExeFile  As String * 260
End Type
 
Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16
Public Const MAX_PATH = 260
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SYNCHRONIZE = &H100000
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Const TH32CS_SNAPPROCESS = &H2&
Public Const hNull = 0
 
Public Function GetPath(ByVal hWnd As Long) As String
    Dim hProcess As Long
    Dim ProcID As Long
    Dim mModules(1 To 200) As Long
    Dim cbNeed As Long
    Dim ModuleName As String
    Dim nSize As Long
    Dim lRet As Long    GetWindowThreadProcessId hWnd, ProcID
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, ProcID)
    lRet = EnumProcessModules(hProcess, mModules(1), 200, cbNeed)
    If lRet <> 0 Then
        ModuleName = Space(MAX_PATH)
        nSize = 500
        lRet = GetModuleFileNameExA(hProcess, mModules(1), ModuleName, nSize)
        GetPath = Left(ModuleName, lRet)
    End If
    lRet = CloseHandle(hProcess)
End Function
'调用如下：
'Text1.Text=GetPath(hWnd)<hWnd>是你要查的句柄

Answer 8

Option ExplicitPublic Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public OldProc As Long
Public NewForm As Form
Public NewMenu As Menu
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONUP = &H205
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const NIM_MODIFY = &H1
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4Public Const NIF_ICON = &H2
Public Const WM_USER = &H400
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Type NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uID As Long
    uFlags As Long
    uCallBackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type
Private NewD As NOTIFYICONDATAPublic Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = TRAY_CALLBACK Then
        If lParam = WM_LBUTTONUP Then
            'If NewForm.WindowState = vbMinimized Then NewForm.WindowState = NewForm.laststate
            'NewForm.SetFocus
            'Exit Function
        End If
        If lParam = WM_RBUTTONUP Then
            NewForm.PopupMenu NewMenu
            Exit Function
        End If
    End If
    'WndProc = CallWindowProc(OldProc, hWnd, Msg, wParam, lParam)
End FunctionPublic Sub AddTray(Frm As Form, Mnu As Menu)
    Set NewForm = Frm
    Set NewMenu = Mnu
    OldProc = SetWindowLong(Frm.hWnd, GWL_WNDPROC, AddressOf WndProc)
    With NewD
        .uID = 0
        .hWnd = Frm.hWnd
        .cbSize = Len(NewD)
        .hIcon = Frm.Icon.Handle
        .uFlags = .uFlags Or NIF_MESSAGE
        .cbSize = Len(NewD)
    End With
    Shell_NotifyIcon NIM_ADD, NewD
End SubPublic Sub RemoveTray()
    With NewD
        .uFlags = 0
    End With
    Shell_NotifyIcon NIM_DELETE, NewD
End SubPublic Sub AddPic(pic As Picture)
    With NewD
        .hIcon = pic.Handle
        .uFlags = NIF_ICON
    End With
    Shell_NotifyIcon NIM_MODIFY, NewD
End SubPublic Sub AddTip(ByVal Tip As String)
    With NewD
        .szTip = Tip & vbNullChar
        .uFlags = NIF_TIP
    End With
    Shell_NotifyIcon NIM_MODIFY, NewD
End Sub

Answer 9

我写的模块大多在“http://www.aivisoft.net/Zyl910/zVBTool.rar”

Answer 10

its screenshot url: 
http://free.efile.com.cn/huangtao/ScreenEnglishShot.jpg
http://free.efile.com.cn/huangtao/ScreenShot.jpgsource download url:
http://free.efile.com.cn/huangtao/SmartmailSource.rarsetup Download Url:
http://free.efile.com.cn/huangtao/SmartMailSetup.rar