VB TreeView1+SSTab 组合用法。

最新推荐文章于 2021-09-03 10:05:49 发布

放错位的天才

最新推荐文章于 2021-09-03 10:05:49 发布

阅读量302

点赞数

文章标签：数据库

原文链接：http://www.cnblogs.com/XTHH/p/6145003.html

版权

使用最简单的控件，做出树型菜单与多标签互动。所有加载,关闭，的子窗子。均只使用了SetCapture，SendMessage 等一些常用操作窗体的API

下面我们来讲讲，具体如何实现！..

实现以上框架用到了一位大牛的无注册DLL 和网上流传的子类化SSTAB子类化模块！

首先我们来讲讲，无需注册的DLL 文件，一直以为VB 都被认为是无法做出无需注册的DLL文件，但是通过修改OBJ VB 生成EXE 时产生的链接文件修改来实现效果，这位大牛，做一款工具，可以在生成时直接导出

函数，这样我们就要吧像声明系统API 一样，来直接调用！
工具展示

1.无窗体DLL

建立一个模块。写入如下内容我们用一段连接server SQL 的模块。来演示

Private Sub Main(): End Sub
Private Function DllMain(ByVal hModule As Long, _
                       ByVal ul_reason_for_call As Long, _
                       ByVal lpReserved As Long) As Long
   DllMain = 1
End Function

在新一个模块。输入如下内容（SQL连接模块）

'连接SQL的模块
Public conn As ADODB.Connection
Public rs As ADODB.Recordset
Public iStm As ADODB.Stream
Public addFlag As Boolean
Public cmd As ADODB.Command
Public param As ADODB.Parameter
Public Function OpenCn(ByVal Cip As String, ByVal kl As String, ByVal users As String, ByVal pw As String) As Boolean '连接模块填写数据库等信息

Dim mag As String
On Error GoTo strerrmag
Set conn = New ADODB.Connection
conn.ConnectionTimeout = 2
conn.Provider = "sqloledb"
conn.Properties("data source").Value = StrConv(Cip, vbUnicode)     '服务器的名字
conn.Properties("initial catalog").Value = StrConv(kl, vbUnicode)           '库名
'conn.Properties("integrated security").Value = "SSPI"      '登陆类型
conn.Properties("user id").Value = StrConv(users, vbUnicode)   'SQL库名
conn.Properties("password").Value = StrConv(pw, vbUnicode) '密码
'sql = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;password=;Initial Catalog=pubs;Data Source=127.0.0.1"    '如果不用这个模块也行可以，这一句便是常用的引擎。
'conn.ConnectionString = sql
conn.Open
OpenCn = True
If conn.State = 1 Then addFlag = True
Exit Function
strerrmag:
     addFlag = False
             If Err.Number <> 0 Then
     MsgBox Err.Number & " " & Err.Description, 48, "错误"
End If
     Exit Function      '连接错误消息
End Function

Public Function rsado()
Set rsado = rs
End Function

'关闭数据库，释放连接
Public Sub cloCn()
On Error Resume Next
If conn.State <> adStateClosed Then conn.Close
Set conn = Nothing
End Sub

Public Function openRs(ByVal strsql As String) As Boolean      '连接数据库记录集
Dim mag As String
Dim rpy As Boolean
On Error GoTo strerrmag
     Set rs = New ADODB.Recordset
     If addFlag = False Then rpy = True
       With rs
     .ActiveConnection = conn
     .CursorLocation = adUseClient
     .CursorType = adOpenKeyset
     .LockType = adLockOptimistic
     .Open StrConv(strsql, vbUnicode)
     End With
     addFlag = True
     openRs = True
     'End        '将记录集给rs
     Exit Function
strerrmag:
     openRs = False
          If Err.Number <> 0 And InStr(1, Err.Description, "ERRO556") = 0 Then
         MsgBox Err.Number & " " & Err.Description, 48, "提示"
End If
     'Exit Function '连接错误消息
End Function
Public Function opencmd(ByVal text As String, ByVal texttype As Integer, ByVal blbm As String, ByVal blbz As String) As Boolean
Dim mag As String
Dim rpy As Boolean
Dim tf
Dim us As Integer
On Error GoTo strerrmag
Set cmd = New ADODB.Command
Set rs = New ADODB.Recordset
conn.CursorLocation = adUseClient
If addFlag = False Then rpy = True

With cmd
     .ActiveConnection = conn
   Select Case StrConv(texttype, vbUnicode)
     Case 1:
     .CommandType = adCmdText
     Case 2:
     .CommandType = adCmdTable
     Case 3:
     .CommandType = adCmdStoredProc
   End Select
   .CommandText = StrConv(text, vbUnicode)
   .NamedParameters = True
   If Len(StrConv(blbm, vbUnicode)) > 0 Then
   tf = Split(StrConv(blbm, vbUnicode), "~")
.Parameters.Append .CreateParameter("@bmz", adVarChar, adParamInput, 200, tf(0))
.Parameters.Append .CreateParameter("@xgz", adVarChar, adParamInput, 20000000, tf(1))
.Parameters.Append .CreateParameter("@jlr", adVarChar, adParamInput, 200, tf(2))
   .Parameters.Append .CreateParameter("@jlsjt", adVarChar, adParamInput, 200, tf(3))
    .Parameters.Append .CreateParameter("@ID", adVarChar, adParamInput, 200, tf(4))

   End If
     Set rs = .Execute()
     End With
     addFlag = True
     opencmd = True
