registry.bas

农村水电费记帐录入

Dim J As Integer
Dim K As Integer
Dim I As Integer
Dim readMon
sConv = Trim(Str(Abs(Val(sConv0))))
readMon = Array("零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖", "角", "分", "", "拾", "佰", "仟", "万", "亿")
J = 0
K = 0
sConv2 = "": sConv1 = ""
For I% = 1 To Len(sConv) Step 1
    If Mid$(sConv, I%, 1) = "." Then
        I% = I% + 1
        sConv2 = Mid$(sConv, I%, 1)
        F = "F"
        
    Else
    If F = "F" Then
        sConv2 = sConv2 & Mid$(sConv, I%, 1)
    Else
        sConv1 = sConv1 & Mid$(sConv, I%, 1)
    End If
    End If
Next I%
sConv2 = Mid$(sConv2, 1, 2)
If Len(sConv2) = 0 Then sConv2 = "00"
If Len(sConv2) = 1 Then sConv2 = sConv2 & "0"

For I% = Len(sConv1) To 1 Step -1
If Mid$(sConv1, I%, 1) = "0" Then
    If (J <> 0) And (Mid$(sConv1, I% + 1, 1) <> "0") Then
             sStr2 = readMon(Mid$(sConv1, I%, 1)) + sStr2
    End If
Else
sStr2 = readMon(Mid$(sConv1, I%, 1)) + readMon(12 + J) + sStr2
End If
    J = J + 1
    If (J = 4) And (Not I% = 1) Then
        sStr2 = readMon(16 + K) + sStr2
        J = 0
        K = K + 1
        K = IIf(K = 2, 0, K)
    End If
Next I%

sStr2 = IIf(sStr2 = "", sStr2, sStr2 + "元")

For I% = 0 To 1
    If Mid$(sConv2, Len(sConv2) - 1 + I%, 1) <> "0" Then
        sStr2 = sStr2 + readMon(Mid$(sConv2, Len(sConv2) - 1 + I%, 1)) + readMon(10 + I%)
    End If
Next I%
If Val(sConv0) > 0 Then
  ConvertMe = sStr2
Else
  ConvertMe = "负" & sStr2
End If
If Mid$(sConv2, 2, 1) = "0" Then ConvertMe = ConvertMe & "整"

End Function
Public Function getQueryData(sql As String) As ADODB.Recordset
'功能描述：
'返回数据集，根据SQL语句与一个定死的数据连接
   
    Dim rs As New ADODB.Recordset '数据集
    'On Error GoTo errH '处错处理
    Set rs.ActiveConnection = gCnn
    rs.CursorLocation = adUseClient
    rs.LockType = adLockBatchOptimistic
    rs.CursorType = adOpenKeyset
    rs.Open sql '执行SQL语句
    Set getQueryData = rs
    Exit Function
errH:
   Set getQueryData = Nothing
End Function
Public Sub Export(rs As ADODB.Recordset, dgrid As DataGrid, Optional titleStr As String, Optional secStr As String, Optional lastStr As String)
On Error Resume Next
    If rs.RecordCount <= 0 Then
     MsgBox "数据为空，不能导出!"
     Exit Sub
    End If
    
    Dim xlApp As New Excel.Application
    Dim xlBook As New Excel.Workbook
    Dim xlSheet As New Excel.Worksheet
    Dim rsnew As New ADODB.Recordset
    Set xlBook = xlApp.Workbooks.Add  '添加一个新的BOOK
    Set xlSheet = xlBook.Worksheets.Add  '添加一个新的SHEET
    
    xlApp.Visible = False
    Screen.MousePointer = vbHourglass
    On Error GoTo Err_Proc
    Dim Irowcount, Icolcount, ActualCols As Long
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim beginRow As Long '已经使用过的行
    beginRow = 6
    Irowcount = rs.RecordCount
    Icolcount = dgrid.Columns.Count
    Dim Datas() As String
    With dgrid
       '写内容
       '开始写DataGrid数据
       ReDim Datas(Irowcount, Icolcount)
         rs.MoveFirst
        For I = 1 To Irowcount + 1
            Select Case I
              Case 1:
                 'start 初始化工作表与写入表头
                 K = 0
                 For J = 0 To Icolcount - 1
                     If .Columns(J).Visible = True And .Columns(J).width > 30 Then
                      K = K + 1
                         xlSheet.Columns(K).Font.Size = 10
                         xlSheet.Columns(K).VerticalAlignment = xlVAlignCenter  '垂直居中
                         xlSheet.Columns(K).ColumnWidth = .Columns(J).width / 100
                         Select Case .Columns(J).Alignment
                            Case dbgRight:
                                xlSheet.Columns(K).HorizontalAlignment = xlRight
                            Case dbgLeft:
                                xlSheet.Columns(K).HorizontalAlignment = xlLeft
                            Case Else
                                xlSheet.Columns(K).HorizontalAlignment = xlCenter
                         End Select
                         
                         xlSheet.Cells(beginRow, K).Value = .Columns(J).Caption
                     End If
                  Next J
                  beginRow = beginRow + 1
                  ActualCols = K
                  'end  －－－－－
              Case Else:
                  K = 0
                 For J = 0 To Icolcount - 1
                 ' .Col = j - 1
                   If .Columns(J).Visible = True Then
                          Datas(I - 2, K) = rs(dgrid.Columns(J).DataField) & ""
                     End If
                     K = K + 1
                    
                  Next J
                  rs.MoveNext
                  
                End Select
         Next I
      End With
      '结束写DataGrid数据
      'xlApp.Visible = True
    If titleStr <> "" Then
     '写标题
        With xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(4, ActualCols))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .MergeCells = True
            .Font.Name = "黑体"
            .Font.Bold = True
            .Font.Size = 20
            .Borders.LineStyle = xlContinuous
            .Value = titleStr
        End With
    End If
    If secStr <> "" Then
    '写时间及副标题行
        With xlSheet.Range(xlSheet.Cells(5, 1), xlSheet.Cells(5, ActualCols))
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .MergeCells = True
            .Borders.LineStyle = xlContinuous
            .Value = secStr
            
        End With
      End If
      With xlSheet.Range(xlSheet.Cells(6, 1), xlSheet.Cells(6, ActualCols))
        .Borders.LineStyle = xlContinuous
      End With
      xlApp.Visible = True
      With xlSheet.Range(xlSheet.Cells(beginRow, 1), xlSheet.Cells(Irowcount + beginRow - 1, ActualCols))
        .Value = Datas
        .Borders.LineStyle = xlContinuous
        
      End With
      beginRow = beginRow + Irowcount
      If lastStr <> "" Then
      '写数据尾
            With xlSheet.Range(xlSheet.Cells(beginRow, 1), xlSheet.Cells(beginRow, ActualCols))
              .HorizontalAlignment = xlLeft
              .VerticalAlignment = xlBottom
              .MergeCells = True
              .Borders.LineStyle = xlContinuous
              .Value = lastStr
            End With
      End If
      '结束写Excel
      'xlSheet.Protect "dlj"
      'xlSheet.EnableSelection = xlNoSelection
      xlSheet.Cells.WrapText = True
      Screen.MousePointer = vbDefault
     Exit Sub
Err_Proc:
    Screen.MousePointer = vbDefault
    MsgBox Err.Description, vbExclamation, "提示"
    Set dgrid.DataSource = rs
End Sub

Public Sub dy()
Set gCnn = New ADODB.Connection
gCnn.Open cnn
End Sub
Public Function cnn() As String    '定义函数
  '返回一个数据库连接
     
    cnn = "driver={SQL Server};server=" & hostName & ";database=sdf"
   
 ' cnn = "driver={SQL Server};server=" & Trim(frm_xtdl.servername) & ";uid=" & Trim(frm_xtdl.uid) & ";pwd=" & Trim(frm_xtdl.pwd) & ";database=" & frm_xtdl.database
   
End Function