frmm_2mdb.frm

利用VB+ACCESS开发的专用布料管理系统

         Width           =   1980
      End
   End
End
Attribute VB_Name = "FrmM_2Mdb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim Rec As New ADODB.Recordset
Dim cn As New ADODB.Connection

Dim MdbFileName As String
Dim MdbPathName As String
Dim Fs As New Scripting.FileSystemObject
Dim i As Integer

Private Sub Combo1_Change()
    If Trim(Combo1.Text) = "" Then
        MdbFileName = Year(Date) & Month(Date) & Day(Date) & ".mdb"
    Else
        MdbFileName = Combo1.Text & ".mdb"
    End If
    ListView1.ListItems.Clear
    ListView1.ColumnHeaders.Clear
    ListView1.ColumnHeaders.Add , "h1", "批号列表", 1900
    Set Rec = cn.Execute("select ph from maindb where orderid='" & _
        Combo1.Text & "' order by orderid")
    If Not Rec.EOF And Not Rec.BOF Then
        Do While Not Rec.EOF
            For i = 1 To ListView1.ListItems.Count
                If ListView1.ListItems(i).Text = Rec.Fields("ph") Then Exit For
            Next i
            If i > ListView1.ListItems.Count Or ListView1.ListItems.Count = 0 Then ListView1.ListItems.Add , , Rec.Fields("ph")
            Rec.MoveNext
        Loop
    End If
    Rec.Close: Set Rec = Nothing
    Text1.Text = MdbPathName & MdbFileName
End Sub

Private Sub Combo1_Click()
    If Trim(Combo1.Text) = "" Then
        MdbFileName = Year(Date) & Month(Date) & Day(Date) & ".mdb"
    Else
        MdbFileName = Combo1.Text & ".mdb"
    End If
    ListView1.ListItems.Clear
    ListView1.ColumnHeaders.Clear
    ListView1.ColumnHeaders.Add , "h1", "批号列表", 1900
    Set Rec = cn.Execute("select ph from maindb where orderid='" & _
        Combo1.Text & "' order by orderid")
    If Not Rec.EOF And Not Rec.BOF Then
        Do While Not Rec.EOF
            For i = 1 To ListView1.ListItems.Count
                If ListView1.ListItems(i).Text = Rec.Fields("ph") Then Exit For
            Next i
            If i > ListView1.ListItems.Count Or ListView1.ListItems.Count = 0 Then ListView1.ListItems.Add , , Rec.Fields("ph")
            Rec.MoveNext
        Loop
    End If
    Rec.Close: Set Rec = Nothing
    Text1.Text = MdbPathName & MdbFileName
End Sub

