functions.bas

本人写的一个垃圾代码,主要是实现简单的打印功能

Attribute VB_Name = "Functions"
'从长字符串中分出字符段
Function GetString(ByVal strInput As String, ByVal intIndex As Integer, Optional strIdentify As String = "|", Optional blnBd As Boolean = False) As String
    'Dim intC As Integer
    'Dim intH As Integer
    'Dim intk As Integer
    On Error GoTo err
    Dim nCount As Integer
    Dim nPostion As Integer
    
    nCount = 0
    nPostion = 1
    strInput = strInput & strIdentify
    Do While InStr(nPostion, strInput, strIdentify)
     nPostion = InStr(nPostion, strInput, strIdetify) + 1
     nCount = nCount + 1
    Loop
 '   If nCount < intIndex - 1 Then
  '    GoTo err
   ' End If
    
    nPostion = 1
    '从strInput中去掉intIndex前面的字符串
    For nCount = 1 To intIndex - 1 Step 1
      nPostion = InStr(strInput, strIdentify)
      strInput = Right(strInput, Len(strInput) - nPostion)
    Next
    
    GetString = Left(strInput, InStr(strInput, strIdentify) - 1)
    
    If blnBd Then
        GetString = Right(GetString, Len(GetString) - InStr(1, GetString, ":"))
    End If
    Exit Function
err:
   Select Case err.Number
    Case 5
    Case Else
        MsgBox err.Description
    End Select
End Function

Sub TextPrint(ByVal frmName As Form, Optional BlnOver As Boolean = True)
 ' Dim inti As Integer
  Dim strTemp As String
  Dim strKeyName As String
  Dim obj As Control
   
  On Error GoTo errhandle
  Printer.ScaleMode = 6

  With frmName
    For Each obj In .Controls
    If (TypeOf obj Is TextBox Or TypeOf obj Is ComboBox) And obj.Visible = True Then
         If Trim(obj <> "") Then
           strKeyName = obj.Name & obj.Index & .Name
           strTemp = GetSetting(App.EXEName, "打印坐标设置", strKeyName)
             
             Printer.FontName = IIf(GetString(strTemp, 1, ",") = "", "宋体", GetString(strTemp, 1, ","))
             Printer.FontSize = Val(IIf(GetString(strTemp, 2, ",") = "", "8", GetString(strTemp, 2, ",")))
             Printer.CurrentX = IIf(GetString(strTemp, 3, ",") = "", obj.Left \ 56.7, GetString(strTemp, 3, ","))
             Printer.CurrentY = IIf(GetString(strTemp, 4, ",") = "", obj.Top \ 56.7, GetString(strTemp, 4, ","))
            
           Printer.Print Trim(obj)
          End If
       End If
    Next
   End With
   If Not Bln Then
      Printer.EndDoc
   End If
   Exit Sub
errhandle:
   MsgBox err.Description
  Exit Sub
End Sub

Public Sub ClearFrm(ByVal frm As Form, Optional ByVal kind As String = "")
    On Error GoTo err
    Dim obj As Control
    With frm
        For Each obj In .Controls
            If kind = "" Then
        
                If TypeOf obj Is TextBox Or TypeOf obj Is ComboBox Then
                    If obj.DataField <> "" Then
                        obj = ""
                    End If
                End If
            ElseIf InStr(1, UCase(obj.Name), UCase(kind)) > 0 Then
                 If TypeOf obj Is TextBox Or TypeOf obj Is ComboBox Then
                    If obj.DataField <> "" Then
                        obj = ""
                    End If
                End If
            End If
         Next
    End With
    Exit Sub
err:
    MsgBox err.Description
End Sub
'限制文本输入
Public Function TextExam(ByVal str As String, ByVal limitstr As String, Optional Bln As Boolean = True) As String
On Error GoTo errhandle
    Dim inti As Integer
    Dim strTemp As String
    For inti = 1 To Len(str)
        If Not Bln And InStr(1, limitstr, Mid(str, inti, 1)) = 0 Then
            strTemp = strTemp & Mid(str, inti, 1)
        End If
        If Bln And InStr(1, limitstr, Mid(str, inti, 1)) <> 0 Then
            strTemp = strTemp & Mid(str, inti, 1)
        End If
    Next inti
    TextExam = strTemp
errhandle:
End Function
'查询之后显示出来
Public Sub ShowDB(ByVal frm As Form, ByVal strSQL As String, Optional ByVal strKind As String = "")
'    On Error GoTo err
    
    Dim rst As ADODB.Recordset
    Dim ctl As Control
    Dim str As String
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseClient
    rst.Open strSQL, myDB, adOpenForwardOnly, adLockReadOnly
    If rst.EOF Then
        'MsgBox "没有记录!", vbOKOnly + vbInformation, "提示"
        Call ClearFrm(frm, strKind)
    Else
        With frm
            For Each ctl In .Controls
              If InStr(1, UCase(ctl.Name), UCase(strKind)) > 0 Then
                If (TypeOf ctl Is TextBox) Or (TypeOf ctl Is ComboBox) Or (TypeOf ctl Is DTPicker) Then
                If ctl.DataField <> "" Then
                    str = ctl.DataField
                    If (TypeOf ctl Is TextBox) Or (TypeOf ctl Is ComboBox) Then
                        ctl = "" & rst(str)
                    End If
               
                    If TypeOf ctl Is DTPicker Then
                        If "" & rst(str) = "" Then
                            ctl = "1900-1-1"
                        Else
                            ctl = rst(str)
                        End If
                    End If
                End If
                End If
              End If
            Next
            
        End With
    End If
    rst.Close
    Set rst = Nothing
    Exit Sub
err:
    MsgBox err.Description
    
End Sub
'构造插入表SQL语句
Public Function ConstructInsertSQL(ByVal frm As Form, ByVal TableName As String, ByVal strKind As String) As String
    Dim strField As String
    Dim strValue As String
    Dim ctl As Control
    strField = ""
    strValue = ""
    With frm
        For Each ctl In .Controls
          If InStr(1, UCase(ctl.Name), UCase(strKind)) > 0 Then
            If (TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox) Then
              If (ctl.DataField <> "") Then
                strField = strField & Trim(ctl.DataField) & ","
                If ctl.Tag = "numeric" Then     '注意数值类型的值Tag=numeric
                    strValue = strValue & Val(Trim(ctl.Text)) & ","
                Else
                    strValue = strValue & "'" & Trim(ctl.Text) & "',"
                End If
              End If
            End If
           End If
        Next
    End With
    strField = Trim(strField)
    strValue = Trim(strValue)
    If InStr(Len(strField) - 1, strField, ",") > 0 Then
        strField = Left(strField, Len(strField) - 1)
    End If
    If InStr(Len(strValue) - 1, strValue, ",") > 0 Then
        strValue = Left(strValue, Len(strValue) - 1)
    End If
    ConstructInsertSQL = "insert into " & TableName & "(" & strField & ") values(" & strValue & ")"
    
End Function
Public Function ConstructUpdateSQL(ByVal frm As Form, ByVal TableName As String, ByVal strKind As String, ByVal strKey As String) As String
    Dim strSet As String
    Dim strWhere As String
    Dim ctl As Control
    strSet = ""
    strWhere = " where "
    With frm
        For Each ctl In .Controls
          If InStr(1, UCase(ctl.Name), UCase(strKind)) > 0 Then
            If (TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox) Then
              If (ctl.DataField <> "") Then
                If InStr(1, strKey, Trim(ctl.DataField), vbBinaryCompare) > 0 Then
                    strWhere = strWhere & Trim(ctl.DataField) & "='" & ctl.Text & "',"
                Else
                    If ctl.Tag = "numeric" Then
                        strSet = strSet & Trim(ctl.DataField) & "=" & Val(ctl.Text) & ","
                    Else
                         strSet = strSet & Trim(ctl.DataField) & "=" & "'" & Trim(ctl.Text) & "',"
                    End If
                End If
              End If
            End If
           End If
        Next
    End With
    strSet = Trim(strSet)
    If InStr(Len(strSet) - 1, strSet, ",") > 0 Then
        strSet = Left(strSet, Len(strSet) - 1)
    End If
    If InStr(Len(strWhere) - 1, strWhere, ",") > 0 Then
        strWhere = Left(strWhere, Len(strWhere) - 1)
    End If
    ConstructUpdateSQL = "Update " & TableName & " Set " & strSet & strWhere
End Function
'转换函数
Function Up(Dxs As String) As String
'检测为空时
If Trim(Dxs) = "" Then
    MsgBox "没有数字，不能转换!", vbOKOnly + 32
    Exit Function
End If
  Dim Sw As Integer, SzP As Integer, SzUp As Integer, TempStr As String, DXStr As String
    Sw = Len(Trim(Dxs))
    SzP = InStr(1, Trim(Dxs), ".")
If SzP = 0 Then
   Dim i As Integer
     For i = 1 To Sw
         TempStr = Right(Trim(Dxs), i)
         TempStr = Left(TempStr, 1)
         TempStr = Converts(TempStr)
         Select Case i
           Case 1
               If TempStr = "零" Then
                  TempStr = "" ' "元"
                   Else
                  TempStr = TempStr '+ "元"
               End If
           Case 2
               If TempStr = "零" Then
                  TempStr = "零"
                Else
                  TempStr = TempStr + "拾"
               End If
           Case 3
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 4
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 5
               If TempStr = "零" Then
                  TempStr = "万"
                   Else
                  TempStr = TempStr + "万"
               End If
            Case 6
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "拾"
               End If
            Case 7
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 8
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 9
               If TempStr = "零" Then
                  TempStr = "亿"
                   Else
                  TempStr = TempStr + "亿"
               End If
         End Select
    Dim TempA As String
        TempA = Left(Trim(DXStr), 1)
    If TempStr = "零" Then
      Select Case TempA
       Case "零"
            DXStr = DXStr
       Case "元"
            DXStr = DXStr
       Case "万"
            DXStr = DXStr
       Case "亿"
            DXStr = DXStr
       Case Else
            DXStr = TempStr + DXStr
      End Select
      Else
       DXStr = TempStr + DXStr
    End If
     Next
  Else
    For i = 1 To SzP - 1
         TempStr = Right(Trim(Dxs), i + (Sw - SzP + 1))
         TempStr = Left(TempStr, 1)
         TempStr = Converts(TempStr)
         Select Case i
           Case 1
               If TempStr = "零" Then
                  TempStr = "点" '"元"
                   Else
                  TempStr = TempStr + "点" ' "元"
               End If
           Case 2
               If TempStr = "零" Then
                  TempStr = "零"
                Else
                  TempStr = TempStr + "拾"
               End If
           Case 3
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 4
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 5
               If TempStr = "零" Then
                  TempStr = "万"
                   Else
                  TempStr = TempStr + "万"
               End If
            Case 6
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "拾"
               End If
            Case 7
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 8
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 9
               If TempStr = "零" Then
                  TempStr = "亿"
                   Else
                  TempStr = TempStr + "亿"
               End If
            Case Else
              '超过999999999时自动删除
              TempStr = ""
         End Select
        TempA = Left(Trim(DXStr), 1)
    If TempStr = "零" Then
      Select Case TempA
       Case "零"
            DXStr = DXStr
       Case "元"
            DXStr = DXStr
       Case "万"
            DXStr = DXStr
       Case "亿"
            DXStr = DXStr
       Case Else
            DXStr = TempStr + DXStr
      End Select
      Else
       DXStr = TempStr + DXStr
    End If
     Next
'计算小数
   Dim DxstrX As String, XStr As String
      XStr = Right(Trim(Dxs), Sw - SzP)
        For i = 1 To Sw - SzP
         TempStr = Left(XStr, i)
         TempStr = Right(TempStr, 1)
         TempStr = Converts(TempStr)
         Select Case i
           Case 1
            If TempStr = "零" Then
               TempStr = "零"
               Else
               TempStr = TempStr '+ "角"
            End If
           Case 2
            If TempStr = "零" Then
               TempStr = ""
               Else
               TempStr = TempStr '+ "分"
               End If
            Case Else
              '超过两位小数时，自动删除
              TempStr = ""
         End Select
        DxstrX = DxstrX + TempStr
     Next
     DXStr = DXStr + DxstrX
End If
    Up = DXStr
End Function

Function Converts(NumStr As String) As String
    Select Case Val(NumStr)
      Case 0
        Converts = "零"
      Case 1
        Converts = "壹"
      Case 2
        Converts = "贰"
      Case 3
        Converts = "叁"
      Case 4
        Converts = "肆"
      Case 5
        Converts = "伍"
      Case 6
         Converts = "陆"
      Case 7
         Converts = "柒"
      Case 8
         Converts = "捌"
      Case 9
         Converts = "玖"
    End Select
End Function