征集大家开发过程中用到的公共函数，子程序(续六)

Question

今天又收获了这么多好东西，大家过节快乐！再开新贴
好东西共同分享,减少重复劳动
（满5个结贴，另开新贴）

Answer 1

将下面的文本粘贴到文本编辑器中，然后存为以.reg为扩展名的文件。双击后将信息添加到注册表中。然后用鼠标右键点击一个动态链接库或OCX控件，在弹出的环境菜单中你将会看到Register和Unregister的选项。运用这个方法的前提是你的计算机上必须有regsvr32.exe文件。
REGEDIT4
[HKEY_CLASSES_ROOT\.ocx]
@="ocxfile"
[HKEY_CLASSES_ROOT\ocxfile]
@=”OCX”
[HKEY_CLASSES_ROOT\ocxfile\shell\Register\command]
@="RegSvr32 \"%1\""
[HKEY_CLASSES_ROOT\ocxfile\shell\Unregister\command]
@="RegSvr32 /u \"%1\"" 
REGEDIT4
[HKEY_CLASSES_ROOT\.dll]
@="dllfile"
[HKEY_CLASSES_ROOT\dllfile]
@=”DLL”
[HKEY_CLASSES_ROOT\dllfile\shell\Register\command]
@="RegSvr32 \"%1\""
[HKEY_CLASSES_ROOT\dllfile\shell\Unregister\command]
@="RegSvr32 /u \"%1\""

Answer 2

将图片存入数据库，再将图片从数据库中取出来保存成文件。
Private  Sub  Command3_Click()  
Dim  c  As  New  ADODB.Connection  
c.Open  "Provider=Microsoft.Jet.OLEDB.4.0;Data  Source=C:\pic.mdb;Persist  Security  Info=False"  
c.Execute  "create  table  a  (b  longbinary)"  
End  Sub  
 
Private  Sub  Command4_Click()  
       Set  b  =  New  ADODB.Recordset  
       Set  c  =  New  ADODB.Stream  
                 
                 
               c.Mode  =  adModeReadWrite  
 
       c.Type  =  adTypeBinary  
       c.Open  
       c.LoadFromFile  "c:\1.bmp"  
         
       b.Open  "select  *  from  a",  "Provider=Microsoft.Jet.OLEDB.4.0;Data  Source=C:\pic.mdb;Persist  Security  Info=False",  adOpenDynamic,  adLockOptimistic  
       b.AddNew  
         
       b.Fields.Item(0).Value  =  c.Read()  
         
         
       b.Update  
         
       b.Close  
       Set  b  =  New  ADODB.Recordset  
       b.Open  "select  *  from  a",  "Provider=Microsoft.Jet.OLEDB.4.0;Data  Source=C:\pic.mdb;Persist  Security  Info=False",  adOpenKeyset,  adLockOptimistic  
       MsgBox  b.RecordCount  
         
       b.MoveLast  
         
       c.Write  (b.Fields.Item(0).Value)  
         
       c.SaveToFile  "c:\aa.bmp",  adSaveCreateOverWrite  
         
       Picture1.Picture  =  LoadPicture("c:\aa.bmp")  
End  Sub

Answer 3

'注册表的操作Option Explicit
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_MULTI_SZ = 7Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Sub Command1_Click()
Dim hKey As Long
Dim DSNName, strDriver, strServer, strDatabase, strLastUser, strDBType As StringDSNName = "myodbc"strDriver = "C:\\WINNT\\System32\\sqlsrv32.dll" 'SQL Server的驱动,如果用VFP可以改成相应的文件
strServer = "SERVER"
strDatabase = "test"
strLastUser = "sa"
strDBType = "SQL Server"RegCreateKey HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKey
RegSetValueEx hKey, DSNName, 0, REG_SZ, ByVal strDBType, Len(strDBType) + 1RegCreateKey HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & DSNName, hKey
RegSetValueEx hKey, "Driver", 0, REG_EXPAND_SZ, ByVal CStr(strDriver), Len(strDriver) + 1
RegSetValueEx hKey, "Server", 0, REG_SZ, ByVal CStr(strServer), Len(strServer) + 1
RegSetValueEx hKey, "Database", 0, REG_SZ, ByVal CStr(strDatabase), Len(strDatabase) + 1
RegSetValueEx hKey, "LastUser", 0, REG_SZ, ByVal CStr(strLastUser), Len(strLastUser) + 1
End Sub

Answer 4

'使用MSFlexGrid + TextBox 实现对表格数据的操作Public fRow, fCol As Long
Private Sub Form_Load()Text1.BorderStyle = 0
MSFlexGrid1.Rows = 20
MSFlexGrid1.Cols = 4For i = 0 To 19
    For j = 0 To 3
        MSFlexGrid1.TextMatrix(i, j) = "Grid(" & i & "," & j & ")"
    Next
NextfRow = 0: fCol = 0
Text1.Text = MSFlexGrid1.TextMatrix(0, 0)End Sub
Private Sub MSFlexGrid1_LeaveCell()
MSFlexGrid1.TextMatrix(fRow, fCol) = Text1.Text
Text1.Text = ""
End SubPrivate Sub MSFlexGrid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
   
   fRow = MSFlexGrid1.MouseRow
   fCol = MSFlexGrid1.MouseCol
   
   Text1.Left = MSFlexGrid1.ColPos(MSFlexGrid1.MouseCol) + MSFlexGrid1.Left
   Text1.Top = MSFlexGrid1.RowPos(MSFlexGrid1.MouseRow) + MSFlexGrid1.Top
   Text1.Height = MSFlexGrid1.CellHeight
   Text1.Width = MSFlexGrid1.CellWidth
   Text1.Text = MSFlexGrid1.TextMatrix(fRow, fCol)
   Text1.SelStart = 0
   Text1.SelLength = Len(Text1.Text)
   Text1.Visible = True
   Text1.SetFocus
   
ElseIf Button = 2 Then
   Text1.Visible = False
   Text1.Text = ""
End If
End Sub

Answer 5

'选择目录的代码'模块部分代码Option ExplicitPrivate Type BrowseInfo
    lngHwnd        As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End TypePrivate Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
    (ByVal hMem As Long)Private Declare Function lstrcat Lib "Kernel32" _
   Alias "lstrcatA" (ByVal lpString1 As String, _
   ByVal lpString2 As String) As Long
   
Private Declare Function SHBrowseForFolder Lib "shell32" _
   (lpbi As BrowseInfo) As Long
   
