main.frm

社区医疗管理系统 用vb开发的简单社区卫生组织用的管理系统

         Checked         =   -1  'True
      End
      Begin VB.Menu mnuVerticality 
         Caption         =   "垂直渐变"
      End
      Begin VB.Menu mnuNoGradientDire 
         Caption         =   "无渐变"
      End
   End
   Begin VB.Menu Menu_help 
      Caption         =   "帮助(&H)"
      Begin VB.Menu MenuHelp_Help 
         Caption         =   "帮助信息(&C)"
      End
      Begin VB.Menu line4 
         Caption         =   "-"
      End
      Begin VB.Menu MenuHelp_about 
         Caption         =   "关于医疗点数据管理系统(&A)"
      End
   End
   Begin VB.Menu right 
      Caption         =   "右键"
      Visible         =   0   'False
      Begin VB.Menu accessadd 
         Caption         =   "名单录入"
      End
      Begin VB.Menu accessfind 
         Caption         =   "名单查询"
      End
   End
End
Attribute VB_Name = "Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2007/07/18
'描    述：社区医疗点数据管理系统 Ver 1.0
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

Option Explicit
'Dim mnuXP_usHoariness
Private Sub accessbf_Click() '备份数据库
Dim mfile As String, mfile2 As String
On Error Resume Next
CommonDialog1.FileName = "medic.mdb"
CommonDialog1.Filter = "Access文件(*.mdb)|*.mdb"
CommonDialog1.ShowSave
mfile = App.Path & "\medic.mdb" '要备份的文件为当前文件夹下的 medic.mdb
mfile2 = CommonDialog1.FileName '得到目标文件的路径
If Trim(mfile2) = "" Then Exit Sub
If Dir(mfile2) <> "" Then
If MsgBox(Dir(mfile2) & " 文件已经存在，是否替换？", vbYesNo + 32, "警告") = vbNo Then Exit Sub
End If
Dim buff() As Byte, i As Long

i = FileLen(mfile)
ReDim buff(i - 1)

Open mfile For Binary As #1
Get #1, , buff
Close #1

Open mfile2 For Binary As #1
Put #1, , buff
Close #1

MsgBox "备份成功！", 64, "恭喜"
End Sub

Private Sub accesshf_Click()  '还原数据库
Dim mfile As String, mfile2 As String
On Error Resume Next
CommonDialog1.FileName = "medic.mdb"
CommonDialog1.Filter = "Access文件(*.mdb)|*.mdb"
CommonDialog1.ShowOpen
mfile = CommonDialog1.FileName '得到别处的Access文件的路径
mfile2 = App.Path & "\medic.mdb" '要覆盖掉当前文件夹下的 medic.mdb

If Trim(mfile) = "" Then Exit Sub

If MsgBox("是否恢复数据库？", vbYesNo + 32, "警告") = vbNo Then Exit Sub

Dim buff() As Byte, i As Long

i = FileLen(mfile)
ReDim buff(i - 1)

Open mfile For Binary As #1
Get #1, , buff
Close #1

Open mfile2 For Binary As #1
Put #1, , buff
Close #1

MsgBox "恢复成功！", 64, "恭喜"
End Sub

Private Sub Exit1_Click()
If MsgBox("确定要退出吗？", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then
        End
    Else
        Main.Show
    End If
End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '右键菜单
   If Button = 2 Then
   PopupMenu right
   End If
End Sub
Private Sub Menu_ManageAdd_Click()
      frmadduser.Show
End Sub

Private Sub Menu_Managechange_Click()
      frmchangepwd.Show
End Sub

Private Sub Menu_EditDelete_Click()
    frmmedicmanage.Show
End Sub

Private Sub Menu_Editinto_Click()
    frmmedicmanage.Show
End Sub

Private Sub Menu_Editmedicchange_Click()
     frmmedicmanage.Show
End Sub
Private Sub Menu_Findname_Click() '按名
   frmmedicfind.Show
   frmmedicfind.Combo1.Text = frmmedicfind.Combo1.List(0)
End Sub
Private Sub Menu_Findtype_Click() '按时间
  frmmedicfind.Show
  frmmedicfind.Combo1.Text = frmmedicfind.Combo1.List(1)
  
End Sub
Private Sub Menu_add_Click()
 frmmedicfind.Show
   frmmedicfind.Combo1.Text = frmmedicfind.Combo1.List(2)
End Sub

Private Sub Menu_tel_Click()
 frmmedicfind.Show
   frmmedicfind.Combo1.Text = frmmedicfind.Combo1.List(3)
End Sub

Private Sub MenuHelp_about_Click() '关于
    frmScrollingSplashScreen.Show
End Sub

Private Sub MenuHelp_Help_Click() '打开帮助文件
Call HtmlHelp(0, App.Path & "\help.chm", &H0, ByVal "新建 文本文档 (5).txt")
End Sub
'************************************ 菜单office2003

Private Sub mnuHorizontal_Click()
If mnuOfficeXp.Checked Then
        'msgbox "OfficeXP风格时设置渐变风格将可能不一致！"
    Else
        mnuHorizontal.Checked = True
        mnuVerticality.Checked = False
        'mnuNoGradientDire.Checked = False
    
    
        VsNetMenu1.ShowMainBarGradient = True
        VsToolBar1.ShowGradient = True
        VsNetMenu1.MainBarGradientDire = usHorizontal
        VsToolBar1.GradientDire = usHorizontal
    End If
    
End Sub

Private Sub mnuNoGradientDire_Click()
mnuHorizontal.Checked = False
    mnuVerticality.Checked = False
    'mnuNoGradientDire.Checked = True
    
    VsNetMenu1.ShowMainBarGradient = False
    VsToolBar1.ShowGradient = False

End Sub

Private Sub mnuOfficeXp_Click() 'office XP
 mnuXP_Blue.Checked = False
    mnuXP_OliveGreen.Checked = False
    mnuXP_Silver.Checked = False
    'mnuXP_usHoariness.Checked = False
    mnuOfficeXp.Checked = True
    
    VsNetMenu1.SetMenuStyle usOfficeXp
    VsToolBar1.SetButtonStyle usOfficeXp

    mnuNoGradientDire_Click

End Sub

Private Sub mnuVerticality_Click()
If mnuOfficeXp.Checked Then
        'msgbox "OfficeXP风格时设置渐变风格将可能不一致！"
    Else
        mnuHorizontal.Checked = False
        mnuVerticality.Checked = True
        'mnuNoGradientDire.Checked = False
    
        VsNetMenu1.ShowMainBarGradient = True
        VsToolBar1.ShowGradient = True
    
        VsNetMenu1.MainBarGradientDire = usVerticality
        VsToolBar1.GradientDire = usVerticality
    End If
End Sub

Private Sub mnuXP_Blue_Click()  'xp
    mnuXP_Blue.Checked = True
    mnuXP_OliveGreen.Checked = False
    mnuXP_Silver.Checked = False
    'mnuXP_usHoariness.Checked = False
    mnuOfficeXp.Checked = False
    mnuHorizontal_Click
    VsNetMenu1.SetMenuStyle usXP_Blue

    VsToolBar1.SetButtonStyle usXP_Blue


End Sub

Private Sub mnuXP_OliveGreen_Click()  '绿
 mnuXP_Blue.Checked = False
    mnuXP_OliveGreen.Checked = True
    mnuXP_Silver.Checked = False
    'mnuXP_usHoariness.Checked = False
    mnuOfficeXp.Checked = False
    mnuHorizontal_Click
    VsNetMenu1.SetMenuStyle usXP_OliveGreen
    VsToolBar1.SetButtonStyle usXP_OliveGreen

End Sub

Private Sub mnuXP_Silver_Click() '白
  mnuXP_Blue.Checked = False
    mnuXP_OliveGreen.Checked = False
    mnuXP_Silver.Checked = True
    'mnuOfficeXp.Checked = False
    mnuHorizontal_Click
    
    VsNetMenu1.SetMenuStyle usXP_Silver
    VsToolBar1.SetButtonStyle usXP_Silver

End Sub
Private Sub VsNetMenu1_Highlight(Caption As String)
   If Caption = "增加用户(&A)" Then
       StatusBar1.Panels(1).Text = "您可以增加用户"
    Else
   StatusBar1.Panels(1).Text = Caption
   End If
End Sub

Private Sub VsToolBar1_ButtonClick(ByVal ButtonIndex As Integer, ByVal ButtonKey As String) '复选 查询
  Select Case ButtonKey
        Case "Menu_Findname1"
            VsToolBar1.PopMenu Menu_Find
        Case "Menu_ManageAdd1"
              frmadduser.Show
        Case "Menu_Managechange1"
              frmchangepwd.Show
        Case "Menu_Editinto1"
              frmmedicmanage.Show
        Case "Menu_Editmedicchange1"
              frmmedicmanage.Show
        Case "Menu_EditDelete1"
              frmmedicmanage.Show
        Case "accessbf1"
              accessbf_Click
        Case "accesshf1"
              accesshf_Click
        Case "MenuHelp_Help1"
              MenuHelp_Help_Click
        Case "MenuHelp_about1"
             frmScrollingSplashScreen.Show
        Case " Exit11"
             Exit1_Click
        End Select
End Sub

Private Sub VsToolBar1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) '在工具栏中的右键菜单
    If Button = 2 Then
        PopupMenu mnuStyle
    End If
End Sub