strerrmag:
     opencmd = False
     If Err.Number <> 0 Then
     MsgBox Err.Number & " " & Err.Description, vbQuestion, "发生了一个错误!", 48, "提示"
End If
Set tf = Nothing
End Function

Public Sub cloRs()
On Error Resume Next
If rs.State <> adStateClosed Then rs.Clone
Set rs = Nothing '释放记录集
End Sub

‘’--以上有六个过程。opencn 连接数据。OPENRS 执行SQL 语句。OPENCMD 执行存储过程，带参数。CLOSCN CLOSrS 关闭连接和释放资源，还有RSADO 要注意上面接收时使用的StrConv(strsql, vbUnicode) 。不然会乱码

在安装大牛马的工具后。生成DLL 时，就会出现如图“

我们选中所需要导出的函数后，点击确认

此时，DLL 文件就制作好，我们如何来使用它呢。看下文

Private Declare Function OpenCn Lib "Std_DLL.dll" (ByVal Cip As String, ByVal kl As String, ByVal users As String, ByVal pw As String) As Boolean '连接数据库
Private Declare Function opencmd Lib "Std_DLL.dll" (ByVal text As String, ByVal texttype As Integer, ByVal blbm As String, ByVal blbz As String) As Boolean '传参查询，执行存储过程
Private Declare Sub cloRs Lib "Std_DLL.dll" ()
Private Declare Sub cloCn Lib "Std_DLL.dll" ()
Private Declare Function rsado Lib "Std_DLL.dll" ()yVal text As String, ByVal texttype As Integer, ByVal blbm As String, ByVal blbz As String) As Boolean '传参查询，执行存储过程

像声明系统的API 一样，写上名称和参数类型即可。（最注要的是，此时你会发现，此DLL 是无需用REGSVR32 来注册的，放在程序目录中，或是丢在SYSTEM32 中就可以直接使用了）

运行效果如下图

1，当然能生成DLL 无窗体，也可以DLL带窗体，只是需要在处理下！

打开工程，新建模块。

输入以下内容

Option Explicit

Private Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function ReadProcessMemory Lib "Kernel32" (ByVal hProcess As Long, _
ByVal lpBaseAddress As Long, _
ByRef lpBuffer As Any, ByVal nSize As Long, _
ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetCurrentProcessId Lib "Kernel32" () As Long
Private Declare Function SetErrorMode Lib "Kernel32" (ByVal wMode As Long) As Long
Private Declare Function VBDllGetClassObject Lib "MSVBVM60.dll" (g1 As Long, _
g2 As Long, ByVal g3_vbHeader As Long, _
REFCLSID As Long, pREFIID As Any, ppv As Long) As Long

Private Const SEM_NOGPFAULTERRORBOX As Long = 2&
Private Const PROCESS_VM_READ As Long = 16&

Private m_lMainThread As Long
Private m_lMainHandle As Long
Private m_lFakeHeader As Long

' - - - - - - - - - - - - - - -
Private Sub Main(): End Sub ' 不要修改或删除这行！！！
' - - - - - - - - - - - - - - -

Private Function MainInit(ByVal hMod As Long, ByVal hAppInst As Long) As Long
Dim aGUID(15) As Byte
Dim lDummy As Long
Dim lRetVal As Long

m_lMainHandle = hMod
m_lFakeHeader = GetFakeHeader
Call SetErrorMode(SEM_NOGPFAULTERRORBOX)
If (m_lFakeHeader) Then
aGUID(0) = 1
aGUID(8) = 192
aGUID(15) = 70
Call VBDllGetClassObject(hMod, lDummy, m_lFakeHeader, lDummy, aGUID(0), lDummy)
lRetVal = 0&
Else
lRetVal = -1&
End If
MainInit = lRetVal
End Function

Private Function GetFakeHeader() As Long
Dim bData(1023) As Byte
Dim sFakeFlag As String
Dim lDataPnt As Long
Dim lhProc As Long
Dim lRetVal As Long

sFakeFlag = ChrW$(16982) & ChrW$(8501)
lDataPnt = m_lMainHandle
lhProc = OpenProcess(PROCESS_VM_READ, 0&, GetCurrentProcessId)
If (lhProc) Then
Do
If (ReadProcessMemory(lhProc, lDataPnt, bData(0), 1024&, 0&) = 0&) Then lRetVal = 0&: Exit Do
lRetVal = InStrB(1&, bData, sFakeFlag)
If (lRetVal) Then lRetVal = lDataPnt + lRetVal - 1&: Exit Do
lDataPnt = 1020& + lDataPnt
Loop
Call CloseHandle(lhProc)
End If
GetFakeHeader = lRetVal
End Function

按照生成以上DLL 的方式，生成DLL文件即可

在自己的工作中，加上以上DLL 文件API 声明

Option Explicit

Private Declare Function MainInit Lib "DLL_Init" (ByVal hMod As Long, ByVal hAppInst As Long) As Long
Private mlHModule As Long

Private Sub Main(): End Sub

Private Function DllMain(ByVal hModule As Long, _
ByVal ul_reason_for_call As Long, _
ByVal lpReserved As Long) As Long
mlHModule = hModule
DllMain = 1
End Function

Private Sub AABCTY15(ByVal hInst As Long, ByVal tf As String, ByVal yst As Integer, zdyzd As String)
Call MainInit(mlHModule, hInst) '必须！！！
cz = StrConv(tf, vbUnicode) '获取数据连接
ys = StrConv(yst, vbUnicode)
selects = StrConv(zdyzd, vbUnicode)
Form2.Show
End Sub

如下图