serverdata.bas

本系统是一个报表分析查询系统

Attribute VB_Name = "ServerData"
Option Explicit

Private Type ServerInfo
 Name As String
 Port As String
 MaxLink As String
End Type

Public SrvInfo As ServerInfo
Public SrvMax As Long
Public SrvCur As Long
Public SrvStation As Long
Public Const MsgInfo = "金软提示"

'//系统的MAC地址
Public Function getSystemMAC() As String
 Dim objs As Object
 Dim obj As Object
 Dim RetValue As String
 Set objs = GetObject("winmgmts:").ExecQuery( _
      "SELECT MACAddress " & _
      "FROM Win32_NetworkAdapter " & _
      "WHERE " & _
      "((MACAddress Is Not NULL) " & _
      "AND (Manufacturer <> " & _
      "'Microsoft'))")
 For Each obj In objs
  RetValue = obj.MACAddress
  Exit For
 Next obj
 Set obj = Nothing
 Set objs = Nothing
 getSystemMAC = RetValue
End Function

'//系统的IP地址
Public Function getSystemIP() As String
 Dim RetValue As String
 Dim objWMIService As Object
 Dim colItems As Object
 Dim objitem As Object
 Set objWMIService = GetObject("winmgmts:")
 Set colItems = objWMIService.ExecQuery("select IPAddress from Win32_NetworkAdapterConfiguration where IPEnabled='TRUE'")
 For Each objitem In colItems
  RetValue = CStr(objitem.IPAddress(0))
 Next
 getSystemIP = RetValue
End Function

'//读取XML文件
Public Function getXmlValue(ByVal XmlFile As String, ByVal AppKey As String, ByRef AppValue As String) As Boolean
 On Error GoTo ErrHandle
 Dim objXml As New DOMDocument
 Dim objNode As IXMLDOMNode
 '//
 Call objXml.Load(XmlFile)
 '//
 Set objNode = objXml.selectSingleNode(AppKey)
 If objNode Is Nothing Then
  AppValue = ""
 Else
  AppValue = objNode.nodeTypedValue
 End If
 '//
 Set objNode = Nothing
 Set objXml = Nothing
 getXmlValue = True
 Exit Function
ErrHandle:
 getXmlValue = False
End Function

'//修改XML文件
Public Function setXmlValue(ByVal XmlFile As String, ByVal AppKey As String, ByVal AppValue As String) As Boolean
 On Error GoTo ErrHandle
 Dim objXml As New DOMDocument
 Dim objNode As IXMLDOMNode
 '//
 Call objXml.Load(XmlFile)
 '//
 Set objNode = objXml.selectSingleNode(AppKey)
 If objNode Is Nothing Then
  Set objNode = Nothing
  Set objXml = Nothing
  setXmlValue = False
  Exit Function
 Else
  objNode.nodeTypedValue = AppValue
  Call objXml.Save(XmlFile)
 End If
 '//
 Set objNode = Nothing
 Set objXml = Nothing
 setXmlValue = True
 Exit Function
ErrHandle:
 setXmlValue = False
End Function

'//加密数据
Public Function EncryptStr(ByVal EStr As String) As String
 Dim EObj As Object
 Set EObj = CreateObject("ABCCrypto2.Crypto")
 EObj.License = "131-598-271-072"
 EObj.Password = "FxGang_Soft"
 EncryptStr = EObj.Encrypt(EStr)
 Set EObj = Nothing
End Function

Public Function DecryptStr(ByVal DStr As String) As String
 Dim EObj As Object
 Set EObj = CreateObject("ABCCrypto2.Crypto")
 EObj.License = "131-598-271-072"
 EObj.Password = "FxGang_Soft"
 DecryptStr = EObj.Decrypt(DStr)
 Set EObj = Nothing
End Function