tsdinggou.frm

出版社图书出货管理系统,包括图书的出库,入库,结果输出

  rs.Close
 db.Close
 MsgBox "转换完成,共转换数据:" + Str(recnum10) + "条"
End Sub

Private Sub Command2_Click()
    Dim myExcel As Excel.Application
    Dim myBook As Excel.Workbook
    Dim mySheet As Excel.Worksheet
    Dim rownum As Long
    filenam = ""
filenam = InputBox("请输入Excel文件名(不包含路径,文件位于d:\tscg\temp\*.xls下)：")
If filenam = "" Then
  MsgBox "文件名未输入!"
  Exit Sub
  End If
filenam1 = "d:\tscg\temp\" + filenam
If Dir(filenam1) = filenam Then
 
 Kill (filenam1)
End If
    
    'Data1.Recordset.MoveLast
    rownum = Data1.Recordset.RecordCount
    colnum = Data1.Recordset.Fields.Count
   ' Data1.Recordset.MoveFirst
    If rownum < 1 Then
      MsgBox "没有选购数据转出!"
      Exit Sub
      End If
  dgoutput1.Caption = "EXCEL格式订购正在输出......."
      Data1.Recordset.MoveFirst
    Set myExcel = CreateObject("Excel.Application")
    Set myBook = myExcel.Workbooks().Add
    Set mySheet = myBook.Worksheets("sheet1")
    
   ' For i = 1 To colnum
    '   mySheet.Cells(1, i).Value = Data1.Recordset.Fields(i - 1).Name
   ' Next i
       mySheet.Cells(1, 1).Value = "控制号"
       mySheet.Cells(1, 2).Value = "ISBN号"
       mySheet.Cells(1, 3).Value = "书名"
       mySheet.Cells(1, 4).Value = "作者"
       mySheet.Cells(1, 5).Value = "出版社"
       mySheet.Cells(1, 6).Value = "出版年"
       mySheet.Cells(1, 7).Value = "价格"
       mySheet.Cells(1, 8).Value = "复本数"
    For r = 1 To rownum
      For c = 1 To colnum
      
    mySheet.Cells(r + 1, c).Value = Data1.Recordset.Fields(c - 1).Value
      Next c
      Data1.Recordset.MoveNext
      dgoutput1.Caption = "EXCEL格式订购正在输出......." & Str(r)
    Next r
    myBook.SaveAs filenam1
    myExcel.Quit
    myExcel.Workbooks.Close
    MsgBox "数据转为EXCEL完毕,EXCEL文件为：" & filenam1 & "数量:" & Str(rownum)
    dgoutput1.Caption = "订购数据输出"
    Set myExcel = Nothing
    Set myBook = Nothing
    Set mySheet = Nothing

  
End Sub

Private Sub Command3_Click()
  Unload Me
End Sub

Private Sub Command4_Click()
  
  Dim db As Database
  Dim rs As Recordset
  Data1.Refresh
  Data2.Refresh
  On Error GoTo aa:
  Set db = Workspaces(0).OpenDatabase("d:\tscg\bookcgk.mdb")
  Set rs = db.OpenRecordset("select sum(fbl*jg) as je from 预采数据 where fbl>0")
  Text3.Text = rs.Fields("je").Value
  rs.Close
  db.Close
  Exit Sub
aa:
  Text3.Text = "0.0"
End Sub

Private Sub Command6_Click()
  Dim db As Database
  Dim rs As Recordset
  Dim marcstr As String
  Dim filenam As String
  Dim recnum11 As Long
  Dim outnum As Long
  outnum = 0
  recnum11 = 0
  
  marcstr = ""
  filenam = ""
  On Error Resume Next
filenam = InputBox("请输入MARC文件名(不包含路径,文件位于d:\tscg\temp\*.iso下)：")
If filenam = "" Then
  MsgBox "文件名未输入!"
  Exit Sub
  End If
