netdata.frm

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

VERSION 5.00
Begin VB.Form NetData 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "请输入网络数据库所在的映射驱动器及路径"
   ClientHeight    =   1500
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6405
   Icon            =   "NetData.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1500
   ScaleWidth      =   6405
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1 
      Height          =   1140
      Left            =   195
      TabIndex        =   4
      Top             =   150
      Width           =   4320
      Begin VB.CommandButton cmdBrowse 
         Caption         =   ".."
         Height          =   450
         Left            =   3840
         TabIndex        =   1
         ToolTipText     =   "浏览目录"
         Top             =   240
         Width           =   315
      End
      Begin VB.TextBox NetDataPath 
         BackColor       =   &H00FFFFFF&
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   14.25
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00C00000&
         Height          =   420
         Left            =   135
         TabIndex        =   0
         Top             =   255
         Width           =   3705
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "请输入网络数据库所在的映射驱动器及路径!"
         ForeColor       =   &H000000FF&
         Height          =   180
         Left            =   210
         TabIndex        =   5
         Top             =   795
         Width           =   3510
      End
   End
   Begin VB.CommandButton NetCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   405
      Left            =   4800
      TabIndex        =   3
      Top             =   675
      Width           =   1320
   End
   Begin VB.CommandButton OK 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   405
      Left            =   4800
      TabIndex        =   2
      Top             =   240
      Width           =   1320
   End
End
Attribute VB_Name = "NetData"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const m_wCurOptIdx = 0

Private Sub Form_Load()
  Dim wIdx As Integer, nFolder As Long
  Dim sPath As String * MAX_PATH
  Dim IDL As ITEMIDLIST
  'center
  NetData.Left = (Screen.Width - NetData.Width) / 2
  NetData.Top = (Screen.Height - NetData.Height) / 2
  Dim DataFile As String, NetFile As String
      DataFile = Browser + "sys\net.ini"
  On Error GoTo NetError
  Dim Fn As Integer
      Fn = FreeFile
  Open DataFile For Input As Fn
  Do While Not EOF(Fn)
  Line Input #Fn, NetFile
  If EOF(Fn) Then Exit Do
  Loop
  Close #Fn
  NetDataPath.Text = NetFile
Exit Sub

NetError:
  MsgBox "Net.ini 网络配置文件没有找到，请与供应商联系！    ", vbOKOnly + vbCritical, "警告！"
End Sub

Private Sub NetCancel_Click()
  Unload Me
End Sub

Private Sub NetDataPath_Change()
 If Trim(NetDataPath.Text) = "" Then
    OK.Enabled = False
 Else
    OK.Enabled = True
 End If
End Sub

Private Sub NetDataPath_GotFocus()
 NetDataPath.SelStart = 0
 NetDataPath.SelLength = Len(Trim(NetDataPath.Text))
End Sub

Private Sub NetDataPath_KeyPress(KeyAscii As Integer)
 If KeyAscii = 13 Then
    KeyAscii = 0
    SendKeys "{tab}"
    End If
End Sub

Private Sub OK_Click()
  '检查路径是否正确
      Dim DataFile As String, NetFile As String
      Dim Fn As Integer
      Dim NetFile0 As String, NetFile1 As String, NetFile2 As String
          NetFile = Trim(NetDataPath.Text)
      If Right(NetFile, 1) <> "\" Then
            NetFile = NetFile + "\"
         End If
       NetFile0 = NetFile & "Sample.MDB"
       NetFile1 = NetFile & "USER.MDB"
       NetFile2 = NetFile & "DATA.MDB"
       
       '继续增加数据库...1
       '检测数据库的正确性
       On Error GoTo NetError
          Fn = FreeFile
       Open NetFile0 For Input As Fn
       Close Fn
       Open NetFile1 For Input As Fn
       Close Fn
       Open NetFile2 For Input As Fn
       Close Fn
       '继续增加数据库...2
       
       
       '网络数据库
       
       SampleData = NetFile0
       UserData = NetFile1
       ConfigData = NetFile2
       
       '继续增加数据库...3
       
           
    '写入net.ini文件中
       DataFile = Browser + "sys\net.ini"
       Open DataFile For Output As Fn
       Print #Fn, NetFile
       Close Fn
       MsgBox "  从现在开始,您所使用的数据被存到以下目录的数据库中。  " & vbCrLf & vbCrLf & "    " & NetDataPath, vbInformation
       Unload Me
       
Exit Sub

'错误代码
NetError:
  MsgBox "路径错误，请再输入？    ", vbOKOnly + vbCritical, "警告!"
  NetDataPath.SetFocus
End Sub

Private Function GetFolderValue(wIdx As Integer) As Long
    
    If wIdx < 2 Then
       GetFolderValue = 0
    ElseIf wIdx < 12 Then
      GetFolderValue = wIdx
    Else
      GetFolderValue = wIdx + 4
    End If

End Function


Private Function GetReturnType() As Long
  Dim dwRtn As Long
  dwRtn = dwRtn
  GetReturnType = dwRtn
End Function

Private Sub cmdBrowse_Click()

  Dim BI As BROWSEINFO
  Dim nFolder As Long
  Dim IDL As ITEMIDLIST
  Dim pIdl As Long
  Dim sPath As String
  Dim SHFI As SHFILEINFO
  
  With BI
    .hOwner = NetData.hwnd
    nFolder = GetFolderValue(m_wCurOptIdx)
    If SHGetSpecialFolderLocation(ByVal Me.hwnd, ByVal nFolder, IDL) = NOERROR Then
      .pidlRoot = IDL.mkid.cb
    End If
    
    .pszDisplayName = String$(MAX_PATH, 0)
    .lpszTitle = "仿真资源管理器的浏览   =>  Mickeysoft"
    .ulFlags = GetReturnType()
    
  End With
  
  ' 显示浏览对话框
  pIdl = SHBrowseForFolder(BI)

  If pIdl = 0 Then Exit Sub
  sPath = String$(MAX_PATH, 0)
  SHGetPathFromIDList ByVal pIdl, ByVal sPath
  
  NetDataPath = Left(sPath, InStr(sPath, vbNullChar) - 1)
 
End Sub