dataoperate.bas

智能仓库管理系统

Attribute VB_Name = "DataOperate"
Public con_id, txtzy2 As String

' *********************************************************************
' ****                     字符串矩阵2＊2加密法                    ****
' *********************************************************************

Public Function EnString(mString As String) As String   '字符串加密
  
  'M是用来将字符串"编码"的矩阵，可以任意指定矩阵中的元素，但是必须是一个N＊N的可逆矩阵，现以2*2方阵表示
  'iM是用来将字符串"解码"的矩阵，iM是M的逆矩阵，不可任意指指定iM中的元素
     
     Dim I
     Dim Want() As Double
     Dim strWant As String
     Dim M(1 To 2, 1 To 2) As Double
     Dim iM(1 To 2, 1 To 2) As Double
     strWant = ""
     M(1, 1) = 1: M(1, 2) = 2: M(2, 1) = 3: M(2, 2) = 4
     iM(1, 1) = -2: iM(1, 2) = 1: iM(2, 1) = 1.5: iM(2, 2) = -0.5
     
     Call encode(mString, M, Want)  '加密
     
     For I = 1 To UBound(Want)
          strWant = strWant & Want(I) & "★"
     Next
     EnString = strWant
End Function

Public Function DeString(mString As String) As String '解密
 Dim I
 Dim TempStr As String
 Dim Want() As Double
 Dim strWant As String
 Dim M(1 To 2, 1 To 2) As Double
 Dim iM(1 To 2, 1 To 2) As Double
     
     I = 0
     TempStr = mString
     Do While InStr(TempStr, "★") > 0
      I = I + 1
      ReDim Want(1 To I) As Double
      TempStr = Mid(TempStr, InStr(TempStr, "★") + 1)
     Loop
     I = 0
     
     TempStr = mString
     Do While InStr(TempStr, "★") > 0
      I = I + 1
      Want(I) = Mid(TempStr, 1, InStr(TempStr, "★") - 1)
      TempStr = Mid(TempStr, InStr(TempStr, "★") + 1)
     Loop
     iM(1, 1) = -2: iM(1, 2) = 1: iM(2, 1) = 1.5: iM(2, 2) = -0.5
     
     Call decode(strWant, iM, Want) '解密
     
     DeString = RTrim(strWant)
End Function

Public Sub encode(strSource As String, M() As Double, dblCoded() As Double) '矩阵加密
     Dim I As Long, j As Long, n As Long, temp As Long, strM() As Double, strC() As Double
     n = UBound(M, 2)
     temp = Len(strSource) Mod n
     strSource = strSource & String(IIf(temp = 0, 0, n - temp), " ")
     ReDim strM(1 To n, 1 To 1) As Double, strC(1 To n, 1 To 1) As Double, dblCoded(1 To Len(strSource))
     For I = 1 To Len(strSource)
          If I Mod n = 0 Then
               strM(n, 1) = AscW(Mid(strSource, I, 1))
               Call MatrixMultiply(M, strM, strC)
               For j = 1 To n
                    dblCoded(I + j - n) = strC(j, 1)
               Next
          Else
               strM(I Mod n, 1) = AscW(Mid(strSource, I, 1))
          End If
     Next
End Sub

Public Sub decode(strSource As String, iM() As Double, dblCoded() As Double) '矩阵解密
     Dim I As Long, j As Long, n As Long, strM() As Double, strC() As Double
     n = UBound(iM, 2)
     ReDim strM(1 To n, 1 To 1) As Double, strC(1 To n, 1 To 1) As Double
     For I = 1 To UBound(dblCoded, 1)
          If I Mod n = 0 Then
               strM(n, 1) = dblCoded(I)
               Call MatrixMultiply(iM, strM, strC)
               For j = 1 To n
                    strSource = strSource & ChrW(CLng(strC(j, 1)))
               Next
          Else
               strM(I Mod n, 1) = dblCoded(I)
          End If
     Next
End Sub

Public Sub MatrixMultiply(M() As Double, n() As Double, ReturnValue() As Double) '求出矩阵M的逆矩阵
     Dim I As Long, j As Long, K As Long, row As Long, column As Long, max As Long
     row = UBound(M, 1)
     column = UBound(n, 2)
     max = UBound(M, 2)
     ReDim ReturnValue(1 To row, 1 To column)
     For I = 1 To row
          For j = 1 To column
               For K = 1 To max
                    ReturnValue(I, j) = ReturnValue(I, j) + M(I, K) * n(K, j)
               Next
          Next
     Next
End Sub


' *********************************************************************
' ****                     将日期转换成星期                        ****
' *********************************************************************


Public Function DateToWeek(mDate As Date) As String
 Dim TempDate As Date
 Dim TempNum As Byte
  
  TempDate = Format(mDate, "yyyy-mm-dd")
  TempNum = DatePart("w", TempDate, vbSunday, vbUseSystem)
  Select Case TempNum
    Case 1
     DateToWeek = "星期日"
    Case 2
     DateToWeek = "星期一"
    Case 3
     DateToWeek = "星期二"
    Case 4
     DateToWeek = "星期三"
    Case 5
     DateToWeek = "星期四"
    Case 6
     DateToWeek = "星期五"
    Case 7
     DateToWeek = "星期六"
  End Select
  
End Function