commmodu.bas

用于电子行业打印复杂报表格式和不干胶标签

      '  Set objWord = Nothing
        
        ' Search the string
        lngNextPos = InStr(lngStartPos, StringToParse, Delimiter)
        
        If lngNextPos = 0 Then
            ' For when we get to the end of the file
            strTemp = Mid$(StringToParse, lngStartPos, Len(StringToParse) - lngNextPos + 1)
        Else
            strTemp = Mid$(StringToParse, lngStartPos, lngNextPos - lngStartPos + 1)
        End If
    
        lngStartPos = lngNextPos + 1
        
       ' Set objWord = New Word
        
      '  objWord.Value = strTemp
      '  colTemp.Add objWord
      
        DoEvents
    
    Loop Until lngNextPos = 0
    
ParseString_Exit:
    Set ParseString = colTemp
  '  Set objWord = Nothing
    Set colTemp = Nothing
End Function

'**加密函数**
Public Function Encrypt(ZMZ As String) As String
  Dim WMZ As String
  Dim N1 As Double
  Dim k As Integer
  Dim C1, C2, P1, P2 As String
  
  ZMZ = Val(ZMZ)
  N1 = Rnd() * 10 ^ 9      'Rnd()函数返回 0-1 的值
  If N1 <= 999999999 Then
    N1 = N1 + 10 ^ 9
  End If
  N1 = Int(N1)
  C1 = Trim(Str(N1 + ZMZ)) + Trim(Str(N1))    '注意去掉前后空格
  C2 = Mid(C1, 5, 20) + Mid(C1, 1, 4)
  P1 = ""
  P2 = ""
  For k = 1 To 10
    P1 = P1 + Mid(C2, 2 * k - 1, 1)
    P2 = P2 + Mid(C2, 2 * k, 1)
  Next
  WMZ = P1 + P2      '返回值是字符型
  Encrypt = WMZ
End Function

'**解密函数**
Public Function Decrypt(WMZ As String) As String
  Dim k As Integer
  Dim KK As Double
  Dim ZMZ As String
  Dim PP, DD, M1, M2 As String
  
  PP = ""
  For k = 1 To 10
    PP = PP + Mid(WMZ, k, 1) + Mid(WMZ, k + 10, 1)
  Next
  DD = Mid(PP, 17, 4) + Mid(PP, 1, 16)
  M1 = Mid(DD, 1, 10)
  M2 = Mid(DD, 11, 10)
  KK = Int(Val(M1) - Val(M2))   '整型值
  ZMZ = Trim(Str(KK))
  Decrypt = ZMZ
End Function

'**获取磁盘驱动器的序列号**
'**和整个硬盘的序列号不同，原因何在?**
Public Function DriveSerial(s As String) As String
  'Dim j As Integer
  Dim sTemp, lpVolumeNameBuffer As String
  Dim lpVolumeSerialNumber, lpFileSystemFlags As Long
  Dim lpMaximumComponentLength As Long
  Dim lpFileSystemNameBuffer As Long
  Dim nFileSystemNameSize, KK As Long
  
  lpVolumeNameBuffer = Space$(128)
  KK = GetVolumeInformation(s, lpVolumeNameBuffer, _
    Len(lpVolumeNameBuffer), lpVolumeSerialNumber, _
    lpMaximumComponentLength, lpFileSystemFlags, _
    lpFileSystemNameBuffer, nFileSystemNameSize)
  'If InStr(lpVolumeNameBuffer, Chr$(0)) > 0 Then
    sTemp = Hex(lpVolumeSerialNumber)
    DriveSerial = Left$(sTemp, 4) & "-" & Mid$(sTemp, 5)
  'End If
End Function

