[Visual Basic] 纯文本查看 复制代码'一个双向链表类 (StrList)
Option Explicit
'分配,清除内存
Private Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "KERNEL32" (ByVal hMem As Long) As Long
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
'复制内存
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private headNode As clsUartNode '头节点
Private curNode As clsUartNode '当前节点
Private endNode As clsUartNode '尾巴节点
Private mvarSize As Integer '节点总数
Private bolFlagGetCmd As Boolean '是否有指令被取出,true为是
'申请内存
Private Function MemAlloc(ByVal dwBytes As Long)
MemAlloc = GlobalAlloc(GMEM_FIXED Or GMEM_ZEROINIT, dwBytes)
End Function
'**************************************************************************************************************
'Public Sub Add(bytArrSendData() As Byte)
'功能 : 增加节点,bytArrSendData(Byte) 将值加入到链表中
'参数 : bytArrSendData() 发送指令的数组,以0为最小下标;
' intSendDataCount 发送数据字节数;
' lngModbusAddr 发送数据的modbus地址 ;
'返回 : 无
'修改历史 :
'**************************************************************************************************************
Public Sub Add(bytArrSendData() As Byte, lngModbusAddr As Long, Optional enmParaType As ParaTypeTag = PT_General, Optional intCtlIndex As Integer = -1)
Dim node As New clsUartNode '新增一个节点
Dim tPtr As Long
Dim intSendArrCount As Integer
intSendArrCount = UBound(bytArrSendData) + 1
tPtr = MemAlloc(intSendArrCount)
If tPtr = 0 Then Err.Raise 0, , "内存不足"
CopyMemory ByVal tPtr, bytArrSendData(0), intSendArrCount '节点赋值
node.ptrSendData = tPtr
node.lngModbusAddr = lngModbusAddr
node.intCtlIndex = intCtlIndex
node.ParaType = enmParaType
node.intSendDataCount = intSendArrCount
Set node.preNode = endNode '新节点加入到链表尾巴 Node-->endNode-->
If headNode Is Nothing Then '加入的节点是第一个节点的处理
Set headNode = node '头节点就是这一个
Set curNode = node '当前节点是第一个节点
Else
Set endNode.nextNode = node '新加的话,终节点指向本节点
End If
Set endNode = node
mvarSize = mvarSize + 1
End Sub
'**************************************************************************************************************
'Public Sub Clear()
'功能 : 清除所有节点
'参数 :
'返回 : 无
'修改历史 :
'**************************************************************************************************************
Public Sub Clear()
Dim tPtr As Long
Dim i As Integer
If mvarSize > 0 Then
For i = 1 To mvarSize
'MsgBox i
Set curNode = headNode.nextNode '头节点下移
tPtr = headNode.ptrSendData
Call GlobalFree(tPtr)
tPtr = headNode.ptrRecvData
Call GlobalFree(tPtr)
Set headNode = curNode
If i <> mvarSize Then
Set headNode.preNode = Nothing '头节点清除
End If
Next
End If
Set headNode = Nothing
Set endNode = Nothing
Set curNode = Nothing
mvarSize = 0
bolFlagGetCmd = False
End Sub
……