VB6.0分析access数据，生成excel文件

最新推荐文章于 2024-02-26 17:08:30 发布

xqg_5083

最新推荐文章于 2024-02-26 17:08:30 发布

阅读量1.1k

点赞数

分类专栏： VB 文章标签： excel access vb datagrid security integer

本文链接：https://blog.csdn.net/xqg_5083/article/details/7780205

版权

VB 专栏收录该内容

1 篇文章 0 订阅

订阅专栏

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim targetUrl As String
Dim Conn As ADODB.Connection
Dim Reco0, RecoBas, Reco, RecoType As New ADODB.Recordset
Dim rowid, colid As Integer

Private Sub Command1_Click()
If InStrRev(Text1.Text, Chr(46) & Chr(109) & Chr(100) & Chr(98)) = 0 Or IsNull(InStrRev(Text1.Text, Chr(46) & Chr(109) & Chr(100) & Chr(98))) Then
MsgBox Chr(-14357) & Chr(-11871) & Chr(-11023) & Chr(-10755) & Chr(-14153) & Chr(-19004) & "mdb" & Chr(-13571) & Chr(-16675) & Chr(-12604) & Chr(-17154) & Chr(-23647)
Exit Sub
End If
Text2.Text = Chr(-15169) & Chr(-19990) & Chr(101) & Chr(120) & Chr(99) & Chr(101) & Chr(108) & Chr(-12604) & Chr(-17154) & Chr(-10755) & Chr(-13830) & Chr(-19511) & Chr(-10544) & Chr(-42) & Chr(46) & Chr(46) & Chr(46)
If Text1.Text = "" Then
MsgBox Chr(-13571) & Chr(-16675) & Chr(-11084) & Chr(-11084) & Chr(-12604) & Chr(-17154) & Chr(-12630) & Chr(-16427) & Chr(-23636) & Chr(-14357) & Chr(-11871) & Chr(-11023) & Chr(-13571) & Chr(-16675) & Chr(-11084) & Chr(-12604) & Chr(-17154)
Text1.SetFocus
Exit Sub
End If
Command2.Enabled = False
Command3.Enabled = False
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
xlApp.Visible = False
Set xlSheet = xlBook.Worksheets("sheet1")
Set Conn = CreateObject("ADODB.Connection")
Set Reco = CreateObject("ADODB.Recordset")
Set RecoType = CreateObject("ADODB.Recordset")
Set RecoBas = CreateObject("ADODB.Recordset")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & targetUrl
RecoBas.Open "SELECT A.XM,A.XB,A.NL,A.BMBH,B.BMMC,A.JY,A.TJRQ,A.RYBH FROM TJDJB A,TJBMB B WHERE A.BMBH=B.BMBH", Conn, 2, 3
RecoType.Open "SELECT DISTINCT A.TJXMBH, A.MC, B.ZHXMBH from TJXM A,TJJRMX B WHERE A.TJXMBH = B.TJXMBH ORDER BY B.ZHXMBH, A.TJXMBH ", Conn, 2, 3
xlSheet.Cells(1, 1).Value = Chr(-12075) & Chr(-15365)
xlSheet.Cells(1, 2).Value = Chr(-12076) & Chr(-19984)
xlSheet.Cells(1, 3).Value = Chr(-15126) & Chr(-15900)
xlSheet.Cells(1, 4).Value = Chr(-19777) & Chr(-15419) & Chr(-15365) & Chr(-19514)
xlSheet.Cells(1, 5).Value = Chr(-13083) & Chr(-17172) & Chr(-14123) & Chr(-14630)
rowid = 1
colid = 6
Do Until RecoType.EOF
xlSheet.Cells(1, colid).Value = RecoType("MC").Value
colid = colid + 1
RecoType.MoveNext
Loop
xlSheet.Cells(1, colid).Value = Chr(-13083) & Chr(-17172) & Chr(-16984) & Chr(-11543)
rowid = 2
colid = 1
Dim hasValue As Integer
hasValue = 0
Do Until RecoBas.EOF
colid = 1
xlSheet.Cells(rowid, colid).Value = Trim(RecoBas("XM").Value)
colid = colid + 1
xlSheet.Cells(rowid, colid).Value = Trim(RecoBas("XB").Value)
colid = colid + 1
xlSheet.Cells(rowid, colid).Value = Trim(RecoBas("NL").Value)
colid = colid + 1
xlSheet.Cells(rowid, colid).Value = Trim(RecoBas("BMMC").Value)
colid = colid + 1
xlSheet.Cells(rowid, colid).Value = Trim(RecoBas("TJRQ").Value)
colid = colid + 1
Reco.Open "SELECT A.XM,A.XB,A.NL,E.BMMC, C.XH,C.TJXMBH,C.ZHXMBH ,D.MC, C.JG,C.JCRQ,C.JCYS,A.JY,A.RYBH FROM TJDJB A,TJJR B, TJJRMX C ,TJXM D,TJBMB E WHERE A.TJBH = B.TJBH AND B.XH = C.XH AND C.TJXMBH =D.TJXMBH AND E.BMBH = A.BMBH AND A.RYBH='" & RecoBas("RYBH").Value & "' ORDER BY E.BMBH,A.XM,C.ZHXMBH, C.TJXMBH ", Conn, 2, 3
RecoType.MoveFirst
Do Until RecoType.EOF
Reco.MoveFirst
Do Until Reco.EOF
If Reco("TJXMBH").Value = RecoType("TJXMBH").Value And Reco("RYBH").Value = RecoBas("RYBH").Value Then
If Reco("JG").Value = "" Or IsNull(Reco("JG").Value) Then
xlSheet.Cells(rowid, colid).Value = ""
Else
xlSheet.Cells(rowid, colid).Value = Trim(Reco("JG").Value)
End If
End If
Reco.MoveNext
Loop
colid = colid + 1
RecoType.MoveNext
Loop
If RecoBas("JY").Value = "" Or IsNull(RecoBas("JY").Value) Then
xlSheet.Cells(rowid, colid).Value = ""
Else
xlSheet.Cells(rowid, colid).Value = Trim(RecoBas("JY").Value)
End If
Reco.Close
rowid = rowid + 1
RecoBas.MoveNext
Loop
RecoBas.Close
RecoType.Close
Conn.Close
targetUrl = Left(targetUrl, InStrRev(targetUrl, Chr(92))) & Chr(-13083) & Chr(-17172) & Chr(-13571) & Chr(-16675) & Chr(46) & Chr(120) & Chr(108) & Chr(115)
xlApp.ActiveWorkbook.SaveAs (targetUrl)
xlBook.Close (True)
xlApp.Quit
Set xlApp = Nothing
Set RecoBas = Nothing
Set RecoType = Nothing
Set Conn = Nothing
Command2.Enabled = True
Command3.Enabled = True
Text2.Text = Chr(-15169) & Chr(-19990) & Chr(101) & Chr(120) & Chr(99) & Chr(101) & Chr(108) & Chr(-12604) & Chr(-17154) & Chr(-11567) & Chr(-13830) & Chr(-19511) & Chr(-23622) & targetUrl
End Sub

