vb6 可以从内存中加载DLL么?(100分）进来的都是高手！

[iland9876543210]

.net 程序可以从内存加载DLL，那么有没有方法在VB6.0里实现同样的功能？

[帝企鹅已被占用]

不小心进来了。
。net是怎么加的？

[threenewbee]

所谓 dll，指一个dll后缀的文件。
所谓加载，肯定是往内存里面加载。

lz问得莫名其妙。

[lyserver]

标准DLL都是操作系统先加载到内存后，然后由应用程序从内存中加载一个副本，因此可以说都是从内存中加载的，加载函数为LoadLibrary。

[嗷嗷叫的老马]

蓝色标题??

[a1875566250]

VB6的声明API，在调用时就是使用动态加载的方式的，我不懂ASM，不过网上有个加ASM的动态运行DLL内函数，Win7下仍正常，LZ可以去看看。

[iland9876543210]

非常感谢各位！

.net 可以通过Assembly.Load加载实现，把一个DLL文件以二进制形式先读到内存中，然后加载。

gukuang78说的很有道理，感觉应该像你说的那样处理，能否给个具体点的例子。


谢了！

[threenewbee]

[Quote=引用 8 楼 iland9876543210 的回复:]
非常感谢各位！

.net 可以通过Assembly.Load加载实现，把一个DLL文件以二进制形式先读到内存中，然后加载。

gukuang78说的很有道理，感觉应该像你说的那样处理，能否给个具体点的例子。


谢了！
[/Quote]

VB调用COM的DLL使用 CreateObject(progid) 即可。
VB调用.NET DLL方法同COM，需要先包装成COM
VB调用传统DLL，需要使用LoadLibrary()这样的办法，因为VB不支持指针，可以将这些代码用VC写好再在VB里面调用。

[笨狗先飞]

网上的,没有试过

VB动态调用外部API函数的方法
'********************************************************************************
'
'Name.......... APIClass
'File.......... APIClass.cls
'Version....... 1.0.0
'Dependencies.. kernel32.DLL
'Author........ Zhou Wen Xing
'Date.......... Apr, 17nd 2008
'UpdateURL..... http://bbs.rljy.com/?m=vbAPIClass
'
'Copyright (c) 2008 bywww.rljy.com
'Liuzhou city, China
'
'********************************************************************************
Option Explicit
'==============================================================================
'数据类型定义
'==============================================================================
Private Type VariableBuffer
VariableParameter() As Byte
End Type
'==============================================================================
'API 函数声明
'==============================================================================
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private 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
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
'==============================================================================
'成员定义
'==============================================================================
'类中的全局变量
Private m_opIndex As Long
Private m_OpCode() As Byte
'********************************************************************************
'** 作 者 ： 人类(Supermanking)
'** 函 数 名 ： ExecuteAPI
'** 输 入 ： LIBPath(String) - 刷新的目标窗口句柄，可为0
'** ： APIScript(String) - 场景图像的宽度
'** 返 回 ： (Long) - 返回零表示失败，非零表示成功
'** 功能描述 ： 动态执行类库里的API函数
'** 创建日期 ： 2008-04-17
'** 修 改 人 ：
'** 修改日期 ：
'** 版 本 ： Version 1.0.0
'********************************************************************************
Public Function ExecuteAPI(LIBPath As String, APIScript As String) As Long
Dim hProcAddress As Long, hModule As Long, x As Long, y As Long
Dim RetLong As Long, FunctionName As String, FunctionParameter As String
Dim LongCount As Long, StringInfo As String, StrByteArray() As VariableBuffer
Dim StringSize As Long, ByteArray() As Byte, IsHaveParameter As Boolean
Dim ParameterArray() As String, OutputArray() As Long
StringSize = 0
ReDim StrByteArray(StringSize)
'识别函数名称
RetLong = InStr(1, APIScript, " ", vbTextCompare)
If RetLong = 0 Then
'没有参数的函数
FunctionName = APIScript
IsHaveParameter = False
Else
'带参数的函数
FunctionName = Left(APIScript, RetLong - 1)
IsHaveParameter = True

'识别函数参数
FunctionParameter = Right(APIScript, Len(APIScript) - RetLong)

'分析函数参数
ParameterArray = Split(FunctionParameter, ",")

'初始化函数内存大小
ReDim OutputArray(UBound(ParameterArray))

'格式化函数参数
For x = 0 To UBound(ParameterArray)
If IsNumeric(Trim(ParameterArray(x))) = True Then
LongCount = CLng(Trim(ParameterArray(x)))
OutputArray(x) = LongCount
Else
StringInfo = Mid(Trim(ParameterArray(x)), 2, Len(ParameterArray(x)) - 3)
If Len(StringInfo) = 0 Then
OutputArray(x) = CLng(VarPtr(Null))
Else
ReDim Preserve StrByteArray(StringSize)
ByteArray = StrConv(StringInfo, vbFromUnicode)
ReDim Preserve StrByteArray(StringSize).VariableParameter(UBound(ByteArray) + 1)
CopyMemory StrByteArray(StringSize).VariableParameter(0), ByteArray(0), UBound(ByteArray) + 1
OutputArray(x) = CLng(VarPtr(StrByteArray(StringSize).VariableParameter(0)))
StringSize = StringSize + 1
End If
End If
Next x
ReDim m_OpCode(400 + 6 * UBound(OutputArray)) '保留用来写m_OpCode
End If

'读取API库
hModule = LoadLibrary(ByVal LIBPath)
If hModule = 0 Then
ExecuteAPI = 0 'Library 读取失败
Exit Function
End If

'取得函数地址
hProcAddress = GetProcAddress(hModule, ByVal FunctionName)
If hProcAddress = 0 Then
ExecuteAPI = 0 '函数读取失败
FreeLibrary hModule
Exit Function
End If

If IsHaveParameter = True Then
'带参数的情况在此执行
ExecuteAPI = CallWindowProc(GetCodeStart(hProcAddress, OutputArray), 0, 1, 2, 3)
Else
'不带参数的情况在此执行
ExecuteAPI = CallWindowProc(hProcAddress, 0, 1, 2, 3)
End If

'释放库空间
FreeLibrary hModule
End Function

Private Function GetCodeStart(ByVal lngProc As Long, arrParams() As Long) As Long
Dim lngIndex As Long, lngCodeStart As Long
lngCodeStart = (VarPtr(m_OpCode(0)) Or &HF) + 1
m_opIndex = lngCodeStart - VarPtr(m_OpCode(0))
For lngIndex = 0 To m_opIndex - 1
m_OpCode(lngIndex) =
Next lngIndex
For lngIndex = UBound(arrParams) To 0 Step -1
AddByteToCode
AddLongToCode arrParams(lngIndex)
Next lngIndex
AddByteToCode
AddLongToCode lngProc - VarPtr(m_OpCode(m_opIndex)) - 4
AddByteToCode
AddByteToCode
AddByteToCode
GetCodeStart = lngCodeStart
End Function

Private Sub AddLongToCode(lData As Long)
CopyMemory m_OpCode(m_opIndex), lData, 4
m_opIndex = m_opIndex + 4
End Sub

Private Sub AddIntToCode(iData As Integer)
CopyMemory m_OpCode(m_opIndex), iData, 2
m_opIndex = m_opIndex + 2
End Sub

Private Sub AddByteToCode(bData As Byte)
m_OpCode(m_opIndex) = bData
m_opIndex = m_opIndex + 1
End Sub

Private Sub Command1_Click()
Dim API As New APIClass
Dim APIScript As String
'最简单的调用API函数
APIScript = "MessageBoxA 0, ""这是动态调用API函数显示的MSGBOX内容，下面将要在作面画一笔。"", ""API信息提示"", 0"
API.ExecuteAPI "C:\WINDOWS\system32\user32.dll", APIScript

'=============在作面画画============
Dim DesktophWnd As Long, DesktophDC As Long
'取得桌面窗口句柄
DesktophWnd = API.ExecuteAPI("C:\WINDOWS\system32\user32.dll", "GetDesktopWindow")
'取得桌面窗口设备句柄
DesktophDC = API.ExecuteAPI("C:\WINDOWS\system32\user32.dll", "GetWindowDC " & DesktophWnd)
'在作面设备上画一条线
API.ExecuteAPI "C:\WINDOWS\system32\gdi32.dll", "LineTo " & DesktophDC & "," & Screen.Width / 15 & "," & Screen.Height / 15
End Sub

[笨狗先飞]

'********************************************************************************
'
'Name.......... APIClass
'File.......... APIClass.cls
'Version....... 1.0.0
'Dependencies.. kernel32.DLL
'Author........ Supermanking
'Date.......... Apr, 17nd 2008
'UpdateURL..... http://bbs.rljy.com/?m=vbAPIClass
'
'Copyright (c) 2008 bywww.rljy.com
'Liuzhou city, China
'
'********************************************************************************
Option Explicit
'==============================================================================
'数据类型定义
'==============================================================================
Private Type VariableBuffer
VariableParameter() As Byte
End Type
'==============================================================================
'API 函数声明
'==============================================================================
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private 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
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
'==============================================================================
'成员定义
'==============================================================================
'类中的全局变量
Private m_opIndex As Long
Private m_OpCode() As Byte
'********************************************************************************
'** 作 者 ： 人类(Supermanking)
'** 函 数 名 ： ExecuteAPI
'** 输 入 ： LIBPath(String) - 刷新的目标窗口句柄，可为0
'** ： APIScript(String) - 场景图像的宽度
'** 返 回 ： (Long) - 返回零表示失败，非零表示成功
'** 功能描述 ： 动态执行类库里的API函数
'** 创建日期 ： 2008-04-17
'** 修 改 人 ：
'** 修改日期 ：
'** 版 本 ： Version 1.0.0
'********************************************************************************
Public Function ExecuteAPI(LibPath As String, APIScript As String) As Long
Dim hProcAddress As Long, hModule As Long, X As Long, Y As Long
Dim RetLong As Long, FunctionName As String, FunctionParameter As String
Dim LongCount As Long, StringInfo As String, StrByteArray() As VariableBuffer
Dim StringSize As Long, ByteArray() As Byte, IsHaveParameter As Boolean
Dim ParameterArray() As String, OutputArray() As Long
StringSize = 0
ReDim StrByteArray(StringSize)
'识别函数名称
RetLong = InStr(1, APIScript, " ", vbTextCompare)
If RetLong = 0 Then
'没有参数的函数
FunctionName = APIScript
IsHaveParameter = False
Else
'带参数的函数
FunctionName = Left(APIScript, RetLong - 1)
IsHaveParameter = True

'识别函数参数
FunctionParameter = Right(APIScript, Len(APIScript) - RetLong)

'分析函数参数
ParameterArray = Split(FunctionParameter, ",")

'初始化函数内存大小
ReDim OutputArray(UBound(ParameterArray))

'格式化函数参数
For X = 0 To UBound(ParameterArray)
If IsNumeric(Trim(ParameterArray(X))) = True Then
LongCount = CLng(Trim(ParameterArray(X)))
OutputArray(X) = LongCount
Else
StringInfo = Mid(Trim(ParameterArray(X)), 2, Len(ParameterArray(X)) - 3)
If Len(StringInfo) = 0 Then
OutputArray(X) = CLng(VarPtr(Null))
Else
ReDim Preserve StrByteArray(StringSize)
ByteArray = StrConv(StringInfo, vbFromUnicode)
ReDim Preserve StrByteArray(StringSize).VariableParameter(UBound(ByteArray) + 1)
CopyMemory StrByteArray(StringSize).VariableParameter(0), ByteArray(0), UBound(ByteArray) + 1
OutputArray(X) = CLng(VarPtr(StrByteArray(StringSize).VariableParameter(0)))
StringSize = StringSize + 1
End If
End If
Next X
ReDim m_OpCode(400 + 6 * UBound(OutputArray)) '保留用来写m_OpCode
End If

'读取API库
hModule = LoadLibrary(ByVal LibPath)
If hModule = 0 Then
ExecuteAPI = 0 'Library 读取失败
Exit Function
End If

'取得函数地址
hProcAddress = GetProcAddress(hModule, ByVal FunctionName)
If hProcAddress = 0 Then
ExecuteAPI = 0 '函数读取失败
FreeLibrary hModule
Exit Function
End If

If IsHaveParameter = True Then
'带参数的情况在此执行
ExecuteAPI = CallWindowProc(GetCodeStart(hProcAddress, OutputArray), 0, 1, 2, 3)
Else
'不带参数的情况在此执行
ExecuteAPI = CallWindowProc(hProcAddress, 0, 1, 2, 3)
End If

'释放库空间
FreeLibrary hModule
End Function

Private Function GetCodeStart(ByVal lngProc As Long, arrParams() As Long) As Long
Dim lngIndex As Long, lngCodeStart As Long
lngCodeStart = (VarPtr(m_OpCode(0)) Or &HF) + 1
m_opIndex = lngCodeStart - VarPtr(m_OpCode(0))
For lngIndex = 0 To m_opIndex - 1
m_OpCode(lngIndex) = &HCC
Next lngIndex
For lngIndex = UBound(arrParams) To 0 Step -1
AddByteToCode &H68
AddLongToCode arrParams(lngIndex)
Next lngIndex
AddByteToCode &HE8
AddLongToCode lngProc - VarPtr(m_OpCode(m_opIndex)) - 4
AddByteToCode &HC2
AddByteToCode &H10
AddByteToCode &H0
GetCodeStart = lngCodeStart
End Function

Private Sub AddLongToCode(lData As Long)
CopyMemory m_OpCode(m_opIndex), lData, 4
m_opIndex = m_opIndex + 4
End Sub

Private Sub AddIntToCode(iData As Integer)
CopyMemory m_OpCode(m_opIndex), iData, 2
m_opIndex = m_opIndex + 2
End Sub

Private Sub AddByteToCode(bData As Byte)
m_OpCode(m_opIndex) = bData
m_opIndex = m_opIndex + 1
End Sub

[chinaboyzyq]

你应该说VB6如何调用DLL

[gukuang78]

基本步骤：
使用LoadLibrary载入DLL
使用GetProcAddress取得函数地址
使用CallWindowProc运行此函数
运行完成后，使用FreeLibrary释放DLL

具体源码，网上有好多。记得有个HookAPIS例程比较不错。

[iland9876543210]

灰常感谢bakw(好好潜水,天天UP) 友情支持！


试一下先。