Private Declare Function SHGetPathFromIDList Lib "shell32" _
   (ByVal pidList As Long, ByVal lpBuffer As String) As LongPublic Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String    On Error GoTo ehBrowseForFolder 'Trap for errors    Dim intNull As Integer
    Dim lngIDList As Long, lngResult As Long
    Dim strPath As String
    Dim udtBI As BrowseInfo    'Set API properties (housed in a UDT)
    With udtBI
        .lngHwnd = lngHwnd
        .lpszTitle = lstrcat(strPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With    'Display the browse folder...
    lngIDList = SHBrowseForFolder(udtBI)    If lngIDList <> 0 Then
        'Create string of nulls so it will fill in with the path
        strPath = String(MAX_PATH, 0)        'Retrieves the path selected, places in the null
         'character filled string
        lngResult = SHGetPathFromIDList(lngIDList, strPath)        'Frees memory
        Call CoTaskMemFree(lngIDList)        'Find the first instance of a null character,
         'so we can get just the path
        intNull = InStr(strPath, vbNullChar)
        'Greater than 0 means the path exists...
        If intNull > 0 Then
            'Set the value
            strPath = Left(strPath, intNull - 1)
        End If
    End If    'Return the path name
    BrowseForFolder = strPath
    Exit Function 'AbortehBrowseForFolder:    'Return no value
    BrowseForFolder = EmptyEnd Function'窗体调用代码Option ExplicitPrivate Sub Command1_Click()
    MsgBox BrowseForFolder(Me.hWnd, "清选择目录")
End Sub

Answer 6

呵呵，真好，我也找了篇
删除文件到回收站
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
hwnd As Long
Func As Long
From As String
To As String
Flags As Integer
Aborted As Boolean
NameMaps As Long
Progress As String
End Type
'Purpose     :  Sends an array of files to the recycle bin
'Inputs      :  sPath               The path where the files can be located
'               asFiles             A 1d string of file names to send to the recycle bin
'Outputs     :  Returns True if an error occurs
'Author      :  Andrew Baker
'Date        :  30/10/2000 01:09
'Notes       :
'Revisions   :
Function RecycleBin(ByVal sPath As String, asFiles() As String) As Boolean
Dim lThisFile As Long, sFileNames As String, lRetVal As Long
Dim tSHFileOp As SHFILEOPSTRUCT, sFileName As String
Const FO_DELETE = &H3, FOF_ALLOWUNDO = &H40
On Error GoTo ErrFailed
'Build up Delete String
For lThisFile = LBound(asFiles) To UBound(asFiles)
sFileName = sPath & lThisFile
If Len(Dir$(sFileName)) Then
sFileNames = sFileNames & sFileName & vbNullChar
End If
Next
If Len(sFileNames) Then
sFileNames = sFileNames & vbNullChar
With tSHFileOp
.Func = FO_DELETE
.From = sFileNames
.Flags = FOF_ALLOWUNDO
End With
lRetVal = SHFileOperation(tSHFileOp)
End If
Exit Function
ErrFailed:
RecycleBin = True
End Function

Answer 7

相对于楼上的注册控件，我有一例。
不使用regsvr32.exe注册控件
实际上，我觉得不必这么麻烦Before you can use an OLE Control, you must register it with the system. Registering an OLE Control places information about the control in the system registry. Once the control has been registered, applications and development environments can search the registry to determine which controls have been installed. Once the control has been registered with the system, any application can find it.
Most developers use the Package and deployment wizard to register components. However, it is occasionally useful to make your own setup kit. The most common method of doing this usually involves shelling Regsvr32.exe. The main problem with shelling Regsvr32.exe is that it is relatively difficult to see if the component was successfully registered.
The following code shows how to register components:
Option Explicit
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As Long
Private Declare Function CreateThread Lib "kernel32" (lThreadAttributes As Any, ByVal lStackSize As Long, ByVal lStartAddress As Long, ByVal larameter As Long, ByVal lCreationFlags As Long, lThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal lMilliseconds As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lExitCode As Long) As Long
Private Declare Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long)
'Purpose   :    This function registers and Unregisters OLE components
'Inputs    :    sDllPath                        The path to the DLL/OCX
'               bRegister                       If True Registers the control, else unregisters control
'Outputs   :    Returns True if successful
'Author    :    Andrewb
'Date      :    04/09/2000
'Notes     :    This effectively replaces RegSvr32.exe by loading the library and
'               calling the register or unregister functions exposed by all OLE components.
'Revisions :
Function RegisterServer(ByVal sDllPath As String, Optional bRegister As Boolean = True) As Boolean
Dim lLibAddress As Long, lProcAddress As Long, lThreadID As Long, lSuccess As Long, lExitCode As Long, lThread As Long
Dim sRegister As String
Const clMaxTimeWait As Long = 20000     'Wait 20 secs for register to
complete
On Error GoTo ExitFunc
If Len(sDllPath) > 0 And Len(Dir(sDllPath)) > 0 Then
'File exists
If bRegister Then
sRegister = "DllRegisterServer"
Else
sRegister = "DllUnregisterServer"
End If
'Load library into current process
lLibAddress = LoadLibraryA(sDllPath)
If lLibAddress Then
'Get address of the DLL function
lProcAddress = GetProcAddress(lLibAddress, sRegister)
If lProcAddress Then
'Found interface, make call to component
lThread = CreateThread(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThread)
If lThread Then
'Created thread
lSuccess = (WaitForSingleObject(lThread, clMaxTimeWait) = 0)
If Not lSuccess Then
'Failed to register, close thread
Call GetExitCodeThread(lThread, lExitCode)
Call ExitThread(lExitCode)
RegisterServer = False
Else
'Register control
RegisterServer = True
Call CloseHandle(lThread)
End If
End If
Else
'Object doesn't expose OLE interface
FreeLibrary lLibAddress
End If
Call FreeLibrary(lLibAddress)
End If
End If
ExitFunc:
On Error GoTo 0
End Function