mdiform1.frm

一套适用于超市

   Dim datapath As String
   Dim fso As New FileSystemObject, fill As File, fldr As Folder, bpath As String

Private Sub A1_Click()
yhgl.Show
End Sub

Private Sub A2_Click()
xgmm.Show
End Sub

Private Sub A4_Click()
Unload Me
End Sub



Private Sub B1_Click()
rktj.Show
End Sub

Private Sub B2_Click()
rkxg.Show
End Sub



Private Sub B3_Click()
rksc.Show
End Sub

Private Sub B4_Click()
rkcx.Show
End Sub

Private Sub C1_Click()
ckgl.Show
End Sub



Private Sub C2_Click()
ckcx.Show
End Sub










Private Sub D1_Click()
kcxxgl.Show
End Sub

Private Sub D2_Click()
kccx.Show
End Sub

Private Sub E_Click()
gysgl.Show
End Sub

Private Sub F1_Click()
Dim fso As New FileSystemObject, fill As File
 Dim HelpPath As String
    If Right(Trim(App.Path), 1) <> "\" Then
      HelpPath = App.Path + "\"
  Else
      HelpPath = App.Path
  End If
  'HelpPath = HelpPath + ".chm"
  Shell (App.Path + "\Help\HelpMaker.exe ") + HelpPath, vbNormalFocus
    
End Sub

Private Sub F2_Click()
about.Show
End Sub

Private Sub H1_Click()
If Loged = -1 Then
  Loged = 1
  mnu_login.Caption = "登录"
  If MsgBox("确实要注销" & MDIForm1.StatusBar1.Panels(1).Text & "?", vbInformation + vbYesNo + vbDefaultButton1, "退出") = vbYes Then
     MDIForm1.StatusBar1.Panels(1).Text = ""
     MDIForm1.StatusBar1.Panels(2).Text = ""
     MDIForm1.H.Enabled = True
     MDIForm1.A.Enabled = False
     MDIForm1.B.Enabled = False
     MDIForm1.C.Enabled = False
     MDIForm1.D.Enabled = False
     MDIForm1.E.Enabled = False
     MDIForm1.F.Enabled = True
     Toolbar1.Buttons(1).Visible = True
     Toolbar1.Buttons(2).Visible = True
     Toolbar1.Buttons(8).Visible = True
     Toolbar1.Buttons(4).Visible = False
     Toolbar1.Buttons(5).Visible = False
     Toolbar1.Buttons(6).Visible = False
     Toolbar1.Buttons(7).Visible = False
  End If
Else
  Loged = -1
 H1.Caption = "注销"
  Frm_Login.Show 1
End If
End Sub

Private Sub H2_Click()
If MsgBox("是否真要退出？", vbInformation + vbYesNo + vbDefaultButton1, "提示") = vbYes Then
    Unload Me
End If
End Sub

Public Sub ExcelInput(strfilename)
Dim xlApp As Excel.Application
Dim xlbook As Excel.Workbook  '定义工作簿变量
Dim xlsheet As Excel.Worksheet  '定义工作表变量
Dim i As Integer, j As Integer
On Error GoTo err  '如果文件名错误,进入错误处理语句
'操作数据表
Set rstu = New Recordset
rstu.Open "select * from 入库表", cs, adOpenKeyset, adLockPessimistic
'操作Excel
strfilename = App.Path & "\入库表.xls"
Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.application") '激活Excel应用程序
Set xlbook = xlApp.Workbooks.Open(strfilename) '打开工作簿
Set xlsheet = xlbook.Worksheets("入库表") '设定工作表
'导入记录
i = 2: j = 1
Do While Trim(xlsheet.Cells(i, j)) <> ""
  rstu.AddNew
  rstu.Fields(0) = xlsheet.Cells(i, j)
  rstu.Fields(1) = xlsheet.Cells(i, j + 1)
  rstu.Fields(2) = xlsheet.Cells(i, j + 2)
  rstu.Fields(3) = xlsheet.Cells(i, j + 3)
  rstu.Fields(4) = xlsheet.Cells(i, j + 4)
  rstu.Fields(5) = xlsheet.Cells(i, j + 5)
  rstu.Fields(6) = xlsheet.Cells(i, j + 6)
  rstu.Fields(7) = xlsheet.Cells(i, j + 7)
  rstu.Fields(8) = xlsheet.Cells(i, j + 8)
  rstu.Fields(9) = xlsheet.Cells(i, j + 9)
  rstu.Fields(10) = xlsheet.Cells(i, j + 10)
  rstu.Fields(11) = xlsheet.Cells(i, j + 11)
  i = i + 1
  rstu.Update
