matlab dll vba,vba 引用 DLL 感悟

**************************手工引用

Sub Xz_注册窗体()

On Error GoTo err

Shell "regsvr32 /s " & VBA.Chr(34) & ThisWorkbook.Path & "\DLLYP.DLL" & VBA.Chr(34), vbHide

UF注册窗体.Show

Exit Sub

err:

MsgBox "程序在注册DLL出错!"

End Sub

Private Sub UserForm_Initialize()

Dim ABCD As New Class1

Me.TextBox1.Text = ABCD.DLLyPxlhNo()

Set ABCD = Nothing

End Sub

********************自动引用

Private Sub UserForm_Initialize()

On Error GoTo err

Dim ABCD As Object

Shell "regsvr32 /s " & Chr(34) & ThisWorkbook.Path & "\yPxlh.dll" & Chr(34), vbHide

Set ABCD = CreateObject("yPxlh.DLLyPxlh")

Me.TextBox1.Text = ABCD.DLLyPxlhNo()

Set ABCD = Nothing

Exit Sub

err:

MsgBox "程序在注册DLL出错!"

End Sub

DLLyPxlh 属性名

yPxlh dll名

DLLyPxlhNo模块名

不可以用Class1类名

为这个研究一天，备忘！！

******************************************网上下载修改

Option Explicit

'以下这一行是必须的，困为要做结构复制。而结构中有数组。所以，没有它则会错位

Option Base 0

Private Const DFP_GET_VERSION = &H74080

Private Const DFP_SEND_DRIVE_COMMAND = &H7C084

Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088

Private Type TGETVERSIONOUTPARAMS

bVersion As Byte '二进制驱动版本

bRevision As Byte '二进制驱动程序修订版

bReserved As Byte '未使用

bIDEDeviceMap As Byte '跟踪IDE设备映射

fCapabilities As Long '跟踪驱动程序能力的映射

dwReserved(4) As Long '作为以后使用

End Type

Private Type TIDEREGS

bFeaturesReg As Byte

bSectorCountReg As Byte

bSectorNumberReg As Byte

bCylLowReg As Byte

bCylHighReg As Byte

bDriveHeadReg As Byte

bCommandReg As Byte

bReserved As Byte

End Type

Private Type TSENDCMDINPARAMS

cBufferSize As Long

irDriveRegs As TIDEREGS

bDriveNumber As Byte

bReserved(2) As Byte

dwReserved(3) As Long

End Type

Private Type TDRIVERSTATUS

bDriverError As Byte

bIDEStatus As Byte

bReserved(1) As Byte

dwReserved(1) As Long

End Type

Private Type TSENDCMDOUTPARAMS

cBufferSize As Long

DRIVERSTATUS As TDRIVERSTATUS

bBuffer(511) As Byte

End Type

'下面的结构是要从另一结构复制数据过来的，所以，必须是字节数与VC的完全一致

'而不能用兼容变量，但这里的我们还是用了兼容变量，Integer,因为此结构中这一

'类型的的变量程序中没有用到，如果要用到，建议改为Byte类型。因为VBA没有USHORT

Private Type TIDSECTOR

wGenConfig As Integer

wNumCyls As Integer

wReserved As Integer

wNumHeads As Integer

wBytesPerTrack As Integer

wBytesPerSector As Integer

wSectorsPerTrack As Integer

wVendorUnique(2) As Integer

sSerialNumber(19) As Byte

wBufferType As Integer

wBufferSize As Integer

wECCSize As Integer

sFirmwareRev(7) As Byte

sModelNumber(39) As Byte

wMoreVendorUnique As Integer

wDoubleWordIO As Integer

wCapabilities As Integer

wReserved1 As Integer

wPIOTiming As Integer

wDMATiming As Integer

wBS As Integer

wNumCurrentCyls As Integer

wNumCurrentHeads As Integer

wNumCurrentSectorsPerTrack As Integer

ulCurrentSectorCapacity(3) As Byte   '这里只能用byte，因为VBA没有无符号的LONG型变量

wMultSectorStuff As Integer

ulTotalAddressableSectors(3) As Byte '这里只能用byte，因为VBA没有无符号的LONG型变量

wSingleWordDMA As Integer

wMultiWordDMA As Integer

bReserved(127) As Byte

End Type

Private vers As TGETVERSIONOUTPARAMS

Private in_data As TSENDCMDINPARAMS

Private out_data As TSENDCMDOUTPARAMS

Private h As Long

Private i As Long

Private j As Byte

Private Type OSVERSIONINFO

dwOSVersionInfoSize As Long

dwMajorVersion As Long

dwMinorVersion As Long

dwBuildNumber As Long

dwPlatformId As Long

szCSDVersion As String * 128

End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _

(LpVersionInformation As OSVERSIONINFO) As Long

Private Const VER_PLATFORM_WIN32S = 0

Private Const VER_PLATFORM_WIN32_WINDOWS = 1

Private Const VER_PLATFORM_WIN32_NT = 2

Private Declare Function CreateFile Lib "kernel32" _

Alias "CreateFileA" (ByVal lpFileName As String, _

ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _

ByVal lpSecurityAttributes As Long, _

ByVal dwCreationDisposition As Long, _

ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) _

As Long

Private Const CREATE_NEW = 1

Private Const GENERIC_READ = &H80000000

Private Const GENERIC_WRITE = &H40000000

Private Const OPEN_EXISTING = 3

Private Const FILE_SHARE_READ = &H1

Private Const FILE_SHARE_WRITE = &H2

Private Type OVERLAPPED

Internal As Long

InternalHigh As Long

offset As Long

OffsetHigh As Long

hEvent As Long

End Type

Private Declare Function DeviceIoControl Lib "kernel32" _

(ByVal hDevice As Long, ByVal dwIoControlCode As Long, _

lpInBuffer As Any, ByVal nInBufferSize As Long, _

lpOutBuffer As Any, ByVal nOutBufferSize As Long, _

lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _

hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private Function hdid9x() As String '硬盘序列号22-1

'当运行95/98/Me操作系统时

h = CreateFile("\\.\Smartvsd", 0, 0, 0, CREATE_NEW, 0, 0)

If h = 0 Then

hdid9x = "open smartvsd.vxd failed"

Exit Function

End If

Dim olp As OVERLAPPED

Dim lRet As Long

lRet = DeviceIoControl(h, DFP_GET_VERSION, ByVal 0&, 0, vers, Len(vers), ByVal i, olp)

If lRet = 0 Then

hdid9x = "DeviceIoControl failed:DFP_GET_VERSION"

CloseHandle (h)

Exit Function

End If

'假如IDE标识命令不支持、失败

If (vers.fCapabilities And 1) <> 1 Then

hdid9x = "Error: IDE identify command not supported."

CloseHandle (h)

Exit Function

End If

'显示IDE设备检测到的数字

Dim sPreOutStr As String

sPreOutStr = DetectIDE(vers.bIDEDeviceMap)

hdid9x = sPreOutStr

'标识IDE设备

'For j = 0 To 3

Dim phdinfo As TIDSECTOR

Dim s(40) As Byte

If (j And 1) = 1 Then

in_data.irDriveRegs.bDriveHeadReg = &HB0

Else

in_data.irDriveRegs.bDriveHeadReg = &HA0

End If

If (vers.fCapabilities And (16 \ (2 ^ j))) = (16 \ (2 ^ j)) Then

hdid9x = "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"

Else

in_data.irDriveRegs.bCommandReg = &HEC

in_data.bDriveNumber = j

in_data.irDriveRegs.bSectorCountReg = 1

in_data.irDriveRegs.bSectorNumberReg = 1

in_data.cBufferSize = 512

lRet = DeviceIoControl(h, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), ByVal i, olp)

If lRet = 0 Then

hdid9x = "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"

CloseHandle (h)

Exit Function

End If

Dim StrOut As String

CopyMemory phdinfo, out_data.bBuffer(0), Len(phdinfo)

CopyMemory s(0), phdinfo.sSerialNumber(0), 20

s(20) = 0

ChangeByteOrder s, 20

StrOut = ByteArrToString(s, 20)

hdid9x = hdid9x & StrOut

End If

CloseHandle (h)

End Function

Function DLLyPxlhNo() '-----------硬盘序列号1

'verinfo资料消息Version版本

Dim verinfo As OSVERSIONINFO

Dim Ret As Long

On Error Resume Next

Dim EB

Set EB = GetObject(, "Excel.Application")

verinfo.dwOSVersionInfoSize = Len(verinfo)

Ret = GetVersionEx(verinfo)

Dim OutStr As String

'dwPlatformId操作系统id

'OutStr全部资料

Select Case verinfo.dwPlatformId

Case VER_PLATFORM_WIN32S

MsgBox "Win32s 这程序不支持."

Exit Function

Case VER_PLATFORM_WIN32_WINDOWS

OutStr = hdid9x

DLLyPxlhNo = Trim(OutStr)

Exit Function

Case VER_PLATFORM_WIN32_NT

OutStr = hdidnt

DLLyPxlhNo = Trim(OutStr)

End Select

End Function

Private Function hdidnt() As String '-----------硬盘序列号21-1

Dim hd As String * 80

Dim phdinfo As TIDSECTOR

Dim s(40) As Byte

Dim StrOut As String

hdidnt = ""

'当运行 NT/Win2000操作系统时

hd = "\\.\PhysicalDrive" & CStr(0)

'     CreateFile 函数创建或打开下列对象，并返回一个可以用来访问这些对象的句柄。

' /文件/ pipes /邮槽/ 通信资源 / 磁盘驱动器(仅适用于 windowsNT )/控制台/ 文件夹 (仅用于打开)

h = CreateFile(hd, GENERIC_READ Or GENERIC_WRITE, _

FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)

Dim olpv As OVERLAPPED

Dim lRet As Long

lRet = DeviceIoControl(h, DFP_GET_VERSION, ByVal 0&, 0, vers, Len(vers), ByVal i, olpv)

If lRet = 0 Then

CloseHandle (h)

Else

''假如IDE标识命令不支持、失败

If (vers.fCapabilities And 1) <> 1 Then

hdidnt = "Error: IDE identify command not supported."

CloseHandle (h)

Exit Function

End If

'标识IDE设备

If (j And 1) = 1 Then

in_data.irDriveRegs.bDriveHeadReg = &HB0

Else

in_data.irDriveRegs.bDriveHeadReg = &HA0

End If

If (vers.fCapabilities And (16 \ (2 ^ j))) <> 0 Then

hdidnt = hdidnt & vbCrLf & "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"

Else

in_data.irDriveRegs.bCommandReg = &HEC

in_data.bDriveNumber = j

in_data.irDriveRegs.bSectorCountReg = 1

in_data.irDriveRegs.bSectorNumberReg = 1

in_data.cBufferSize = 512

Dim olpr As OVERLAPPED

lRet = DeviceIoControl(h, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), ByVal i, olpr)

If lRet <= 0 Then

hdidnt = hdidnt & vbCrLf & "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"

CloseHandle (h)

Else

CopyMemory phdinfo, out_data.bBuffer(0), Len(phdinfo)

CopyMemory s(0), phdinfo.sSerialNumber(0), 20

s(20) = 0

ChangeByteOrder s, 20

StrOut = ByteArrToString(s, 20)

hdidnt = hdidnt & StrOut

End If

End If

End If

End Function

Sub ChangeByteOrder(szString() As Byte, uscStrSize As Long) '-----------硬盘序列号21-2

Dim i As Long

Dim temp As String

For i = 0 To uscStrSize - 1 Step 2

temp = szString(i)

szString(i) = szString(i + 1)

szString(i + 1) = temp

Next i

End Sub

Private Function ByteArrToString(inByte() As Byte, ByVal strlen As Integer) As String '-----------硬盘序列号21-3

Dim i As Integer

For i = 0 To strlen

If inByte(i) = 0 Then

Exit For

End If

ByteArrToString = ByteArrToString & Chr(inByte(i))

Next i

End Function

Private Function DetectIDE(bIDEDeviceMap As Byte) As String '硬盘序列号22-2

If (bIDEDeviceMap And 1) Then

If (bIDEDeviceMap And 16) Then

DetectIDE = DetectIDE & "ATAPI device is attached to primary controller, drive 0."

Else

DetectIDE = DetectIDE & "IDE device is attached to primary controller, drive 0."

End If

End If

If (bIDEDeviceMap And 2) Then

If (bIDEDeviceMap And 32) Then

DetectIDE = DetectIDE & "ATAPI device is attached to primary controller, drive 1."

Else

DetectIDE = DetectIDE & "IDE device is attached to primary controller, drive 1."

End If

End If

If (bIDEDeviceMap And 4) Then

If (bIDEDeviceMap And 64) Then

DetectIDE = DetectIDE & "ATAPI device is attached to secondary controller, drive 0."

Else

DetectIDE = DetectIDE & "IDE device is attached to secondary controller, drive 0."

End If

End If

If (bIDEDeviceMap And 8) Then

If (bIDEDeviceMap And 128) Then

DetectIDE = DetectIDE & "ATAPI device is attached to secondary controller, drive 1."

Else

DetectIDE = DetectIDE & "IDE device is attached to secondary controller, drive 1."

End If

End If

End Function

Private Function ByteArrToLong(inByte() As Byte) As Double

Dim i As Integer

For i = 0 To 3

ByteArrToLong = ByteArrToLong + CDbl(inByte(i)) * (256 ^ i)

Next i

End Function