📄 frmother.frm
字号:
Y1 = 6060
Y2 = 6165
End
Begin VB.Line Line4
BorderColor = &H00800000&
Index = 2
X1 = 2430
X2 = 2370
Y1 = 6075
Y2 = 6165
End
Begin VB.Line Line1
BorderColor = &H00800000&
Index = 2
X1 = 2190
X2 = 2670
Y1 = 3405
Y2 = 3405
End
Begin VB.Line Line2
BorderColor = &H00800000&
Index = 1
X1 = 2445
X2 = 2445
Y1 = 2700
Y2 = 3420
End
Begin VB.Line Line3
BorderColor = &H00800000&
Index = 1
X1 = 2445
X2 = 2520
Y1 = 2685
Y2 = 2790
End
Begin VB.Line Line4
BorderColor = &H00800000&
Index = 1
X1 = 2430
X2 = 2370
Y1 = 2700
Y2 = 2790
End
Begin VB.Line Line1
BorderColor = &H00800000&
Index = 3
X1 = 2205
X2 = 2685
Y1 = 2670
Y2 = 2670
End
Begin VB.Line Line12
BorderColor = &H00FFFFFF&
X1 = 165
X2 = 3585
Y1 = 6375
Y2 = 6375
End
Begin VB.Line Line11
BorderColor = &H80000005&
X1 = 3585
X2 = 3585
Y1 = 2595
Y2 = 6390
End
Begin VB.Line Line10
BorderColor = &H80000003&
X1 = 165
X2 = 3585
Y1 = 2595
Y2 = 2595
End
Begin VB.Line Line9
BorderColor = &H80000003&
X1 = 165
X2 = 165
Y1 = 2610
Y2 = 6375
End
Begin VB.Shape Shape2
BorderColor = &H000080FF&
FillColor = &H00C0FFFF&
FillStyle = 0 'Solid
Height = 3765
Left = 180
Top = 2610
Width = 3390
End
End
Attribute VB_Name = "frmOther"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdLocal_Click()
'选择文件
On Error Resume Next
dlgOpen.CancelError = True
dlgOpen.DialogTitle = "选择数据库文件"
dlgOpen.Filter = "ACCESS(*.mdb)文件|Systemdata.mdb"
dlgOpen.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
dlgOpen.ShowOpen
If Err.Number = 32755 Then
'用户取消时
txtLocalPath.SetFocus
Exit Sub
Else
txtLocalPath.Text = dlgOpen.FileName
End If
End Sub
Private Sub cmdSave_Click()
'保存设置
On Error GoTo SaveRRR
Dim fIni As RegClass
Set fIni = New RegClass
Dim sTMp As String
Dim retVal As Boolean
If Right(App.Path, 1) = "\" Then
sTMp = App.Path & "Eatery.Exe"
Else
sTMp = App.Path & "\Eatery.Exe"
End If
'给出打印位置与更换当前位置
fIni.WriteINIString "System", "xLeft", ftLeft.Text, SystemConfigFile
fIni.WriteINIString "System", "xTop", ftTop.Text, SystemConfigFile
XLeft = CLng(ftLeft.Text): XTop = CLng(ftTop.Text)
fIni.WriteINIString "System", "xSmallLeft", ftSmallLeft.Text, SystemConfigFile
fIni.WriteINIString "System", "xSmallTop", ftSmallTop.Text, SystemConfigFile
xSmallLeft = CLng(ftSmallLeft.Text): xSmallTop = CLng(ftSmallTop.Text)
If chkAutorun.Value = vbChecked Then
'自动运行时
fIni.WriteINIString "System", "AutoRun", 1, SystemConfigFile
retVal = fIni.WriteRegStringValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run", "Eatery", sTMp)
IsAutorun = 1
Else
fIni.WriteINIString "System", "AutoRun", 0, SystemConfigFile
retVal = fIni.WriteRegStringValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run", "Eatery", "")
IsAutorun = 0
End If
'写入公司信息,公司名称只能再注册时修改。
fIni.WriteINIString "System", "Tel", Trim(ftTel.Text), SystemConfigFile
sCompanyTel = Trim(ftTel.Text)
fIni.WriteINIString "System", "Add", Trim(ftAddress.Text), SystemConfigFile
sCompanyAdd = Trim(ftAddress.Text)
fIni.WriteINIString "System", "CompanyName", Trim(ftCompany.Text), SystemConfigFile
sUnit = Trim(ftCompany.Text)
'显示消息"System", "Info", "欢迎光临〖VB中国大酒店〗", SystemConfigFile
fIni.WriteINIString "System", "Info", Trim(ftInfo.Text), SystemConfigFile
'写入SQL内容
fIni.WriteINIString "System", "SQLServer", Trim(ftSQL.Text), SystemConfigFile
fIni.WriteINIString "System", "SQLUser", Trim(ftUser.Text), SystemConfigFile
fIni.WriteINIString "System", "SQLpwd", Trim(ftPWD.Text), SystemConfigFile
If chkSQL.Value = vbChecked Then
'使用SQL数据库时
fIni.WriteINIString "System", "IsSQL", 1, SystemConfigFile
IsSqlDat = True
Else
'使用ACCESS数据库
fIni.WriteINIString "System", "IsSQL", 0, SystemConfigFile
IsSqlDat = False
End If
SQLServer = Trim(ftSQL.Text)
SQLUser = Trim(ftUser.Text)
SQLPWD = Trim(ftPWD.Text)
'=================================SQL赋值结束===================================================
sInfo = Trim(ftInfo.Text)
'检测数据库是否正确
If Trim(txtLocalPath.Text) <> "" Then
If Dir(txtLocalPath, vbArchive) = "" Then
'没有该文件时
MsgBox "Sorry，系统的数据库文件不正确？ " & vbCrLf _
& "请仔细检查一下,餐饮数据库是否正确。 ", vbInformation
txtLocalPath.SetFocus
Exit Sub
Else
'正确时
'保存数据库信息
fIni.WriteINIString "System", "AccessDatabase", Trim(txtLocalPath.Text), SystemConfigFile
AccessFile = Trim(txtLocalPath.Text)
Constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile & ";Mode=ReadWrite;Persist Security Info=False"
End If
End If
Set fIni = Nothing
MsgBox "重新启动本系统后，配置生效？ ", vbInformation
Unload Me
Exit Sub
SaveRRR:
MsgBox "何存设置错误：" & Err.Description, vbCritical
End Sub
Private Sub Form_Load()
GetFormSet Me, frmMain
OtherFocus = True
frmMain.lbControl = "其它参数配置"
'如果未注册时，不能使用SQL
If IsShare = True Then
chkSQL.Value = vbUnchecked
chkSQL.Enabled = False
End If
ftLeft.Text = XLeft: ftTop.Text = XTop
ftSmallLeft.Text = xSmallLeft: ftSmallTop.Text = xSmallTop
ftInfo = sInfo
'SQL数据库内容====================
ftSQL.Text = SQLServer
ftUser.Text = SQLUser
ftPWD.Text = SQLPWD
If IsSqlDat = True Then
chkSQL.Value = vbChecked
Else
chkSQL.Value = vbUnchecked
End If
txtLocalPath.Text = AccessFile
'试用版时，不能修改名称
ftCompany.Enabled = IsShare
ftCompany.Text = sUnit
'给出公司信息
ftTel.Text = sCompanyTel
ftAddress.Text = sCompanyAdd
ftCompany.Text = sUnit
If IsAutorun = 1 Then
chkAutorun.Value = vbChecked
Else
chkAutorun.Value = vbUnchecked
End If
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.WindowState = 1 Then Exit Sub
'常规时
If Me.WindowState = 0 Then
Me.Move 1, 1, frmMain.Width - (frmMain.picTool.Width + 200), frmMain.Height - (frmMain.picADV.Height + 1150)
End If
picCommand.Left = Me.ScaleWidth - picCommand.Width - 100
End Sub
Private Sub Form_Unload(Cancel As Integer)
OtherFocus = False
frmMain.lbControl = "收银控制中心"
'写数据库到Internet数据配置文件中
WriteToConfig
End Sub
Private Sub ftLeft_Change()
If ftLeft.Text = "" Then
ftLeft.Text = "0"
ftLeft.SelStart = 0
ftLeft.SelLength = 1
End If
End Sub
Private Sub ftLeft_LostFocus()
If ftLeft.Text = "" Then
ftLeft.Text = "0"
End If
End Sub
Private Sub ftTop_Change()
If ftTop.Text = "" Then
ftTop.Text = "0"
ftTop.SelStart = 0
ftTop.SelLength = 1
End If
End Sub
Private Sub ftTop_LostFocus()
If ftTop.Text = "" Then
ftTop.Text = "0"
End If
End Sub
Private Sub WriteToConfig()
On Error GoTo WriteERR
Dim lFile As Long
Dim sFileName As String
lFile = FreeFile()
sFileName = App.Path & "\datconfig.asp"
If Dir(sFileName, vbArchive) = "" Then
MsgBox "Internet配置文件不存在,不能更新。" & vbCrLf & "可能您使用的版本没有升级？", vbInformation
Exit Sub
End If
' Constring = "DRIVER=Microsoft Access Driver (*.mdb);User ID=;PWD=jms1404;DBQ=" & database
' Constring = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=mytel;Server=donghuaserver;Database=DHtel;Password=ok"
Open sFileName For Output As #lFile
Print #lFile, "<%" & Chr(13) & Chr(10)
If chkSQL.Value = vbChecked Then
'SQL服务器时
Print #lFile, "Constring =" & Chr(34) & "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=" & ftUser.Text & ";Server=" & ftSQL.Text & ";Database=Eatery;Password=" & ftPWD.Text & Chr(34) & Chr(13) & Chr(10)
Else
'使用Access数据库时
Print #lFile, "Constring =" & Chr(34) & "DRIVER=Microsoft Access Driver (*.mdb);User ID=;PWD=;DBQ=" & txtLocalPath.Text & Chr(34) & Chr(13) & Chr(10)
End If
Print #lFile, "CompanyName=" & Chr(34) & Trim(ftCompany.Text) & Chr(34) & Chr(13) & Chr(10)
If chkSQL.Value = vbChecked Then
'SQL时
Print #lFile, "IsSQLDat=1" & Chr(13) & Chr(10)
Else
Print #lFile, "IsSQLDat=0" & Chr(13) & Chr(10)
End If
Print #lFile, "%>" & Chr(13) & Chr(10)
Close #lFile
Exit Sub
WriteERR:
MsgBox "写数据入Datconfig.asp出错：" & Err.Description, vbExclamation
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -