mdiform1.frm

通用样品管理系统是一个商业程序,功能界面都还不错!

         Caption         =   "检索样品库"
         Shortcut        =   {F2}
      End
      Begin VB.Menu step11 
         Caption         =   "-"
      End
      Begin VB.Menu MnuBrowser 
         Caption         =   "浏览样品库"
         Shortcut        =   {F3}
      End
   End
   Begin VB.Menu MnuManager 
      Caption         =   "系统管理(&S)"
      Begin VB.Menu MnuBar 
         Caption         =   "工具栏 (&T)"
         Checked         =   -1  'True
      End
      Begin VB.Menu step51 
         Caption         =   "-"
         Visible         =   0   'False
      End
      Begin VB.Menu MnuSoftRegister 
         Caption         =   "软件注册(&R)..."
         Visible         =   0   'False
      End
      Begin VB.Menu STEP30 
         Caption         =   "-"
      End
      Begin VB.Menu MnuOperater 
         Caption         =   "操作员管理(&M)..."
      End
      Begin VB.Menu MnuOperator 
         Caption         =   "操作员管理(&M)..."
      End
      Begin VB.Menu STEP3 
         Caption         =   "-"
      End
      Begin VB.Menu MnuSample 
         Caption         =   "样品参数配置(&C)..."
      End
      Begin VB.Menu MnuSysConfig 
         Caption         =   "公司信息配置(&A)..."
      End
   End
   Begin VB.Menu MnuRemoteDataC 
      Caption         =   "远程数据配置(&R)"
      Begin VB.Menu MnuSingleMode 
         Caption         =   "设置为单机版模式(&S)..."
      End
      Begin VB.Menu step50 
         Caption         =   "-"
      End
      Begin VB.Menu MnuMultiMode 
         Caption         =   "设置网络数据库的位置(&L)..."
      End
   End
   Begin VB.Menu MnuHelp 
      Caption         =   "帮助系统(&H)"
      Begin VB.Menu MnuHelpContent 
         Caption         =   "帮助目录"
      End
      Begin VB.Menu MnuReadme 
         Caption         =   "阅读 Readme (&L)"
      End
      Begin VB.Menu step44 
         Caption         =   "-"
      End
      Begin VB.Menu MnuTip 
         Caption         =   "使用技巧..."
      End
      Begin VB.Menu step41 
         Caption         =   "-"
      End
      Begin VB.Menu MnuWeb 
         Caption         =   "虚拟温州市"
         Begin VB.Menu MnuProduct 
            Caption         =   "最新热卖产品信息 (&P)"
         End
         Begin VB.Menu MnuFAQ 
            Caption         =   "企业名录 (&Q)"
         End
         Begin VB.Menu MnuSupport 
            Caption         =   "分类信息 (&S)"
         End
         Begin VB.Menu step43 
            Caption         =   "-"
         End
         Begin VB.Menu MnuCompany 
            Caption         =   "东化科技主页 (H)"
         End
      End
      Begin VB.Menu step42 
         Caption         =   "-"
      End
      Begin VB.Menu MnuAbout 
         Caption         =   "关于 东化样品管理"
      End
   End
   Begin VB.Menu MnuExi 
      Caption         =   "退出系统(&E)"
   End
End
Attribute VB_Name = "MDIForm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim MouseD As Boolean, Oldx As Single, Oldy As Single

Private Sub MDIForm_Activate()

'显示每日一贴
Dim Ltp As Integer
    Ltp = GetSetting(App.EXEName, "Options", "Show Tips at Startup", 1)
 If Ltp = 1 Then
    frmTip.Show
 End If
'配置工具栏----------------------------------------------
  Ltp = GetSetting(App.EXEName, "ToolBar", "Show ToolBar", 1)
    If Ltp = 1 Then
       MnuBar.Checked = True
       'ToolForm.Show
       Picture1.Visible = True
         Else
       Picture1.Visible = False
       MnuBar.Checked = False
    End If

End Sub

Private Sub MDIForm_Load()
    '检测是否注册过
Dim sKeyName As String
Dim sEntry As String
Dim sRstr1 As String, sRstr2 As String
Dim bSuccess As Boolean
    '获得第一个值
    sKeyName = "HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Register"
    sEntry = "Register"
    gbSkipRegErrMsg = True
    sRstr1 = GetRegStringValue(sKeyName, sEntry)
If sRstr1 = "1" Then
    'OK第2次使用系统
    '获得第二个值
    sKeyName = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Setup"
    sEntry = "Register"
    gbSkipRegErrMsg = True
    sRstr2 = GetRegStringValue(sKeyName, sEntry)
    '注册完成
   If sRstr1 = "1" And sRstr2 = "8" Then
      '注册完成
   Else
      Dim sRstr3 As String
      sKeyName = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Setup"
      sEntry = "Date"
      gbSkipRegErrMsg = True
      sRstr3 = GetRegStringValue(sKeyName, sEntry)
      '使用次数到
      If Val(sRstr3) >= 300 Then
         MsgBox "使 用 期 限 满 ， 请 与 我 们 联 系。", vbOKOnly + vbCritical
         Register.Show 1
      Else
         '计数加1
         sKeyName = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Setup"
         sEntry = "Date"
         sRstr3 = Trim(Str(Val(sRstr3) + 1))
         bSuccess = WriteRegStringValue(sKeyName, sEntry, sRstr3)
      End If
    End If
   '检查完毕
   Else
    '注册1
    sKeyName = "HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Register"
    sEntry = "Register"
    sRstr1 = "1"
    bSuccess = WriteRegStringValue(sKeyName, sEntry, sRstr1)
    '注册2
    sKeyName = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Setup"
    sEntry = "Register"
    sRstr2 = "0"
    bSuccess = WriteRegStringValue(sKeyName, sEntry, sRstr2)
    '注册3
    sKeyName = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Setup"
    sEntry = "Date"
    sRstr3 = "1"
    bSuccess = WriteRegStringValue(sKeyName, sEntry, sRstr3)
End If
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

'超级用户
If UserText = "超级用户" Then
   MnuOperator.Visible = True
   MnuOperater.Visible = False
   Else
   MnuOperator.Visible = False
   MnuOperater.Visible = True
End If

MDIForm1.HelpContextID = 0
MDIForm1.MousePointer = 11
Call CoolBar(Toolbar1)
Dim Ltp As Long
    MDIForm1.WindowState = GetSetting(App.EXEName, "Windows", "Windows Status", 1)
Dim InNum As Integer
   '配置图片
     StatusBar.Panels.Item(3).Text = "日期:" & Date
   '配置
     Dim DB As Database, EF As Recordset, x As Integer
     Dim TempArray(5) As String
     On Error GoTo NoData
   '阅读配置数据
     Set DB = OpenDatabase(ConfigData)
     Set EF = DB.OpenRecordset("Config", dbOpenDynaset)
       ' Ef.MoveFirst
     For x = 0 To 5
      If Not IsNull(EF.Fields(x).Value) Then
          TempArray(x) = EF.Fields(x).Value
      End If
    Next
  DB.Close
  CompanyName = TempArray(0)

'结束___________________________________________________
  
  MDIForm1.Caption = TempArray(0) + "-样品管理系统"
  MDIForm1.StatusBar.Panels.Item(6).Text = "制作单位：" + TempArray(0)
  MDIForm1.StatusBar.Panels.Item(6).ToolTipText = "欢迎使用本软件"
  MDIForm1.MousePointer = 0
  On Error GoTo PhotoValible
  MDIForm1.Picture = LoadPicture(TempArray(5))
  MDIForm1.StatusBar.Panels.Item(2).Text = UserText
  Exit Sub
NoData:
  MsgBox "配置数据造破坏,不能配置完整的系统!", vbOKOnly + 16, "警告!"
  MDIForm1.MousePointer = 0
Exit Sub
PhotoValible:
  MsgBox "桌面图片配置有错误,请重新配置桌面!", vbOKOnly + 16, "警告!"
  MDIForm1.MousePointer = 0
  Exit Sub
End Sub

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim SureQ As Integer
  SureQ = MsgBox("真的退出该系统吗(Y/N)？", vbYesNo + 32, "请确认...")
  If SureQ = 6 Then
     Cancel = 0
     Else
     Cancel = -1
  End If
End Sub

Private Sub MDIForm_Resize()
   Line1.X1 = 0
   Line1.X2 = MDIForm1.ScaleWidth
   Line2.X1 = 0
   Line2.X2 = MDIForm1.ScaleWidth
End Sub

Private Sub MDIForm_Unload(Cancel As Integer)
  SaveSetting App.EXEName, "Windows", "Windows Status", MDIForm1.WindowState
End Sub

Private Sub MnuStoreBar_Click()
End Sub

Private Sub MnuAbout_Click()
MDIForm1.MousePointer = 11
If frmAbout.Visible Then
   MDIForm1.MousePointer = 0
   frmAbout.SetFocus
   Exit Sub
    Else
   frmAbout.Show
End If
   MDIForm1.MousePointer = 0
End Sub

Private Sub MnuBar_Click()
If MnuBar.Checked = True Then
   'Unload ToolForm
   MnuBar.Checked = False
   Picture1.Visible = False
   SaveSetting App.EXEName, "ToolBar", "Show ToolBar", 0
   Else
   'ToolForm.Show
   Picture1.Visible = True
   MnuBar.Checked = True
   SaveSetting App.EXEName, "ToolBar", "Show ToolBar", 1
End If
End Sub

Private Sub MnuBrowser_Click()
MDIForm1.MousePointer = 11
   Load frmView
MDIForm1.MousePointer = 0
   MDIForm1.Hide
   frmView.Show 1
End Sub

Private Sub MnuCompany_Click()
MDIForm1.MousePointer = 11
Dim WxyNo As Long
 WxyNo = ShellExecute(Me.hwnd, "open", "Http://www.freelong.net/index.html", "", App.Path, 1)
If WxyNo = 0 Then
 MsgBox "浏览器没有正确安装或其它错误。", vbOKOnly + 16, "登录错误"
End If
 MDIForm1.MousePointer = 0
End Sub

Private Sub MnuDelete_Click()
MDIForm1.MousePointer = 11
If frmDelete.Visible = True Then
    MDIForm1.MousePointer = 0
    frmDelete.SetFocus
   Else
    frmDelete.Show
End If
MDIForm1.MousePointer = 0
End Sub