📄 tsdinggou111.frm
字号:
VERSION 5.00
Begin VB.Form dgoutput1
Caption = "订购数据输出"
ClientHeight = 7020
ClientLeft = 60
ClientTop = 345
ClientWidth = 11310
LinkTopic = "Form1"
ScaleHeight = 7020
ScaleWidth = 11310
StartUpPosition = 1 'CenterOwner
Begin VB.CommandButton Command4
Caption = "统计"
Height = 375
Left = 10200
TabIndex = 0
Top = 120
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "退出"
Height = 495
Left = 8160
TabIndex = 10
Top = 6480
Width = 1335
End
Begin VB.CommandButton Command2
Caption = "EXCEL输出"
Height = 495
Left = 5160
TabIndex = 9
Top = 6480
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "工作单输出"
Enabled = 0 'False
Height = 495
Left = 2160
TabIndex = 8
Top = 6480
Width = 1455
End
Begin VB.Data Data2
Caption = "Data2"
Connect = "Access"
DatabaseName = "D:\tscg\bookcgk.mdb"
DefaultCursorType= 0 'DefaultCursor
DefaultType = 2 'UseODBC
Exclusive = 0 'False
Height = 285
Left = 8760
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = "tongji"
Top = 960
Visible = 0 'False
Width = 2415
End
Begin VB.TextBox Text3
Height = 375
Left = 8280
TabIndex = 7
Top = 120
Width = 1695
End
Begin VB.TextBox Text2
DataField = "cs"
DataSource = "Data2"
Height = 375
Left = 6360
Locked = -1 'True
TabIndex = 6
Text = "Text2"
Top = 120
Width = 1215
End
Begin VB.TextBox Text1
DataField = "zs"
DataSource = "Data2"
Height = 375
Left = 4200
Locked = -1 'True
TabIndex = 5
Text = "Text1"
Top = 120
Width = 1335
End
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access"
DatabaseName = "D:\tscg\bookcgk.mdb"
DefaultCursorType= 0 'DefaultCursor
DefaultType = 2 'UseODBC
Exclusive = 0 'False
Height = 375
Left = 8760
Options = 0
ReadOnly = -1 'True
RecordsetType = 1 'Dynaset
RecordSource = "xgs"
Top = 1800
Visible = 0 'False
Width = 2415
End
Begin VB.Label Label4
Caption = "金额："
BeginProperty Font
Name = "楷体_GB2312"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 7560
TabIndex = 4
Top = 120
Width = 975
End
Begin VB.Label Label3
Caption = "册数："
BeginProperty Font
Name = "楷体_GB2312"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 5640
TabIndex = 3
Top = 120
Width = 1095
End
Begin VB.Label Label2
Caption = "种数："
BeginProperty Font
Name = "楷体_GB2312"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3480
TabIndex = 2
Top = 120
Width = 1095
End
Begin VB.Label Label1
Caption = "您选择的图书如下："
BeginProperty Font
Name = "华文行楷"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 120
TabIndex = 1
Top = 120
Width = 2775
End
End
Attribute VB_Name = "dgoutput1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
Dim sqlstring As String
Dim filenam As String
Dim fieldtype As Integer
Dim pzhh As Recordset
Dim recnum10 As Long
Dim db As Database
Dim rs As Recordset
Dim recount As Long
recount = 0
recnum10 = 0
'On Error Resume Next
'If tablestr <> "采购库" Then
' MsgBox "请选择采购库进行查询后，再将查询的数椐转为工作单"
' Exit Sub
' End If
'rstable.MoveFirst
'If rstable.EOF Then
' MsgBox "没找到所要的记录"
' Exit Sub
' End If
On Error Resume Next
filenam = ""
filenam = InputBox("请输入工作单文件名(不包含路径,文件位于d:\tscg\temp\*.wor下)：")
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
'读取字段值
jkzh = Str(rs.Fields("ID").Value)
sm = rs.Fields("bookname").Value
jg1 = Str(rs.Fields("jg").Value)
xcbl = rs.Fields("bmn").Value
xcbs = rs.Fields("bms").Value
zz = rs.Fields("author").Value
isbn = rs.Fields("isbn").Value
sxbs = Str(rs.Fields("fbl").Value)
'将此条记录写入文件
Print #1, "00575nam0 2200229 45"
If jkzh = Null Then jkzh = ""
worstr1 = "001" + jkzh
Print #1, worstr1
jkzh = "" '1记录控制号 001$a
If isbn = Null Then isbn = ""
If jg1 = Null Then jg1 = ""
worstr2 = "010 @a" + isbn + "@d" + jg1
Print #1, worstr2
isbn = "" '2ISBN号 010$a
jg1 = "" '价格 010$d
If sm = Null Then sm = ""
If zz = Null Then zz = ""
worstr3 = "2001 @a" + sm + "@f" + zz
Print #1, worstr3
sm = "" '3书名 200$a
If xcbs = Null Then xcbs = ""
If xcbl = Null Then xcbl = ""
worstr4 = "210 @c" + xcbs + "@d" + xcbl
Print #1, worstr4
xcbs = "" '出版社 210$c
xcbl = "" '出版年 210$d
worstr7 = "701 @a" + zz
Print #1, worstr7
zz = "" '作者 200$f,701$a
If sxbs = Null Then sxbs = ""
worstr8 = "960 @e" + sxbs
Print #1, worstr8
sxbs = "" '所选本数 960$e
Print #1, "***"
recnum10 = recnum10 + 1
rs.MoveNext
Loop
Close #1
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 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
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -