实现代码如下：
#Include "windows.bi"
#Include "crt.bi"
#include "vbcompat.bi"
/'
xywh Base Struct Memory Manage [基本结构化内存管理器]
┌─┬─┬─┬─┬─┬─┬─┬─┬─┬─┬─┬─┬──┐
│01│02│03│04│05│06│07│08│09│10│11│12│ .. │
└─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴──┘
'/
Type xBsmm
' 管理器内存指针
StructMemory As Any Ptr
' 成员占用内存长度
StructLenght As UInteger
' 管理器中存在多少成员
StructCount As UInteger
' 已经申请的结构数量
AllocCount As UInteger
' 预分配内存步长
AllocStep As UInteger
' 构造函数
Declare Constructor(iItemLenght As UInteger, PreassignStep As UInteger = 32, PreassignLenght As UInteger = 0)
' 析构函数
Declare Destructor()
' 添加成员
Declare Function InsertStruct(iPos As UInteger, iCount As UInteger = 1) As UInteger
Declare Function AppendStruct(iCount As UInteger = 1) As UInteger
' 删除成员
Declare Function DeleteStruct(iPos As UInteger, iCount As UInteger = 1) As Integer
' 移动成员
Declare Function SwapStruct(iPosA As UInteger, iPosB As UInteger) As Integer
' 获取成员指针
Declare Function GetPtrStruct(iPos As UInteger) As Any Ptr
' 分配内存
Declare Function CallocMemory(iCount As UInteger) As Integer
' 重置（释放资源）
Declare Sub ReInitManage()
End Type
' 构造函数
Constructor xBsmm(iItemLenght As UInteger, PreassignStep As UInteger = 32, PreassignLenght As UInteger = 0)
StructLenght = iItemLenght
AllocStep = PreassignStep
If PreassignLenght Then
CallocMemory(PreassignLenght)
EndIf
End Constructor
' 析构函数
Destructor xBsmm()
ReInitManage()
End Destructor
' 添加成员 [成功返回idx，失败返回0]
Function xBsmm.InsertStruct(iPos As UInteger, iCount As UInteger = 1) As UInteger
' 不能添加0个成员
If iCount = 0 Then
Return 0
EndIf
' 分配内存
If StructCount + iCount > AllocCount Then
If CallocMemory(StructCount + iCount + AllocStep) = 0 Then
Return 0
EndIf
EndIf
If iPos < StructCount Then
' 插入
memmove(StructMemory + ((iPos + iCount) * StructLenght), StructMemory + (iPos * StructLenght), (StructCount - iPos) * StructLenght)
'Function = StructMemory + (iPos * StructLenght)
Function = iPos + 1
StructCount += iCount
Else
' 添加
'Function = StructMemory + (StructCount * StructLenght)
Function = StructCount + 1
StructCount += iCount
EndIf
End Function
Function xBsmm.AppendStruct(iCount As UInteger = 1) As UInteger
Return InsertStruct(StructCount, iCount)
End Function
' 删除成员
Function xBsmm.DeleteStruct(iPos As UInteger, iCount As UInteger = 1) As Integer
' 不能删除0个成员
If iCount Then
' 范围检查
If iPos Then
iPos -= 1
If iPos < StructCount Then
If iPos + iCount < StructCount Then
' 中段删除
memmove(StructMemory + (iPos * StructLenght), StructMemory + ((iPos + iCount) * StructLenght), (StructCount - (iPos + iCount)) * StructLenght)
StructCount -= iCount
Else
' 末尾删除
StructCount = iPos
EndIf
Return -1
EndIf
EndIf
EndIf
End Function
' 移动成员
Function xBsmm.SwapStruct(iPosA As UInteger, iPosB As UInteger) As Integer
' 范围检查
If (iPosA <> 0) And (iPosB <> 0) Then
iPosA -= 1
iPosB -= 1
If (iPosA < StructCount) And (iPosB < StructCount) Then
If iPosA <> iPosB Then
' 交换数据
Dim StuA As Any Ptr = malloc(StructLenght)
memmove(StuA, StructMemory + (iPosA * StructLenght), StructLenght)
memmove(StructMemory + (iPosA * StructLenght), StructMemory + (iPosB * StructLenght), StructLenght)
memmove(StructMemory + (iPosB * StructLenght), StuA, StructLenght)
Return -1
Else
' 位置相同，不需要交换
Return -1
EndIf
EndIf
EndIf
End Function
' 获取成员指针
Function xBsmm.GetPtrStruct(iPos As UInteger) As Any Ptr
If iPos Then
iPos -= 1
If iPos < StructCount Then
Return StructMemory + (iPos * StructLenght)
EndIf
EndIf
End Function
' 分配内存
Function xBsmm.CallocMemory(iCount As UInteger) As Integer
If iCount > AllocCount Then
' 增量
Dim NewMem As Any Ptr = realloc(StructMemory, iCount * StructLenght)
If NewMem Then
AllocCount = iCount
StructMemory = NewMem
Return -1
EndIf
ElseIf iCount < AllocCount Then
' 裁剪
Dim NewMem As Any Ptr = realloc(StructMemory, iCount * StructLenght)
If NewMem Then
AllocCount = iCount
StructMemory = NewMem
If iCount <= StructCount Then
' 需要裁剪数据
StructCount = iCount
EndIf
Return -1
EndIf
ElseIf iCount = 0 Then
' 清空
ReInitManage()
Else
' 不变
Return -1
EndIf
Return 0
End Function
' 重置（释放资源）
Sub xBsmm.ReInitManage()
If StructMemory Then
free(StructMemory)
StructMemory = NULL
EndIf
StructCount = 0
AllocCount = 0
End Sub
#Define CDate_Format_Error(s) Print(s):Cells.ReInitManage():Return
#Define CDate_Error(s) Print(s):Delete pObjFormat:Return 0
' CDate 函数缺省的格式字符串
Dim Shared s_CDate_DefaultFotmat As ZString * 32 = "yyyy.mm.dd.hh.mm.ss"
' 数据格式单元结构体
Type CDate_Format_Cell
' 数据格式单元类型 [ y=1 m=2 d=3 h=4 n=5 s=6 +=7 *=8 space=9 ?=10 str=0 ]
Dim iType As Integer
' 数据单元匹配的字符串
Dim sText As ZString * 60
End Type
' 数据格式解析类
Type CDate_Format
' 要处理的格式数量
Dim Cells As xBsmm = SizeOf(CDate_Format_Cell)
' 构造函数
Declare Constructor(sFormat As ZString Ptr)
' 析构函数
Declare Destructor()
End Type
' 构造函数 [处理格式化字符串]
Constructor CDate_Format(sFormat As ZString Ptr)
If sFormat = NULL Then
sFormat = @s_CDate_DefaultFotmat
EndIf
Dim iSize As Integer = strlen(sFormat)
Dim sTempAddr As ZString Ptr = sFormat
Dim iTempSize As Integer = 0
Dim iType As Integer = 0 ' 见 : 数据格式单元类型
Dim bHour As Integer = FALSE
' 自动添加一个 * 数据格式单元
Dim pCell As CDate_Format_Cell Ptr = Cells.GetPtrStruct(Cells.AppendStruct())
If pCell Then
pCell->iType = 8
pCell->sText = ""
Else
' 申请内存出错
CDate_Format_Error("malloc error")
EndIf
' 开始解析
For i As Integer = 0 To iSize - 1
iTempSize += 1
' 判断当前解析类型
Dim iCurType As Integer = 0
If Cast(UByte Ptr, sFormat)[i] = 121 Then iCurType = 1
If Cast(UByte Ptr, sFormat)[i] = 109 Then iCurType = 2
If Cast(UByte Ptr, sFormat)[i] = 100 Then iCurType = 3
If Cast(UByte Ptr, sFormat)[i] = 104 Then iCurType = 4
If Cast(UByte Ptr, sFormat)[i] = 110 Then iCurType = 5
If Cast(UByte Ptr, sFormat)[i] = 115 Then iCurType = 6
If Cast(UByte Ptr, sFormat)[i] = 46 Then iCurType = 7
If Cast(UByte Ptr, sFormat)[i] = 42 Then iCurType = 8
If Cast(UByte Ptr, sFormat)[i] = 32 Then iCurType = 9
If Cast(UByte Ptr, sFormat)[i] = 63 Then iCurType = 10
If iCurType Then
' 跳过重复的字符 [y、m、d、h、n、s]
If (iType = iCurType) AndAlso (iCurType < 10) Then
sTempAddr = @sFormat[i+1]
iTempSize = 0
Continue For
EndIf
' 先记录字符串匹配单元
If iTempSize > 1 Then
Dim pCell As CDate_Format_Cell Ptr = Cells.GetPtrStruct(Cells.AppendStruct())
If pCell Then
pCell->iType = 0
strncpy(@pCell->sText, sTempAddr, iTempSize-1)
pCell->sText[iTempSize-1] = 0
Else
' 申请内存出错
CDate_Format_Error("malloc error")
EndIf
End If
' 记录特殊匹配单元
Dim pCell As CDate_Format_Cell Ptr = Cells.GetPtrStruct(Cells.AppendStruct())
If pCell Then
pCell->iType = IIf(bHour AndAlso (iCurType = 2), 5, iCurType)
pCell->sText = ""
Else
' 申请内存出错
CDate_Format_Error("malloc error")
EndIf
sTempAddr = @sFormat[i+1]
iTempSize = 0
iType = iCurType
' 为 m 做特殊处理 [ 跟在 h 后面的时候算作 n ]
If iType < 7 Then bHour = IIf(iType = 4, TRUE, FALSE)
Else
' 其他情况
iType = 0
End If
' 检查缓冲区是否溢出 [固定字符串匹配最多支持59个字符]
If iTempSize >= 60 Then
CDate_Format_Error("buffer size max 60 byte")
EndIf
'Print Cast(UByte Ptr, sFormat)[i], sFormat[i]
Next
End Constructor
' 析构函数
Destructor CDate_Format()
Cells.ReInitManage()
End Destructor
Function CDate_CheckNumber(sText As UByte Ptr, iMin As Integer, iMax As Integer) As Integer
Dim iSize As Integer
' 判断最小长度是否合格
For i As Integer = 0 To iMin - 1
If isdigit(sText[i]) = 0 Then
Return 0
EndIf
Next
iSize = iMin
' 判断数字长度
For i As Integer = iMin To iMax - 1
If isdigit(sText[i]) Then
iSize = i + 1
EndIf
Next
' 判断最大长度是否合格
If (iSize = iMax) AndAlso isdigit(sText[iMax]) Then
Return 0
EndIf
Return iSize
End Function
Function CDate(sText As ZString Ptr, sFormat As ZString Ptr = NULL) As Double
Dim pObjFormat As CDate_Format ptr = New CDate_Format(sFormat)
If pObjFormat AndAlso pObjFormat->Cells.StructCount Then
Dim sTempAddr As UByte Ptr = sText
Dim sNumber As ZString * 16 = ""
Dim As Integer y, m, d, h, n, s
For i As Integer = 1 To pObjFormat->Cells.StructCount
Dim pCell As CDate_Format_Cell Ptr = pObjFormat->Cells.GetPtrStruct(i)
'Print pCell->iType, pCell->sText
Select Case pCell->iType
Case 0
' 字符串完全匹配
Dim iSize As Integer = strlen(@pCell->sText)
If strncmp(@pCell->sText, sTempAddr, iSize) = 0 Then
sTempAddr += iSize
Else
CDate_Error("StrComp Fail : " & pCell->sText)
EndIf
Case 1
' 匹配年
Dim iSize As Integer = CDate_CheckNumber(sTempAddr, 4, 4)
If iSize > 0 Then
memcpy(@sNumber, sTempAddr, iSize)
sNumber[iSize] = 0
y = atoi(@sNumber)
sTempAddr += iSize
Else
CDate_Error("Year Fail")
EndIf
Case 2
' 匹配月
Dim iSize As Integer = CDate_CheckNumber(sTempAddr, 1, 2)
If iSize > 0 Then
memcpy(@sNumber, sTempAddr, iSize)
sNumber[iSize] = 0
m = atoi(@sNumber)
sTempAddr += iSize
Else
CDate_Error("Month Fail")
EndIf
Case 3
' 匹配日期
Dim iSize As Integer = CDate_CheckNumber(sTempAddr, 1, 2)
If iSize > 0 Then
memcpy(@sNumber, sTempAddr, iSize)
sNumber[iSize] = 0
d = atoi(@sNumber)
sTempAddr += iSize
Else
CDate_Error("Day Fail")
EndIf
Case 4
' 匹配时
Dim iSize As Integer = CDate_CheckNumber(sTempAddr, 1, 2)
If iSize > 0 Then
memcpy(@sNumber, sTempAddr, iSize)
sNumber[iSize] = 0
h = atoi(@sNumber)
sTempAddr += iSize
Else
CDate_Error("Hour Fail")
EndIf
Case 5
' 匹配分
Dim iSize As Integer = CDate_CheckNumber(sTempAddr, 1, 2)
If iSize > 0 Then
memcpy(@sNumber, sTempAddr, iSize)
sNumber[iSize] = 0
n = atoi(@sNumber)
sTempAddr += iSize
Else
CDate_Error("Minute Fail")
EndIf
Case 6
' 匹配秒
Dim iSize As Integer = CDate_CheckNumber(sTempAddr, 1, 2)
If iSize > 0 Then
memcpy(@sNumber, sTempAddr, iSize)
sNumber[iSize] = 0
s = atoi(@sNumber)
sTempAddr += iSize
Else
CDate_Error("Second Fail")
EndIf
Case 7
' 匹配任意字符 [至少一个]
If isdigit(sTempAddr[0]) Then
Delete pObjFormat
Return 0
EndIf
Dim iOffset As Integer = 1
Do
If isdigit(sTempAddr[iOffset]) Then
Exit Do
EndIf
iOffset += 1
Loop
sTempAddr += iOffset
Case 8
' 匹配任意字符
Dim iOffset As Integer = 0
Do
If isdigit(sTempAddr[iOffset]) Then
Exit Do
EndIf
iOffset += 1
Loop
sTempAddr += iOffset
Case 9
' 匹配任意空白字符 [Space、Tab]
Dim iOffset As Integer = 0
Do
If (sTempAddr[iOffset] <> 32) AndAlso (sTempAddr[iOffset] <> 9) Then
Exit Do
EndIf
iOffset += 1
Loop
sTempAddr += iOffset
Case 10
' 匹配任意字符一个
If sTempAddr[0] And 128 Then
sTempAddr += 2
Else
sTempAddr += 1
EndIf
End Select
Next
Delete pObjFormat
Return DateSerial(y, m, d) + TimeSerial(h, n, s)
Else
' 函数执行失败返回 0
Return 0
EndIf
End Function
/'
格式化字符串说明:
y 解析年份，必须 4 位数字
m 解析月份，1 - 2 位数字，当 m 紧跟在 h 后面时，按照分钟解析
d 解析日期，1 - 2 位数字
h 解析小时，1 - 2 位数字
n 解析分钟，1 - 2 位数字
s 解析秒，1 - 2 位数字
* 解析任意字符 0 次至无限次，直到遇到数字
. 解析任意字符 1 次至无限次，直到遇到数字
? 解析任意字符 1 次，中文字符也按照一个字符计算
Space 解析空白字符(Space、Tab) 0 次至无限次
其他字符将按照完全匹配解析
*备注 : 解析格式化字符串时，会自动在最前面生成一个 *
更新计划(已知问题)：
* 和 . 两个符号根据之后匹配的内容自动匹配到特定位置（现在他们后面必须跟数字匹配）
添加对字符串 \0 结尾的处理（现在没有对 \0 结尾做处理，有缓冲区溢出风险）
'/
Dim DT As Double = CDate("当前时间为：2018年9月14日 8:30:12", "yyyy年mm月dd日 hh:mm:ss")
Print DT
Print Format(DT, "yyyy.mm.dd hh:mm:ss")
Print "----------------"
DT = CDate("当前时间为：2019年12月6日 12:5:6")
Print DT
Print Format(DT, "yyyy.mm.dd hh:mm:ss")
Sleep
地址：北京市顺义天竺空港工业区
邮编：100010
电话：13716706323
邮箱：xywhsoft@qq.com
联络人：高先生