Loop
MsgBox "导入结束！", 64, "操作提示"
xlbook.Close (True)
rstu.Close
cs.Close
Exit Sub
err:
  'MsgBox "文件打开错误!", 16, "操作提示"
End Sub


Public Sub ExcelOutput()
Dim xlApp As Excel.Application
Dim xlbook As Excel.Workbook  '定义工作簿变量
Dim xlsheet As Excel.Worksheet  '定义工作表变量
Dim strfilename As String, i As Integer, H As Integer
On Error GoTo err  '如果文件名错误,进入错误处理语句
 '操作数据表
Set rstu = New Recordset
rstu.Open "select * from 入库表", cs, adOpenKeyset, adLockPessimistic
'操作Excel
strfilename = App.Path & "\Excel\入库表.xls"
Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.application") '激活Excel应用程序
Set xlbook = xlApp.Workbooks.Open(strfilename) '打开工作簿
Set xlsheet = xlbook.Worksheets("入库表") '设定工作表
'写入字段名
For i = 1 To rstu.Fields.Count
xlsheet.Cells(1, i) = rstu.Fields(i - 1).Name
Next
'写入记录
H = 2
Do While rstu.EOF = False
  For i = 1 To rstu.Fields.Count
    xlsheet.Cells(H, i) = rstu.Fields(i - 1)
  Next
  rstu.MoveNext
  H = H + 1
Loop
MsgBox "导出结束!", 64, "操作提示"
'关闭Excel文件
xlbook.Close (True)
rstu.Close
cs.Close
 Exit Sub
err:
  'MsgBox "文件打开错误!", 16, "操作提示"
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
 Select Case Button.Key
 Case "数据备份"
   datapath = App.Path & "\database\chaoshi.mdb"
 Set fill = fso.GetFile(datapath)
 bpath = App.Path & "\backup"
 fso.GetFolder bpath
 If fso.FolderExists(bpath) = False Then
    Set fldr = fso.CreateFolder(bpath)
 End If
  CommonDialog1.InitDir = bpath
  CommonDialog1.FileName = "chaoshi" & Date & ".mdb"
  CommonDialog1.DialogTitle = ""
  CommonDialog1.Filter = "Access数据库(*.mdb)|*.mdb"
'当用户在保存时"取消"时,跳到BeckupExit
  On Error GoTo BeckupExit
  CommonDialog1.ShowSave
  If Not err.Number = 32755 Then
  fill.Copy CommonDialog1.FileName, True
  MsgBox "数据备份成功！" & vbCrLf & "备份的路径是：" & CommonDialog1.FileName, vbOKOnly + vbInformation, "数据备份成功 提示"
  End If
BeckupExit:
 Case "数据还原"
    'Dim fso As New FileSystemObject, fill As File, fldr As Folder, bpath As String
    On Error GoTo ReloadExit
    CommonDialog1.ShowOpen
    If Not err.Number = 32755 Then
        If MsgBox("警告：此操作会使现有数据丢失！" & vbCrLf & "是否真的要从数据库备份中，恢复数据库！", vbYesNo + vbQuestion, "数据库恢复") = vbYes Then
            bpath = App.Path & "\backup"
            fso.GetFolder bpath
            If fso.FolderExists(bpath) = False Then
                Set fldr = fso.CreateFolder(bpath)
            End If
            Set fill = fso.GetFile(CommonDialog1.FileName)
            datapath = App.Path & "\database\chaoshi.mdb"
            
            fill.Copy datapath, True
            MsgBox "数据库恢复成功！", vbOKOnly + vbInformation, "数据库恢复成功 提示"
        End If
    End If
ReloadExit:
 Case "打印"
 frmprint.Show
 Case "数据导出"
  ExcelOutput
 Case "数据导入"
   CommonDialog1.Filter = "Excel文件|*.xls"
   CommonDialog1.FileName = "入库表"
   CommonDialog1.ShowOpen
  If Trim(CommonDialog1.FileName) = "" Then
     MsgBox "请选择导入文件名!", 16, "操作提示"
     Exit Sub
  End If
     ExcelInput (CommonDialog1.FileName)
 
 Case "退出"
 If MsgBox("是否真要退出？", vbInformation + vbYesNo + vbDefaultButton1, "提示") = vbYes Then
   End
   End If
 End Select
End Sub