Private Sub Command1_Click(Index As Integer)
    Select Case Index
        Case 0
            On Error Resume Next
            If Option1(1).Value = True Then
                If ListView1.ListItems.Count = 0 Then
                    MsgBox "没有选择《批号》。", vbOKOnly + vbExclamation, "导出出错"
                    ListView1.SetFocus
                    Exit Sub
                End If
                For i = 1 To ListView1.ListItems.Count
                    If ListView1.ListItems(i).Checked = True Then Exit For
                Next i
                If i > ListView1.ListItems.Count Then
                    MsgBox "没有选择《批号》。", vbOKOnly + vbExclamation, "导出出错"
                    ListView1.SetFocus
                    Exit Sub
                End If
            End If
            If Trim(Combo1.Text) = "" Then
                MsgBox "没有选取单号！", vbOKOnly + vbExclamation, "选择单号出错..."
                Combo1.SetFocus
                Exit Sub
            End If
            If Trim(Text1.Text) = "" Then
                MsgBox "没有输入导出的文件名！", vbOKOnly + vbExclamation, "文件出错..."
                Text1.SetFocus
                Exit Sub
            End If
            If Fs.FileExists(App.Path & "\chxn\temp.mdb") = False Then
                MsgBox "模版文件《" & App.Path & "\chxn\temp.mdb" & "》掉失,请于系统开发人员联系。", _
                    vbCritical + vbOKOnly, "文件出错..."
                Exit Sub
            End If
            If Fs.FileExists(Trim(Text1.Text)) = True Then
                If MsgBox("文件已存在，是否要覆盖已有的文件：" & Trim(Text1.Text) & " ？", _
                    vbCritical + vbOKCancel, "文件出错...") = vbOK Then
                    Fs.DeleteFile Trim(Text1.Text), True
                Else
                    Exit Sub
                End If
            End If
            Fs.CopyFile App.Path & "\chxn\temp.mdb", Trim(Text1.Text), True
            Rec.CursorLocation = adUseClient
            If Option1(1).Value = True Then
                Dim SqlStr As String
                Dim strPh As String
                SqlStr = "": strPh = ""
                For i = 1 To ListView1.ListItems.Count
                    If ListView1.ListItems(i).Checked = True Then
                        SqlStr = SqlStr & " or ph='" & ListView1.ListItems(i).Text & "'"
                        strPh = strPh & "," & ListView1.ListItems(i).Text
                    End If
                Next i
                strPh = Right(strPh, Len(strPh) - 1)
                SqlStr = Right(SqlStr, Len(SqlStr) - 3)
                Rec.Open "select * from maindb where (" & SqlStr & ") and orderid='" & _
                    Combo1.Text & "' order by pid", cn, adOpenDynamic, adLockOptimistic
            Else
                Rec.Open "select * from maindb where orderid='" & _
                    Combo1.Text & "' order by pid", cn, adOpenDynamic, adLockOptimistic
            End If
            If Rec.EOF And Rec.BOF Then
                MsgBox "选择的《疋号》没有数据，请重新选择...", vbOKOnly + vbExclamation, "数据为空！"
                Rec.Close: Set Rec = Nothing
                Exit Sub
            End If
            Dim CnMdb As New ADODB.Connection
            Dim RecMdb As New ADODB.Recordset
            CnMdb.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=" & _
                Trim(Text1.Text) & ";jet oledb:database password=;"
            CnMdb.Open
            RecMdb.Open "select * from maindb", CnMdb, adOpenDynamic, adLockOptimistic
            Do While Not Rec.EOF
                RecMdb.AddNew
                For i = 0 To Rec.Fields.Count - 1
                    RecMdb.Fields(i).Value = IIf(Trim(Rec.Fields(i).Value) = "", " ", Rec.Fields(i).Value)
                Next i
                RecMdb.Update
                Rec.MoveNext
            Loop
            Rec.Close: Set Rec = Nothing
            Unload Me
        Case 1
            Unload Me
    End Select
End Sub

Private Sub Command2_Click()
    On Error Resume Next
    With CommonDialog1
        .DialogTitle = "请选择要保存到的文件夹..."
        .CancelError = True
        .FileName = MdbPathName & MdbFileName
        .Filter = "*.mdb|*.mdb"
        .ShowOpen
    End With
    If Len(CommonDialog1.FileName) = 0 Then Exit Sub
    If Fs.FileExists(CommonDialog1.FileName) = True Then
        If MsgBox("文件已存在，是否要覆盖已有的文件：" & CommonDialog1.FileName & " ？", _
            vbCritical + vbOKCancel, "文件出错...") = vbOK Then
            Fs.DeleteFile CommonDialog1.FileName, True
        Else
            Exit Sub
        End If
    End If
    MdbFileName = Trim(CommonDialog1.FileName)
    Text1.Text = MdbFileName
    For i = Len(MdbFileName) To 0 Step -1
        If Mid(MdbFileName, i, 1) = "\" Then
            MdbPathName = Left(MdbFileName, i)
            MdbFileName = Right(MdbFileName, Len(MdbFileName) - i)
            GoTo ExitSub
        End If
    Next i
ExitSub:
End Sub

Private Sub Form_Load()
    Option1(1).Value = True
    MdbPathName = App.Path & "\"
    MdbFileName = Year(Date) & Month(Date) & Day(Date) & ".mdb"
    cn.Open DbConnectSql
    Combo1.Clear
    Set Rec = cn.Execute("select distinct(orderid) from maindb order by orderid")
    If Not Rec.EOF And Not Rec.BOF Then
        Do While Not Rec.EOF
            Combo1.AddItem Rec.Fields("orderid")
            Rec.MoveNext
        Loop
    End If
    Rec.Close: Set Rec = Nothing
    Text1.Text = MdbPathName & MdbFileName
    Combo1.Text = ""
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Rec.Close: Set Rec = Nothing
    cn.Close: Set cn = Nothing
End Sub

Private Sub Option1_Click(Index As Integer)
    If Option1(0).Value = True Then
        ListView1.Enabled = False
    Else
        ListView1.Enabled = True
    End If
End Sub

Private Sub Text1_GotFocus()
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1.Text)
End Sub