frminport.frm

一个功能比较完善的远程抄表软件

VERSION 5.00
Begin VB.Form frmInport 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "导入数据"
   ClientHeight    =   3255
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   3900
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3255
   ScaleWidth      =   3900
   Begin VB.ListBox lstData 
      Height          =   2760
      Left            =   120
      MultiSelect     =   2  'Extended
      TabIndex        =   2
      Top             =   360
      Width           =   2415
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消(&C)"
      Height          =   375
      Left            =   2640
      TabIndex        =   1
      Top             =   960
      Width           =   1095
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Height          =   375
      Left            =   2640
      TabIndex        =   0
      Top             =   480
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "选择要导入的数据:"
      Height          =   255
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   1695
   End
End
Attribute VB_Name = "frmInport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2007/07/09
'描    述：CBB三表户外计量系统 Ver 5.2
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
Dim MsgStr As String
Const InportMsg1 = "导入数据结构错误"
Const InportMsg2 = "导入数据格式错误"
Function GetFieldData(v_DataStr As String, v_Index As Integer, v_Mark As String) As String
Dim temStart As Integer
Dim temLoc As Integer

    GetFieldData = ""
    If v_DataStr = "" Then
        Exit Function
    End If
    temStart = 0
    temLoc = 0
    For i = 1 To v_Index
        temStart = temLoc + 1
        If temStart > Len(v_DataStr) Then
            Exit Function
        End If
        temLoc = InStr(temStart, v_DataStr, v_Mark)
        If temLoc <= 0 Then
            If i = v_Index Then
                temLoc = Len(v_DataStr) + 1
            Else
                Exit Function
            End If
        End If
    Next i
    GetFieldData = Mid(v_DataStr, temStart, temLoc - temStart)
End Function

Private Sub cmdCancel_Click()
    Unload Me
End Sub
Sub InportData(v_Date As Date, v_File As String)
Dim rcData1 As Recordset
Dim rcData2 As Recordset
Dim hFile As Integer
Dim temStr As String
Dim temStart As Integer
Dim temLoca As Integer
Dim temFieldStr As String
Dim temFieldData As fldUserData

    If Dir("bak\" & v_File, 0) = "" Then
        MsgStr = MsgStr & "数据文件" & v_File & "没有找到" & Chr(13)
        Exit Sub
    End If
    Set rcData1 = dbCbb.OpenRecordset("UserData", dbOpenDynaset)
    Set rcData2 = dbCbb.OpenRecordset("UserData2", dbOpenDynaset)
    rcData1.FindFirst "format(Date,""yyyy-mm-dd"")=""" & Format(v_Date, "yyyy-mm-dd") & """"
    If Not rcData1.NoMatch Then
        If MsgBox("日期" & v_Date & "数据已经存在" & Chr(13) & _
            "导入数据将会覆盖原数据" & Chr(13) & _
            "确定要导入数据吗?", vbYesNo + vbQuestion, Me.Caption) = vbYes Then
            SQL = "delete * from UserData where format(Date,""yyyy-mm-dd"")=""" & Format(v_Date, "yyyy-mm-dd") & """"
            dbCbb.Execute SQL
            SQL = "delete * from UserData2 where format(Date,""yyyy-mm-dd"")=""" & Format(v_Date, "yyyy-mm-dd") & """"
            dbCbb.Execute SQL
            Set rcData1 = dbCbb.OpenRecordset("UserData", dbOpenDynaset)
            Set rcData2 = dbCbb.OpenRecordset("UserData2", dbOpenDynaset)
        Else
            Exit Sub
        End If
    End If
    hFile = FreeFile
    Open "bak\" & v_File For Input As #hFile
    Do Until EOF(hFile)
        Line Input #hFile, temStr
        If Trim(temStr) <> "" Then
            With rcData1
                .AddNew
'UserID,DevID,Value,Date,Status
                temFieldStr = GetFieldData(temStr, 1, ";")
                !UserID = Val(temFieldStr)
                temFieldStr = GetFieldData(temStr, 2, ";")
                !devID = Val(temFieldStr)
                temFieldStr = GetFieldData(temStr, 3, ";")
                !Value = Val(temFieldStr)
                temFieldStr = GetFieldData(temStr, 4, ";")
                !Date = CDate(temFieldStr)
                temFieldStr = GetFieldData(temStr, 5, ";")
                !Status = Val(temFieldStr)
                .Update
            End With
            With rcData2
                .AddNew
'UserID,DevID,Value,Date,Status
                temFieldStr = GetFieldData(temStr, 1, ";")
                !UserID = Val(temFieldStr)
                temFieldStr = GetFieldData(temStr, 2, ";")
                !devID = Val(temFieldStr)
                temFieldStr = GetFieldData(temStr, 3, ";")
                !Value = Val(temFieldStr)
                temFieldStr = GetFieldData(temStr, 4, ";")
                !Date = CDate(temFieldStr)
                temFieldStr = GetFieldData(temStr, 5, ";")
                !Status = Val(temFieldStr)
                .Update
            End With
        End If
next_line:
    Loop
    Close #hFile
End Sub
Sub cmdOK_Click()
Dim curDate As Date
Dim curFile As String
Dim temStr As String

    If lstData.SelCount > 0 Then
        Me.MousePointer = 11
        MsgStr = ""
        For i = 0 To lstData.ListCount - 1
            If lstData.Selected(i) Then
                temStr = lstData.List(lstData.ListIndex)
                curDate = CDate(Mid(temStr, 1, InStr(1, temStr, "(") - 1))
                curFile = Trim(Mid(temStr, InStr(1, temStr, "(") + 1, InStr(1, temStr, ")") - InStr(1, temStr, "(") - 1))
                InportData curDate, curFile
'status
                AppendStatusInfo "导入日期" & curDate & "数据", icoBLUE
                SaveLog "导入日期" & curDate & "数据", 0
            End If
        Next i
        Me.MousePointer = 0
        MsgBox IIf(MsgStr = "", "成功导入数据!", MsgStr), vbInformation, Me.Caption
    End If
    Unload Me
End Sub

Private Sub Form_Load()
    If Dir("bak", 16) = "" Then
        MkDir "bak"
        Exit Sub
    End If
Dim temFileName As String
Dim temStr As String
Dim temDateStr As String

    temFileName = Dir("bak\*.dat", 0)
    Do While temFileName <> ""
        temStr = Mid(temFileName, 1, InStr(1, temFileName, ".") - 1)
        If Len(temStr) <> 8 Then
            temStr = ""
            temFileName = ""
            temDateStr = ""
            GoTo next_file
        End If
        temDateStr = Left(temStr, 4) & "-" & Mid(temStr, 5, 2) & "-" & Mid(temStr, 7, 2)
        If IsDate(temDateStr) Then
            lstData.AddItem temDateStr & "(" & temFileName & ")"
        End If
        
next_file:
        temFileName = Dir
    Loop
End Sub

Private Sub lstData_DblClick()
    cmdOK_Click
End Sub