'**从一个带有路径的文件名中取出文件名
'**如从 C:\GATING\SYSTEM\CLOCK.BMP 中取出 CLOCK.BMP
Public Function GetPathName(sName As String) As String
  Dim nLength As Integer
  Dim i, KK As Integer
  
  nLength = Len(Trim(sName))
  For i = nLength To 1 Step -1
    If Mid(sName, i, 1) = "\" Then  '从字符串尾开始找出第一个 "\"
      Exit For
    End If
  Next
  KK = nLength - i '获得文件名的长度
  GetPathName = Right(sName, KK)
End Function

Public Sub Delrecord(dBname As String)
  '删除记录
  Dim cmd As ADODB.Command
  
  Set cmd = New ADODB.Command
  Set cmd.ActiveConnection = cnSys
    
  cmd.CommandText = "Delete From " & dBname
  cmd.Execute
  
  Set cmd = Nothing
End Sub

Public Function vFieldVal(rvntFieldVal As Variant) As Variant
'将字段的空白部分去掉
  If IsNull(rvntFieldVal) Then
     vFieldVal = ""
  Else
    vFieldVal = CStr(Trim(rvntFieldVal))
  End If
End Function

Public Function ValToStr(digits As Variant, nPos) As String
'将数值型转化成字符串，前面补0  (共 6 位)
  Dim i As Integer
  Dim temp As String
  
  temp = ""
  For i = 1 To nPos - Len(Trim(CStr(digits)))
    temp = temp & "0"
  Next
  
  ValToStr = temp & Trim(CStr(digits))
End Function

Public Function SavePoint(digits As Variant, nlong As Integer) As Single
'将一个数保留 nlong 个小数点
  Dim i As Integer
  Dim nTemp, temp As Single
  Dim sTemp As String
  
  temp = 1
  For i = 1 To nlong
    temp = temp * 10
  Next
  nTemp = Int(temp * digits + 0.5) '要四舍五入
  If nTemp = 0 Then
    SavePoint = 0
  Else
    sTemp = Trim(CStr(nTemp))
    If Len(sTemp) < nlong Then  '若长度小于指定的小数位，则应在前面补0
      For i = 1 To nlong - Len(sTemp)
        sTemp = "0" & sTemp
      Next i
    End If
    SavePoint = Val(CStr(Int(nTemp / temp)) + "." + Right(sTemp, nlong))
  End If
End Function

Public Function ShowPoint(digits As Variant, nlong As Integer) As String
'将一个数保留 nlong 个小数点，用于报表的打印显示,若数为0，则不显示
  Dim i As Integer
  Dim temp As Single
  Dim sTemp As String
  
  temp = 1
  For i = 1 To nlong
    temp = temp * 10
  Next
  temp = Int(temp * digits + 0.5) '要四舍五入
  
  If temp = 0 Then
    ShowPoint = ""
  Else
    sTemp = Trim(CStr(temp))
    If Len(sTemp) < nlong Then  '若长度小于指定的小数位，则应在前面补0
      For i = 1 To nlong - Len(sTemp)
        sTemp = "0" & sTemp
      Next i
    End If
    ShowPoint = Trim(CStr(Int(digits))) + "." + Right(sTemp, nlong)
  End If
End Function

Public Sub SetCtlStatus(frmComm As Form, bFlag As Boolean)
'设置表单中控件的状态
  Dim CtrlBox As Control
  
  For Each CtrlBox In frmComm.Controls
    If TypeOf CtrlBox Is TextBox Then   '文本框
      CtrlBox.Enabled = bFlag
    ElseIf TypeOf CtrlBox Is ComboBox Then   '组合框
      CtrlBox.Enabled = bFlag
    ElseIf TypeOf CtrlBox Is CheckBox Then   '选项框
      CtrlBox.Enabled = bFlag
    End If
  Next CtrlBox
End Sub

Public Function GetRndNum(ByVal Maxbound As Single, ByVal Minbound As Single) As Single
'获得一定范围内的随机数
  Randomize  '初始化
  GetRndNum = (Maxbound - Minbound) * Rnd + Minbound
End Function