Private Sub Command2_Click()
CommonDialog1.Flags = &H200 Or &H80000
CommonDialog1.Filter = Chr(42) & Chr(46) & Chr(42) & Chr(32)
CommonDialog1.ShowOpen
targetUrl = CommonDialog1.FileName
Debug.Print CommonDialog1.FileName
If InStrRev(CommonDialog1.FileName, Chr(46) & Chr(109) & Chr(100) & Chr(98)) = 0 Or IsNull(InStrRev(CommonDialog1.FileName, Chr(46) & Chr(109) & Chr(100) & Chr(98))) Then
MsgBox Chr(-14357) & Chr(-11871) & Chr(-11023) & Chr(-10755) & Chr(-14153) & Chr(-19004) & "mdb" & Chr(-13571) & Chr(-16675) & Chr(-12604) & Chr(-17154) & Chr(-23647)
Text1.Text = Chr(-14357) & Chr(-11871) & Chr(-11023) & Chr(-10755) & Chr(-14153) & Chr(-19004) & Chr(-13571) & Chr(-16675) & Chr(-12604) & Chr(-17154) & Chr(-23647)
Exit Sub
End If
Text1.Text = CommonDialog1.FileName
Set Conn = CreateObject("ADODB.Connection")
Set Reco0 = CreateObject("ADODB.Recordset")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & targetUrl
L1:
Reco0.Open "SELECT A.XM,A.XB,A.NL,E.BMMC, C.TJXMBH, D.MC, C.JG,C.JCRQ,C.JCYS,A.JY FROM TJDJB A,TJJR B, TJJRMX C ,TJXM D,TJBMB E WHERE A.TJBH = B.TJBH AND B.XH = C.XH AND C.TJXMBH =D.TJXMBH AND E.BMBH = A.BMBH ORDER BY E.BMBH,A.XM,C.TJXMBH ", Conn, 1, 1
If Reco0.EOF And Reco0.BOF Then
MsgBox "ERROR!", 16
Else
If "" = Reco0("XM").Value Then
MsgBox Chr(-12630) & Chr(-16427) & Chr(-23636) & Chr(-14357) & Chr(-11871) & Chr(-11023) & Chr(-13571) & Chr(-16675) & Chr(-11084) & Chr(-12604) & Chr(-17154), 16
End If
End If
Reco0.Close
Conn.Close
Set Reco0 = Nothing
Set Conn = Nothing
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & targetUrl & ";Persist Security Info=False"
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "SELECT A.XM,A.XB,A.NL,E.BMMC, C.TJXMBH, D.MC, C.JG,C.JCRQ,C.JCYS,A.JY FROM TJDJB A,TJJR B, TJJRMX C ,TJXM D,TJBMB E WHERE A.TJBH = B.TJBH AND B.XH = C.XH AND C.TJXMBH =D.TJXMBH AND E.BMBH = A.BMBH ORDER BY E.BMBH,A.XM,C.TJXMBH"
Set DataGrid1.DataSource = Adodc1
DataGrid1.Refresh
Adodc2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & targetUrl & ";Persist Security Info=False"
Adodc2.CommandType = adCmdText
Adodc2.RecordSource = "SELECT DISTINCT A.TJXMBH, A.MC from TJXM A,TJJRMX B WHERE A.TJXMBH = B.TJXMBH ORDER BY A.TJXMBH"
Set DataGrid2.DataSource = Adodc2
DataGrid2.Refresh
Adodc3.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & targetUrl & ";Persist Security Info=False"
Adodc3.CommandType = adCmdText
Adodc3.RecordSource = "SELECT A.XM,A.XB,A.NL,A.BMBH,B.BMMC,A.JY FROM TJDJB A,TJBMB B WHERE A.BMBH=B.BMBH"
Set DataGrid3.DataSource = Adodc3
DataGrid3.Refresh
End Sub

Private Sub Data1_Validate(Action As Integer, Save As Integer)

End Sub
Private Sub Command3_Click()
Text1.Text = ""
Text2.Text = ""
Set DataGrid1.DataSource = Nothing
DataGrid1.Refresh
Set DataGrid2.DataSource = Nothing
DataGrid2.Refresh
Set DataGrid3.DataSource = Nothing
DataGrid3.Refresh
End Sub

Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
End Sub

Public Sub deleteR(ssql As String)
DoCmd.SetWarnings False
DoCmd.RunSql ssql
End Sub