filenam1 = "d:\tscg\temp\" + filenam
If Dir(filenam1) = filenam Then
 
 Kill (filenam1)
End If

Open filenam1 For Output As #1
  
  Set db = Workspaces(0).OpenDatabase("d:\tscg\bookcgk.mdb")
  Set rs = db.OpenRecordset("select marc from 预采数据 where fbl>0")
  rs.MoveFirst
  Do While Not rs.EOF
  recnum11 = recnum11 + 1
   Me.Caption = "正在输出第:" & recnum11 & "条"
   
    marcstr = rs("marc").Value
    If Len(marcstr) > 40 Then
   
      outnum = outnum + 1
      Print #1, marcstr
    End If
    marcstr = ""
    rs.MoveNext
  Loop
  rs.Close
  db.Close
  Close #1
 MsgBox "处理完成！处理" & recnum11 & "条，实际输出" & outnum & "条"
End Sub


Private Sub Command5_Click()
    '采购Marc数据输出，输出所选购图书：ISBN（isbn)，书名(bookname)，作者(author)，
    '价格jg，出版社bms，出版年bmn，订购数量fbl，内容context，提供商provide。
    Dim filenam As String
    Dim recount As Long
    Dim recnum10 As Long
    Dim headdata As String '头标区
    Dim bcdata As String '目次区
    Dim datadata As String '数据区
    
    headdata = ""
    bcdata = ""
    datadata = ""
    If banben = "PDA" Or banben = "正式" Then
       MsgBox "高级版需购买！"
       Exit Sub
    
    End If
    recnum10 = 0
    recount = 0
    On Error Resume Next
filenam = ""
filenam = InputBox("请输入MARC文件名(不包含路径,文件位于d:\tscg\temp\*.iso下)：")
If filenam = "" Then
  MsgBox "文件名未输入!"
  Exit Sub
  End If
filenam1 = "d:\tscg\temp\" + filenam
If Dir(filenam1) = filenam Then
 
 Kill (filenam1)
End If

Open filenam1 For Output As #1
Set db = Workspaces(0).OpenDatabase("d:\tscg\bookcgk.mdb")
Set rs = db.OpenRecordset("select * from 预采数据 where fbl>0")

If rs.EOF Then
   MsgBox "采购数据库为空,不能转换！"
   
   Close #1
   Kill (filenam1)
   rs.Close
   db.Close
   Exit Sub
   End If
   
  rs.MoveLast
  rs.MoveFirst
  recount = rs.RecordCount
  
  Do While Not rs.EOF
'读取字段值
   isbn = ""
   jg1 = ""
   sm = ""
   zz = ""
   isbn = rs.Fields("isbn").Value  '010$a
   jg1 = Trim(Str(rs.Fields("jg").Value))  '010@d
 
   sm = rs.Fields("bookname").Value  '200$a
   zz = rs.Fields("author").Value  '200$f
   xcbs = ""
   xcbl = ""
  xcbs = rs.Fields("bms").Value  '210$c
  xcbl = rs.Fields("bmn").Value  '210$d
   context = ""
   provide = ""
   sxbs = ""
  context = rs.Fields("context").Value  '330$a
 
  provide = rs.Fields("provide").Value  '801$b
  
  sxbs = LTrim(Str(rs.Fields("fbl").Value))  '905$s
 
  
  '记录头标区，目次区，数据区。
  field010 = Chr(30) & Chr(32) & Chr(32) & Chr(31) & "a" & isbn & Chr(31) & "dCNY" & jg1
  fieldname = "010"
  fieldlen = LenB(StrConv(field010, vbFromUnicode))  '4位aa = LenB(StrConv(linestring, vbFromUnicode))
  fieldloc = 0    '5位
  bcdata = fieldname & Format(fieldlen, "0000") & Format(0, "00000")
  ss = fieldlen + fieldloc
  
  field200 = Chr(30) & Chr(32) & Chr(32) & Chr(31) & "a" & sm & Chr(31) & "f" & zz
  fieldname = "200"
  fieldlen = LenB(StrConv(field200, vbFromUnicode))
  fieldloc = ss
  bcdata = bcdata & fieldname & Format(fieldlen, "0000") & Format(fieldloc, "00000")
  ss = fieldlen + fieldloc
  
  field210 = Chr(30) & Chr(32) & Chr(32) & Chr(31) & "c" & xcbs & Chr(31) & "d" & xcbl
   fieldname = "210"
  fieldlen = LenB(StrConv(field210, vbFromUnicode))
  fieldloc = ss
  bcdata = bcdata & fieldname & Format(fieldlen, "0000") & Format(fieldloc, "00000")
  ss = fieldlen + fieldloc
  
  field330 = Chr(30) & Chr(32) & Chr(32) & Chr(31) & "a" & context
   fieldname = "330"
  fieldlen = LenB(StrConv(field330, vbFromUnicode))
  fieldloc = ss
  bcdata = bcdata & fieldname & Format(fieldlen, "0000") & Format(fieldloc, "00000")
  ss = fieldlen + fieldloc
  
  field801 = Chr(30) & Chr(32) & Chr(32) & Chr(31) & "b" & provide
   fieldname = "801"
  fieldlen = LenB(StrConv(field801, vbFromUnicode))
  fieldloc = ss
  bcdata = bcdata & fieldname & Format(fieldlen, "0000") & Format(fieldloc, "00000")
  ss = fieldlen + fieldloc
  
  field905 = Chr(30) & Chr(32) & Chr(32) & Chr(31) & "s" & sxbs
   fieldname = "905"
  fieldlen = LenB(StrConv(field905, vbFromUnicode))
  fieldloc = ss
  '目次区
  bcdata = bcdata & fieldname & Format(fieldlen, "0000") & Format(fieldloc, "00000")
  ss = fieldlen + fieldloc
  '数据区
  datadata = field010 & field200 & field210 & field330 & field801 & field905 & Chr(30) & Chr(29)
  reclentotal = LenB(StrConv(datadata, vbFromUnicode)) + Len(bcdata) + 24
  mclentotal = 24 + Len(bcdata)
  
  headdata = Format(reclentotal, "00000") & "nam0 22" & Format(mclentotal, "00000") & "   450 "
  recorddata1 = headdata & bcdata & datadata
  Print #1, recorddata1
  
  recnum10 = recnum10 + 1
  Me.Caption = "正在处理第：" & recnum10 & "条"
  rs.MoveNext
 Loop
   
   
  rs.Close
  db.Close
  Close #1
  MsgBox "数据处理完成"
End Sub
Private Sub Form_Load()
  Dim db As Database
  Dim rs As Recordset
  On Error Resume Next
  Set db = Workspaces(0).OpenDatabase("d:\tscg\bookcgk.mdb")
  Set rs = db.OpenRecordset("select sum(fbl*jg) as je from 预采数据 where fbl>0")
  Text3.Text = rs.Fields("je").Value
  rs.Close
  db.Close
  If banben = "试用" Then
   Command5.Enabled = False
   Command1.Enabled = True
   Command2.Enabled = True
   Command4.Enabled = True
   Command6.Enabled = False
  End If
   If banben = "正式" Then
   Command5.Enabled = True
   Command1.Enabled = True
   Command2.Enabled = True
   Command4.Enabled = True
   Command6.Enabled = True
  End If
   If banben = "PDA" Then
   Command5.Enabled = True
   Command1.Enabled = False
   Command2.Enabled = True
   Command4.Enabled = True
   Command6.Enabled = True
  End If
   If banben = "高级" Then
  Command5.Enabled = True
  Command1.Enabled = True
  Command2.Enabled = True
  Command4.Enabled = True
   Command6.Enabled = True
  End If
End Sub