标签： 编程

Option Explicit
‘注册表操作
Public Declare Function RegCloseKey Lib “advapi32.dll” (ByVal hkey As Long) As Long
Private Declare Function RegCreateKey Lib “advapi32.dll” Alias “RegCreateKeyA” (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegOpenKey Lib “advapi32.dll” Alias “RegOpenKeyA” (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib “advapi32.dll” Alias “RegQueryValueExA” (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegSetValueEx Lib “advapi32.dll” Alias “RegSetValueExA” (ByVal hkey&, ByVal lpValueName$, ByVal Reserved&, ByVal dwType&, ByVal lpData$, ByVal cbData&) As Long
Private Declare Function RegSetValue Lib “advapi32.dll” Alias “RegSetValueA” (ByVal hkey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegDeleteValue Lib “advapi32.dll” Alias “RegDeleteValueA” (ByVal hkey As Long, ByVal lpValueName As String) As Long
Public Declare Function RegOpenKeyEx Lib “advapi32” Alias “RegOpenKeyExA” (ByVal hkey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Public Declare Function RegCreateKeyEx Lib “advapi32.dll” Alias “RegCreateKeyExA” (ByVal hkey&, ByVal lpSubKey$, ByVal Reserved&, ByVal lpClass$, ByVal dwOptions&, ByVal samDesired&, ByVal SecAtts&, phkResult&, lpdwDisp&) As Long
Private Declare Function RegDeleteKey Lib “advapi32.dll” Alias “RegDeleteKeyA” (ByVal hkey As Long, ByVal lpSubKey As String) As Long
Public Declare Function SHDeleteKey Lib “shlwapi.dll” Alias “SHDeleteKeyA” (ByVal hkey As Long, ByVal pszSubKey As String) As Long

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const KEY_ALL_ACCESS = (&H1F0000 Or &H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H20) And (Not &H100000)
Public Const REG_NONE = (0)
Public Const REG_SZ = (1) ‘REG_SZ ——键值存储为字符串值
Public Const REG_EXPAND_SZ = (2)
Public Const REG_BINARY = (3) ‘REG_BINARY ——键值存储为二进制值
Public Const REG_DWORD = (4) ‘REG_DWORD ——键值存储为DWORD值（双字）
Public Const REG_DWORD_BIG_ENDIAN = (5)
Public Const REG_LINK = (6)
Public Const REG_MULTI_SZ = (7)
Public Const REG_RESOURCE_LIST = (8)
Public Const REG_FULL_RESOURCE_DESCRIPTOR = (9)
Public Const REG_RESOURCE_REQUIREMENTS_LIST = (10)

Function RegQueryStringValue(ByVal hkey As Long, ByVal sValueName As String) As String
On Error Resume Next
Dim lResult As Long, lValueType As Long, sBuf As String, lDataBufSize As Long
‘retrieve nformation about the key
lResult = RegQueryValueEx(hkey, sValueName, 0, lValueType, ByVal 0, lDataBufSize)
If lResult = 0 Then
If lValueType = REG_SZ Then
‘Create a buffer
sBuf = String(lDataBufSize, Chr$(0))
‘retrieve the key’s content
lResult = RegQueryValueEx(hkey, sValueName, 0, 0, ByVal sBuf, lDataBufSize)
If lResult = 0 Then
‘Remove the unnecessary chr$(0)’s
‘RegQueryStringValue = Left$(sBuf, InStr(1, sBuf, Chr$(0)) – 1)
‘Avoid making mistakes when chr$(0) is zero
RegQueryStringValue = GetAPIString(sBuf)
End If
ElseIf lValueType = REG_BINARY Then
Dim sData As Integer
‘retrieve the key’s value
lResult = RegQueryValueEx(hkey, sValueName, 0, 0, sData, lDataBufSize)
If lResult = 0 Then
RegQueryStringValue = sData
End If
End If
End If
On Error GoTo 0
End Function

Function GetString(ByVal hkey As Long, sPath As String, ByVal sValue As String, ByVal sApp As Variant, ByVal sIniFile As Variant) ‘从注册表读取数据, 如果失败则从初始化文件读取
On Error Resume Next
Dim lResult1, lResult2
‘Open the key
lResult1 = RegOpenKey(hkey, sPath, lRet)
‘Get the key’s content
lResult2 = RegQueryStringValue(lRet, sValue)
GetString = lResult2
‘Close the key
RegCloseKey lRet
On Error GoTo 0
‘OS is diversity, determine if registry success
If IsMissing(sApp) Then Exit Function
If IsMissing(sIniFile) Then Exit Function
If lResult1 = 0 And Len(lResult2) > 0 And Not ChineseExist(lResult2) Then Exit Function ‘含汉字字符串时不一定对
On Error Resume Next
‘Read ini file, when operating Registry is fail.
GetString = ReadIniFile(sApp, sValue, sIniFile)
On Error GoTo 0
End Function

Sub SaveString(ByVal hkey As Long, ByVal sPath As String, ByVal sValue As String, ByVal sData As String, ByVal sApp As Variant, ByVal sIniFile As Variant) ‘向注册表写入数据, 如果失败则向初始化文件写入
On Error Resume Next
Dim lResult1, lResult2
‘Create a new key
lResult1 = RegCreateKey(hkey, sPath, lRet)
‘Save a string to the key
lResult2 = RegSetValueEx(lRet, sValue, 0, REG_SZ, ByVal sData, Len(sData))
‘close the key
RegCloseKey lRet
On Error GoTo 0
‘Debug.Print lResult1
‘Debug.Print lResult2
‘OS is diversity, determine if registry success
If IsMissing(sApp) Then Exit Function
If IsMissing(sIniFile) Then Exit Function
If lResult1 = 0 And lResult2 = 0 And Not ChineseExist(sData) Then Exit Sub ‘含汉字字符串时结果有问题
On Error Resume Next
‘Write ini file, when operating Registry is fail.
WriteIniFile sApp, sValue, sData, sIniFile
‘WritePrivateProfileString sApp, sValue, sData, sIniFile
On Error GoTo 0
End Sub

Sub DelSetting(ByVal hkey As Long, ByVal sPath As String, ByVal sValue As String, ByVal sApp As Variant, ByVal sIniFile As Variant) ‘删除注册表数据, 如果失败则删除初始化文件数据
On Error Resume Next
‘Debug.Print hKey
‘Debug.Print sPath
‘Debug.Print sValue
Dim lResult1, lResult2
‘Create a new key
lResult1 = RegCreateKey(hkey, sPath, lRet)
‘Delete the key’s value
lResult2 = RegDeleteValue(lRet, sValue)
‘close the key
RegCloseKey lRet
On Error GoTo 0
‘Debug.Print lResult1
‘Debug.Print lResult2
‘OS is diversity, determine if registry success
If IsMissing(sApp) Then Exit Function
If IsMissing(sIniFile) Then Exit Function
If lResult1 = 0 And hkey = HKEY_LOCAL_MACHINE Then Exit Sub ‘lResult2 = 2 or 5 含汉字字符串时须两处删除
On Error Resume Next
‘Write ini file, when operating Registry is fail.
WriteIniFile sApp, sValue, vbNullString, sIniFile
‘WritePrivateProfileString sApp, sValue, vbNullString, sIniFile
On Error GoTo 0
End Sub

Public Sub DelKey(hkey As Long, sKey As String)
‘Delete the key
lRet = RegDeleteKey(hkey, sKey)
End Sub

Public Function ChineseExist(sText) As Boolean ‘有无汉字
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “[\u4e00-\u9fa5]”
oRegExp.Global = True
ChineseExist = oRegExp.Test(sText)
Set oRegExp = Nothing
End Function

Public Function NumberSeries(ByVal sText As String) As Variant ‘提取文字中的纯数字,以数组的形式返回
Dim oRegExp As Object
Dim oMatches As Object ‘匹配字符串集合对象
Dim oMatch As Object ‘匹配字符串
Set oRegExp = CreateObject(“Vbscript.RegExp”)
Dim iCount As Integer
Dim TempArray() As Double
With oRegExp
.Global = True ‘True表示匹配所有, False表示仅匹配第一个符合项
.IgnoreCase = True ‘True表示不区分大小写, False表示区分大小写
.Pattern = “([0-9])?.+|([0-9])+” ‘匹配字符模式(不识 + – % 号)
Set oMatches = .Execute(sText) ‘执行正则查找，返回所有匹配结果的集合，若未找到，则为空
For Each oMatch In oMatches
ReDim Preserve TempArray(0 To iCount)
TempArray(iCount) = oMatch.Value
iCount = iCount + 1
Next
End With
NumberSeries = TempArray
Set oRegExp = Nothing
Set oMatches = Nothing
End Function

Public Function PureLetter(sText) As Boolean ‘纯字母
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “^[A-Za-z]+$”
oRegExp.Global = True
PureLetter = oRegExp.Test(sText)
Set oRegExp = Nothing
End Function

Public Function PureNumber(sText) As Boolean ‘纯数字
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “^[0-9]+$”
oRegExp.Global = True
PureNumber = oRegExp.Test(sText)
Set oRegExp = Nothing
End Function

Public Function ReplaceExp(ByVal sText As String, ByVal sPattern As String, ByVal sNew As String) As String ‘文字替换
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = sPattern ‘设置模板属性
oRegExp.IgnoreCase = True ‘忽略大小写
oRegExp.Global = True ‘匹配所有搜索项还是只匹配第一项
oRegExp.MultiLine = True ‘是否在多行中搜索
ReplaceExp = oRegExp.Replace(sText, sNew)
Set oRegExp = Nothing
End Function

Public Function IsUrl(ByVal sText As String) As Boolean ‘合法 Url
On Error GoTo ERR_Url
Dim oRegExp As Object
IsUrl = False
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “(((ht|f)tps?://)|(www.))([\w-]+.)+[\w-:]+(/[\w- ./?%#;&=]*)?”
oRegExp.Global = True
IsUrl = oRegExp.Test(sText)
Set oRegExp = Nothing
ERR_Url:
End Function

Public Function IsMail(ByVal sText As String) ‘合法 eMail
On Error GoTo ERR_Mail
Dim oRegExp As Object
IsMail = False
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “\w+([-+.]\w+)@\w+([-.]\w+).\w+([-.]\w+)*”
oRegExp.Global = True
IsMail = oRegExp.Test(sText)
Set oRegExp = Nothing
ERR_Mail:
End Function

Public Function ChineseCount(ByVal sText As String) As Long ‘汉字数量
Dim oRegExp As Object
Dim oMatchs As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Global = True
oRegExp.Pattern = “[\u4e00-\u9fa5]”
Set oMatchs = oRegExp.Execute(sText) ‘成功匹配的 Match 对象集合
ChineseCount = oMatchs.Count
Set oRegExp = Nothing
End Function

Public Function CheckID(ByVal sText As String, ByVal iFunction As Integer) As String ‘核查 ID, 判断证件号码是否正确, 或提取出生日期,或返回性别, 或返回年龄
Dim oItem As Object
Dim iSum As Integer
Dim FactorArray As Variant, CRCArray As Variant
Dim I As Integer
Dim sBirthDate As String
FactorArray = Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2) ‘身份证号加权因子
CRCArray = Array(“1”, “0”, “X”, “9”, “8”, “7”, “6”, “5”, “4”, “3”, “2”) ‘最后一位有效校验位
If Len(sText) = 18 Then ‘判断是否为18位
Set oRegExp = CreateObject(“Vbscript.RegExp”)
oRegExp.Pattern = “[A-Za-z0-9]{1}” ‘应用正则表达式分拆成18个1位数，此步可以应用mid函数，但正则表达式会效率会更高
oRegExp.Global = True
Set oItem = oRegExp.Execute(sText)
For I = 0 To 16
iSum = oItem(I) * FactorArray(I) + iSum
Next I
If CRCArray(iSum Mod 11) = UCase(oItem(17)) Then
Select Case iFunction
Case 1 ‘判断证件号码是否正确
CheckID = “True”
Case 2 ‘提取出生日期
CheckID = Format(Mid(sText, 7, 8), “0-00-00”)
Case 3 ‘返回性别
If oItem(16) Mod 2 = 0 Then CheckID = “Female” Else CheckID = “Male”
Case 4 ‘返回周岁年龄
sBirthDate = Format(Mid(sText, 7, 8), “0-00-00”)
If Month(sBirthDate) < Month(Date) Then CheckID = DateDiff(“yyyy”, sBirthDate, Date) ElseIf Month(sBirthDate) > Month(Date) Then
CheckID = DateDiff(“yyyy”, sBirthDate, Date) – 1
ElseIf Day(sBirthDate) > Day(Date) Then
CheckID = DateDiff(“yyyy”, sBirthDate, Date) – 1
Else
CheckID = DateDiff(“yyyy”, sBirthDate, Date)
End If
End Select
Else
CheckID = “False” ‘错误
End If
Else
CheckID = “Invalid” ‘非中国居民身份证
End If
End Function

Option Explicit
Public Const BUFFER = 256
Public Declare Function GetProfileInt Lib “kernel32” Alias “GetProfileIntA” (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal nDefault As Long) As Long
Public Declare Function GetProfileSection Lib “kernel32” Alias “GetProfileSectionA” (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Public Declare Function GetProfileString Lib “kernel32” Alias “GetProfileStringA” (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Public Declare Function GetPrivateProfileInt Lib “kernel32” Alias “GetPrivateProfileIntA” (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileSection Lib “kernel32” Alias “GetPrivateProfileSectionA” (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileString Lib “kernel32” Alias “GetPrivateProfileStringA” (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WriteProfileSection Lib “kernel32” Alias “WriteProfileSectionA” (ByVal lpAppName As String, ByVal lpString As String) As Long
Public Declare Function WriteProfileString Lib “kernel32” Alias “WriteProfileStringA” (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Public Declare Function WritePrivateProfileSection Lib “kernel32” Alias “WritePrivateProfileSectionA” (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib “kernel32” Alias “WritePrivateProfileStringA” (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Public Function WriteIniFile(ByVal sApp As String, ByVal sKey As String, ByVal sData As String, ByVal sIniFile As String) As Long
WriteIniFile = WritePrivateProfileString(sApp, sKey, sData, sIniFile)
End Function

Public Function ReadIniFile(ByVal sApp As String, ByVal sKey As String, ByVal sIniFile As String) As String
Dim sBuffer As String
sBuffer = Space$(BUFFER)
If GetPrivateProfileString(sApp, sKey, “”, sBuffer, BUFFER, sIniFile) > 0 Then
ReadIniFile = GetAPIString(sBuffer)
Else
ReadIniFile = “”
End If
End Function

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)

‘打开并绑定文件 D:/Test.dwg
Dim oDraw As Object ‘AutoCAD 多文档之一
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

‘插入表格
Dim oTable As Object
Dim dInsertPoint(2) As Double
dInsertPoint(0) = 12
dInsertPoint(1) = 12
dInsertPoint(2) = 0
Set oTable = oDraw.ModelSpace.AddTable(dInsertPoint, 6, 7, 10, 50) ‘插入点,行列数,单元格高宽

‘调整字体
Call AddTextStyle(“Standard”)

‘填充表格
oTable.SetText 0, 0, “LOAD LIST”

oTable.SetText 1, 0, “Load”
oTable.SetText 2, 0, “Rating(kW)”
oTable.SetText 3, 0, “Factor”
oTable.SetText 4, 0, “Voltage(kV)”
oTable.SetText 5, 0, “Current(A)”

oTable.SetText 1, 1, “潜污泵 A”
oTable.SetText 2, 1, “22”
oTable.SetText 3, 1, “0.8”
oTable.SetText 4, 1, “0.38”
oTable.SetText 5, 1, “=B3/(1.732×B4×B5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 2, “循环泵”
oTable.SetText 2, 2, “37”
oTable.SetText 3, 2, “0.8”
oTable.SetText 4, 2, “0.38”
oTable.SetText 5, 2, “=C3/(1.732×C4×C5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 3, “外输泵”
oTable.SetText 2, 3, “45”
oTable.SetText 3, 3, “0.8”
oTable.SetText 4, 3, “0.38”
oTable.SetText 5, 3, “=D3/(1.732×D4×D5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 4, “管道泵”
oTable.SetText 2, 4, “18.5”
oTable.SetText 3, 4, “0.8”
oTable.SetText 4, 4, “0.38”
oTable.SetText 5, 4, “=E3/(1.732×E4×E5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 5, “潜污泵 B”
oTable.SetText 2, 5, “22”
oTable.SetText 3, 5, “0.8”
oTable.SetText 4, 5, “0.38”
oTable.SetText 5, 5, “=F3/(1.732×F4×F5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 6, “照明箱”
oTable.SetText 2, 6, “20”
oTable.SetText 3, 6, “0.8”
oTable.SetText 4, 6, “0.38”
oTable.SetText 5, 6, “=G3/(1.732×G4×G5)” ‘× 改为合法的六星乘号

‘获取第4行第5列的文字
Debug.Print oTable.GetText(3, 4) ‘单元格序号基于 0

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)

‘打开并绑定文件 D:/Test.dwg
Dim oDraw As Object ‘AutoCAD 多文档之一
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

‘ 生成块定义
Dim oBlockDef As Object
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
Set oBlockDef = oDraw.Blocks.Add(insertionPnt, “TestBlock”)

‘ 块内添加圆
Dim oCircle As Object
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 0: center(1) = 0: center(2) = 0
radius = 12
Set oCircle = oBlockDef.AddCircle(center, radius)
Debug.Print “Entity Name: ” & oCircle.EntityName
Debug.Print oCircle.Handle

‘ 块内添加单行文字
Dim startPoint(0 To 2) As Double
Dim height As Double
Dim textString As String
Dim oText As Object
startPoint(0) = 15
startPoint(1) = 5
startPoint(2) = 0
height = 6
textString = “A block demo.”
Set oText = oBlockDef.AddText(textString, startPoint, height)
Debug.Print “Entity Name: ” & oText.EntityName
Debug.Print oText.Handle

‘ 插入块(块的实例化)
Dim oBlockRef As Object
insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
Set oBlockRef = oDraw.ModelSpace.InsertBlock(insertionPnt, “TestBlock”, 1#, 1#, 1#, 0)

‘ 缩放块实例
Dim basePoint(0 To 2) As Double
Dim scaleFactor As Double
basePoint(0) = 0#
basePoint(1) = 0#
basePoint(2) = 0#
scaleFactor = 10#
Call oBlockRef.ScaleEntity(basePoint, scaleFactor)

‘ 旋转块实例
Dim rotationAngle As Double
basePoint(0) = 0#
basePoint(1) = 0#
basePoint(2) = 0#
rotationAngle = 1.57 ‘弧度
Call oBlockRef.Rotate(basePoint, rotationAngle)

‘ 分解块实例
Dim oSet As Variant
oSet = oBlockRef.Explode()
For I = LBound(oSet) To UBound(oSet)
Debug.Print “Entity Name: ” & oSet(I).EntityName
Debug.Print oSet(I).Handle
Next

‘ 执行 AutoCAD 命令 Zoomextents
oAutoCAD.Zoomextents