module1.bas

小型客户管理系统

Attribute VB_Name = "Module1"
'用户数据数据集
Public MainDB As New ADODB.Connection
Public MainRS As New ADODB.Recordset
Public MainDB_Open As Boolean '标识数据库是否打开

'系统数据集
Public SysLogDB As New ADODB.Connection
Public SysLogRS As New ADODB.Recordset
Public SysLogDB_Open As Boolean '标识数据库是否打开

Public DataBasePath As String '保存数据库路径
Public MainSQL As String '保存sql语句

Public UserDept As String '保存用户部门
Public UserName As String '保存用户名

Public ClientCode As Integer '保存客户编号
Public ClientName As String '保存客户名称
Public UseDataBase As String '保存使用数据库
Public DataCode As Integer '保存关联数据库编号

Public OperateCode As Integer  '标识操作状态值（当前是何操作）
Public OperateState As String '标识操作（add,update,delete）
Public OperateDB As String   '标识当前操作数据库

Private Fs As New FileSystemObject '用于Sub Main
Private TempFile As TextStream '用于Sub Main

Sub Main()
Dim Fp As String

If App.PrevInstance = True Then
   MsgBox "本程序已经运行", vbExclamation, "警告"
   End
End If

If Not Fs.FileExists("C:\Program Files\Microsoft Office\Office\MSACCESS.EXE") Then
   MsgBox "运行此程序需要安装MicroSoft Office2000程序，并且需安装在C:\Program Files\目录下，否则将不能打印报表", vbExclamation, "警告"
End If

'建立存放导入数据库的目录
If Not Fs.FolderExists(App.Path & "\indata") Then
   Fs.CreateFolder (App.Path & "\indata")
End If

If Not Fs.FileExists(App.Path & "\DP.txt") Then
   Fs.CreateTextFile "DP.txt"
   Select_DB.Show
Else
   Set TempFile = Fs.OpenTextFile(App.Path & "\DP.txt", ForReading)
   If TempFile.AtEndOfLine Then
      Select_DB.Show
   Else
      Fp = TempFile.ReadLine
      If Not Fs.FileExists(Fp) Then
         MsgBox "没有找到数据库，请检查", vbExclamation, "警告"
         Select_DB.Show
      Else
         DataBasePath = Fp
         TempFile.Close
         Sys_Login.Show
      End If
   End If
End If
End Sub

'****************将所需打印数据导入临时数据库中****************
'FieldNum字段个数（从0开始）
Public Sub CreateFile()
If Not Fs.FolderExists("c:\OutPutData") Then
   Fs.CreateFolder ("c:\OutPutData")
End If

If Fs.FileExists("c:\OutPutData\Output_DB.mdb") Then
   Fs.DeleteFile "c:\OutPutData\Output_DB.mdb"
End If
Fs.CopyFile App.Path & "\Output_DB.mdb", "c:\OutPutData\"
End Sub
Public Sub DaoBiao(TableName As String, FieldNum As Integer, DataRS As Recordset)

Dim OutPutDB As New ADODB.Connection, OutPutRs As New ADODB.Recordset
Dim OutPutDB_Open As Boolean

'MsgBox DataRS.RecordCount
   
Set OutPutDB = New ADODB.Connection
OutPutDB.CursorLocation = adUseClient
OutPutDB.Open "driver={Microsoft Access Driver (*.mdb)};dbq=c:\OutPutData\Output_DB.mdb" & ""
OutPutDB_Open = True

'OutPutDB.Execute ("Delete * From " & TableName)

Set OutPutRs = New ADODB.Recordset
OutPutRs.Open "select * from " & TableName, OutPutDB, adOpenStatic, adLockOptimistic
'MsgBox FhRs.RecordCount
If DataRS.RecordCount <> 0 Then
   DataRS.MoveFirst
   While Not DataRS.EOF
      '导入数据
      OutPutRs.AddNew
      For I = 0 To FieldNum
          OutPutRs.Fields(I) = DataRS.Fields(I)
      Next I
      OutPutRs.Update
      DataRS.Update
      DataRS.MoveNext
   Wend
End If

Set OutPutRs = Nothing
If OutPutDB_Open Then
   OutPutDB.Close
End If

'MsgBox "成功导出", vbInformation, "信息提示"

'导出后打开access来利用做好的access report打印
'If Fs.FileExists("C:\Program Files\Microsoft Office\Office\MSACCESS.EXE") Then
'   Shell "C:\Program Files\Microsoft Office\Office\MSACCESS.EXE c:\jxctmp\ReportTmp.mdb", vbNormalFocus
'Else
'   MsgBox "无法找到MSACCESS程序，确认Office程序安装在C:\Program Files\目录下？", vbExclamation, "警告"
'End If
End Sub
'**************************************************************