📄 frmcompany.frm
字号:
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmcompany.frx":4D6C
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmcompany.frx":53E8
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmcompany.frx":5A64
Key = ""
EndProperty
BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmcompany.frx":5CF8
Key = ""
EndProperty
EndProperty
End
End
Begin MSComctlLib.StatusBar status
Align = 2 'Align Bottom
Height = 255
Left = 0
TabIndex = 13
Top = 5475
Width = 8325
_ExtentX = 14684
_ExtentY = 450
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
End
Attribute VB_Name = "frmcompany"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim rsC As New Recordset
Public InsertType As String
Private Sub CmdInsert_Click()
If frmcompany.InsertType = "buyFind" Then
If Frm_BuyFind.cmdcomp Then
Frm_BuyFind.txtcomp = txtcompname
Frm_BuyFind.txtcomp1 = txtcompname
Unload Me
Else
Frm_BuyFind.txtcomp1 = txtcompname
Unload Me
End If
End If
If frmcompany.InsertType = "FRMIOorder" Then
frmioorder.lblcompid = txtid
Compid = txtid
frmioorder.txtcompname = txtcompname
Unload Me
ElseIf frmcompany.InsertType <> "Frmbuy" Then
If frmIFind.cmdcomp Then
frmIFind.txtcomp = txtcompname
frmIFind.txtcomp1 = txtcompname
Unload Me
Else
frmIFind.txtcomp1 = txtcompname
Unload Me
End If
End If
If frmcompany.InsertType = "Frmbuy" Then
Frmbuy.txtCustomId = txtid.Text
Frmbuy.txtCustomName = txtcompname.Text
Unload Me
End If
End Sub
Private Sub Command1_Click()
On Error GoTo gl
Dim txtfilename As String
dlg.InitDir = App.Path & "\data"
dlg.ShowOpen
txtfilename = dlg.Filename
If txtfilename <> "" Then
Screen.MousePointer = 11
Call xlstomdb(txtfilename, rsC)
Screen.MousePointer = vbDefault
dlg.Filename = ""
rsC.Filter = ""
rsC.Requery
MsgBox " 数据导入成功！ ", , ginfo
'Set dtgrd.DataSource = rsC
dtgrd.Refresh
End If
Screen.MousePointer = vbDefault
Exit Sub
gl: MsgBox err.Description
Screen.MousePointer = vbDefault
End Sub
Private Sub xlstomdb(Filename As String, adogrd As ADODB.Recordset)
On Error GoTo errl
Dim excel_app As Object
Dim excel_sheet As Object
Dim row As Integer
Dim strcol(5) As String
Screen.MousePointer = vbHourglass
DoEvents
' Create the Excel application.
Set excel_app = CreateObject("Excel.Application")
excel_app.Workbooks.Open Filename:=Filename
' Check for later versions.
If Val(excel_app.Application.Version) >= 8 Then
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If
Dim iLine As Integer
iLine = 1: row = 2
Do
For iLine = 1 To 4
strcol(iLine - 1) = Trim$(excel_sheet.Cells(row, iLine))
If Len(strcol(iLine - 1)) = 0 Then Exit For
If iLine = 5 Then Exit For
Next iLine
If Len(strcol(0)) = 0 Or Len(strcol(1)) = 0 Then
Exit Sub
End If
adogrd.Filter = "compname='" & Trim(strcol(0)) & "' or comptel = '" & Trim(strcol(1)) & "'"
If adogrd.EOF Or adogrd.BOF Then
adogrd.Filter = ""
If adogrd.RecordCount > 0 Then
Idadd = adogrd.RecordCount
Else
Idadd = 0
End If
adogrd.AddNew
adogrd.Fields!ID = Idadd + 1
adogrd.Fields!compname = strcol(0)
adogrd.Fields!comptel = strcol(2)
adogrd.Fields!compman = CStr(strcol(1))
adogrd.Fields!commemo = strcol(4)
'adogrd.UpdateBatch adAffectCurrent
Else
adogrd.Fields!compname = strcol(0)
adogrd.Fields!comptel = strcol(2)
adogrd.Fields!compman = strcol(1)
adogrd.Fields!commemo = strcol(3)
End If
adogrd.UpdateBatch adAffectCurrent
row = row + 1
Loop
excel_app.ActiveWorkbook.Close False
' Close Excel.
excel_app.Quit
Set excel_sheet = Nothing
Set excel_app = Nothing
adogrd.Close
Set adogrd = Nothing
Screen.MousePointer = vbDefault
adogrd.Filter = ""
Exit Sub
errl: MsgBox err.Description
End Sub
Private Sub dtgrd_Click()
txtid = dtgrd.Columns(0).Text
Toolbar1.Buttons(6).Enabled = True
End Sub
Private Sub dtgrd_DblClick()
CmdInsert_Click
End Sub
Private Sub dtgrd_RowColChange(LastRow As Variant, ByVal LastCol As Integer)
If Not (rsC.EOF Or rsC.BOF) Then
dtgrd_Click
End If
End Sub
Private Sub Form_Load()
If rsC.State = 1 Then
rsC.Close
End If
rsC.Open "select * from companydepart", cn, adOpenKeyset, adLockBatchOptimistic
rsC.Requery
Set dtgrd.DataSource = rsC
Toolbar1.Buttons(2).Enabled = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
rsC.Close
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim Re As String
Dim cmd As New ADODB.Command
Dim Idadd As Integer
Select Case Trim(Button.Key)
Case "new"
frminfo.Enabled = True
txtcompname = ""
txtcompman = ""
txtcomptel = ""
Toolbar1.Buttons(3).Enabled = False
Toolbar1.Buttons(6).Enabled = False
Toolbar1.Buttons(2).Enabled = True
Toolbar1.Buttons(1).Enabled = False
Idadd = rsC.RecordCount
txtcompman.SetFocus
Case "save"
If Toolbar1.Buttons(1).Enabled = False Then
Re = DataCheck
If Re = "OK" Then
rsC.Find "compname='" & txtcompname & "'"
If Not (rsC.BOF Or rsC.EOF) Then
MsgBox " 该公司已经存在！ ", , ginfo
Exit Sub
End If
Idadd = rsC.RecordCount
rsC.AddNew
rsC!ID = Idadd + 1
txtid = rsC!ID
rsC!compman = Trim(txtcompman)
rsC!compname = Trim(txtcompname)
rsC!comptel = Trim(txtcomptel)
rsC!commemo = Trim(txtmemo)
rsC.UpdateBatch adAffectCurrent
' Toolbar1.Buttons(3).Enabled = True
Toolbar1.Buttons(2).Enabled = False
Toolbar1.Buttons(6).Enabled = True
Toolbar1.Buttons(1).Enabled = True
rsC.Requery
rsC.Find "compname='" & txtcompname & "' "
Else
MsgBox Re, , ginfo
End If
Toolbar1.Buttons(3).Enabled = True
Else
If txtcompname <> "" Then
rsC.Filter = "compname='" & txtcompname & "' And ID <> " & txtid & " "
If Not (rsC.BOF Or rsC.EOF) Then
MsgBox " 该公司已经存在! ", , ginfo
Exit Sub
End If
Else
MsgBox " 请输入产品名称！ ", , ginfo
Exit Sub
End If
rsC.Close
Set rsC = Nothing
Form_Load
rsC.Find "id=" & txtid
rsC!compman = Trim(txtcompman)
rsC!compname = Trim(txtcompname)
rsC!comptel = Trim(txtcomptel)
rsC!commemo = Trim(txtmemo)
rsC.UpdateBatch adAffectCurrent
Toolbar1.Buttons(3).Enabled = True
Toolbar1.Buttons(2).Enabled = False
Toolbar1.Buttons(6).Enabled = True
Toolbar1.Buttons(1).Enabled = True
End If
Case "dele"
On Error GoTo l
Re = MsgBox(" 你确定要删除数据吗？", vbYesNo + vbQuestion, ginfo)
If Re = vbYes Then
rsC.Find "id=" & Val(txtid)
If txtid = "" Then
dtgrd.Refresh
txtid = dtgrd.Columns(0).Text
End If
cmd.ActiveConnection = cn
cmd.CommandText = "delete * from companydepart where id=" & txtid
cmd.Execute
rsC.MoveNext
If Not (rsC.EOF Or rsC.BOF) Then
Do While Not rsC.EOF
If CInt(txtid) <= rsC!ID Then
rsC!ID = rsC!ID - 1
rsC.UpdateBatch adAffectCurrent
rsC.MoveNext
Else
Exit Do
End If
Loop
End If
rsC.Requery
Toolbar1.Buttons(3).Enabled = True
Else
Exit Sub
End If
Exit Sub
l: MsgBox err.Description
Case "find"
Re = InputBox("请输入公司名称：", "查找信息", Default, 2500, 2500)
If Re <> "" Then
rsC.Filter = "compname='" & Re & "'"
If rsC.BOF Or rsC.EOF Then
MsgBox " 对不起，没找到该记录！", , ginfo
Set rsC = Nothing
Form_Load
Exit Sub
End If
End If
Case "edit"
frminfo.Enabled = True
txtcompman.SetFocus
Toolbar1.Buttons(6).Enabled = False
Toolbar1.Buttons(2).Enabled = True
Toolbar1.Buttons(1).Enabled = True
Case "exit"
Unload Me
End Select
End Sub
Private Function DataCheck() As String
If txtcompname = "" Or txtcompman = "" Then
DataCheck = " 数据输入不完整，请检查！ "
Exit Function
End If
DataCheck = "OK"
End Function
Private Sub txtid_Change()
If Toolbar1.Buttons(1).Enabled <> False Then
If txtid <> "" Then
rsC.Find "id=" & txtid
If Not (rsC.BOF Or rsC.EOF) Then
txtcompname = rsC!compname
If rsC!compman <> "" Then txtcompman = rsC!compman
If rsC!comptel <> "" Then txtcomptel = rsC!comptel
End If
End If
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -