📄 form1.frm
字号:
Picture = "Form1.frx":38F4
Style = 1 'Graphical
TabIndex = 1
Top = 1200
Width = 1575
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 495
Left = 0
TabIndex = 0
Top = 8805
Width = 13590
_ExtentX = 23971
_ExtentY = 873
SimpleText = "玩具 屯地干杯 还需要还需要于是村地"
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
Begin MSComctlLib.ImageList ImageList1
Left = 3960
Top = 8760
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 32
ImageHeight = 32
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 9
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":41BE
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":44D8
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":47F2
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":4B0C
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":4E26
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":5700
Key = ""
EndProperty
BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":5FDA
Key = ""
EndProperty
BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":68B4
Key = ""
EndProperty
BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":6C4E
Key = ""
EndProperty
EndProperty
End
Begin MSAdodcLib.Adodc Adodc1
Height = 375
Left = 120
Top = 6840
Visible = 0 'False
Width = 5400
_ExtentX = 9525
_ExtentY = 661
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 1
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 3
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = "DSN=slmis"
OLEDBString = ""
OLEDBFile = ""
DataSourceName = "slmis"
OtherAttributes = ""
UserName = "slmis"
Password = "dfwl111"
RecordSource = "select * from lkh"
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
Begin VB.Menu file
Caption = "系统管理(F)"
Index = 2
Begin VB.Menu xtsz
Caption = "系统设置"
End
End
Begin VB.Menu ends
Caption = "修改数据(E)"
Index = 3
Begin VB.Menu xtsj
Caption = "系统数据"
End
End
Begin VB.Menu tjsj
Caption = "统计设置"
Begin VB.Menu sjzz
Caption = "数据转置"
End
End
Begin VB.Menu sjcd
Caption = "数据传递"
Begin VB.Menu zh
Caption = "SQL到Excel"
End
Begin VB.Menu acc
Caption = "ACCESS到Excel"
End
End
Begin VB.Menu exit
Caption = "退出系统"
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public ex As New Workbook
Public exc As New Worksheet
Public e As New Application
'作者：kiki
'函数：Function ChangetoExcel(rst As ADODB.Recordset)
'功能：实现将一个记录集对象导出到EXCEL表。
'说明：函数需要1个参数，参数为ADODB.Recordset类型
'时间：2003.07.15
'********************************************************
Public Function ChangetoExcel(rst As adodb.Recordset)
Dim excel_app As Object
Dim excel_sheet As Object
'Dim rst As ADODB.Recordset
'Dim new_value As String
Dim rerows As Integer
Dim recols As Integer
rst.MoveFirst
Screen.MousePointer = vbHourglass
DoEvents
Set excel_app = CreateObject("Excel.Application")
excel_app.Visible = True
excel_app.Workbooks.Open FileName:=App.Path & "\misexcel.xls"
If Val(excel_app.Application.Version) >= 8 Then
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If
rerows = rst.RecordCount
recols = rst.Fields.Count
For i = 0 To rerows - 1
For j = 0 To recols - 1
excel_sheet.Cells(i + 1, j + 1) = rst.Fields(j)
Next
rst.MoveNext
Next
'excel_sheet.saveas App.Path & "\misexcel.xls"
'excel_app.ActiveWorkbook.Close False
'excel_app.Quit
Set excel_sheet = Nothing
Set excel_app = Nothing
Screen.MousePointer = vbDefault
'MsgBox "Copied " & Format$(rerows - 1) & " record."
End Function
'***************************************************
'问题：多次点击会打开多个EXCEL表
'***************************************************
Private Sub Command1_Click()
Adodc1.RecordSource = "select lkh.ch as 车号,lkh.mc as 客户 ,lkh.lxfs as 联系方式,lkh.jkfs as 结款方式,lkh.dz as 地址,sum(lcw.jsje) as 销售额 from lkh inner join lcw on lkh.mc=lcw.kh where lkh.ch like '%商超%' and lcw.lb='提货' and lcw.hsrq between '2007.10.01' and '2007.10.31' group by lkh.mc,lkh.lxfs,lkh.dz,lkh.jkfs,lkh.ch order by lkh.ch" 'charindex(','+lkh.ch+',''+ldhk.mc+',',1,2,0,')"
Adodc1.Refresh
If 1 = 0 Then
If Adodc1.Recordset.RecordCount > 0 Then
Adodc1.Recordset.MoveFirst
Do While Adodc1.Recordset.EOF = False
If Adodc1.Recordset.Fields("车号") = "01号车" Then
Text1.Text = Adodc1.Recordset.Fields("车号")
End If
Adodc1.Recordset.MoveNext
Loop
End If
End If
Set DataGrid1.DataSource = Adodc1
End Sub
Private Sub Command2_Click()
Adodc1.RecordSource = "select ldhk.kh,ldjk.dj,ldhkold.lsdhs From ldhkold Left Outer Join Custom On ldhkold.mc= ldjk.mc Left Outer Join lcpjh ON ldhkold.mc=lcpjh.mc Left Outer Join ldhk ON lcpjh.mc= ldhk.mc Where ldhkold.rq = '2007.08.01'"
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
End Sub
Private Sub Command3_Click()
Dim rq1 As String
Dim rq2 As String
rq1 = Format(DTPicker1.Value, "yyyy.mm.dd")
rq2 = Format(DTPicker2.Value, "yyyy.mm.dd")
Adodc1.RecordSource = "select lkh.ch as 车号 ,ldhk.mc as 品名,sum(ldhk.yds) as 预定数,sum(ldhk.lsdhs) as 临定数,sum(ldhk.tzs) as 增减数,sum(ldhk.xcs) as 宣传数,sum(ldhk.bfs) as 坏奶,sum(ldhk.yds+ldhk.lsdhs+ldhk.tzs+ldhk.xcs+ldhk.bfs) as 数量合计 from lkh inner join ldhk on lkh.mc=ldhk.kh and ldhk.rq between " + "'" + rq1 + "'" + " and " + "'" + rq2 + "'" + " group by lkh.ch,ldhk.mc order by lkh.ch" 'charindex(','+lkh.ch+',''+ldhk.mc+',',1,2,0,')"
Adodc1.Refresh
Set DataGrid1.DataSource = Form1.Adodc1
End Sub
Private Sub Command4_Click()
Dim i, j, k As Integer
Dim strConn As String
Dim xlapp As Variant
Dim xlBook As Variant
Dim xlSHEET As Variant
Set xlapp = CreateObject("excel.application")
Set xlBook = xlapp.Workbooks.Add
Set xlSHEET = xlBook.Worksheets(1)
xlapp.Visible = True
On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
Set xlBook = xlapp.Workbooks.Add
Set xlSHEET = xlBook.ActiveSheet
For k = 1 To DataGrid1.Columns.Count
xlSHEET.Cells(1, k) = DataGrid1.Columns(k - 1).Caption
Next k
For i = 1 To Adodc1.Recordset.RecordCount + 1
For j = 0 To DataGrid1.Columns.Count
xlSHEET.Cells(i + 1, j + 1) = Adodc1.Recordset(j) '
Next j
Adodc1.Recordset.MoveNext
Next i
End Sub
Private Sub Command5_Click()
Form4.Show
Unload Form1
End Sub
Private Sub Command6_Click()
Dim rq1 As String
Dim rq2 As String
rq1 = Format(DTPicker1.Value, "yyyy.mm.dd")
rq2 = Format(DTPicker2.Value, "yyyy.mm.dd")
Adodc1.RecordSource = "select kh as 客户,sum(qcje) as 期初金额,sum(jsje) as 减少金额,sum(zjje) as 增减金额,sum(jyje) as 结余金额 from lcw where sx='2' and hsrq between " + "'" + rq1 + "'" + " and " + "'" + rq2 + "'" + "group by kh order by kh"
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
End Sub
Private Sub Command7_Click()
Dim rq1 As String
Dim rq2 As String
Dim sjy As String
sjy = Str("2")
rq1 = Format(Form1.DTPicker1.Value, "yyyy.mm.dd")
rq2 = Format(Form1.DTPicker2.Value, "yyyy.mm.dd")
Adodc1.RecordSource = "select * from lcw where hsrq between " + "'" + rq1 + "'" + " and " + "'" + rq2 + "'" + "and" + " skdw='乌当财务部' "
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
End Sub
Private Sub Command8_Click()
Dim rq1 As String
Dim rq2 As String
rq1 = Format(DTPicker1.Value, "yyyy.mm.dd")
rq2 = Format(DTPicker2.Value, "yyyy.mm.dd")
'If 0 = 9 Then
Adodc4.RecordSource = "select ch as 车号 ,kh as 客户,mc as 品名,sum(yds) as 预定数,sum(lsdhs) as 临定数,sum(tzs) as 增减数,sum(yds+lsdhs+tzs) as 数量合计 from ldhk where rq between " + "'" + rq1 + "'" + " and " + "'" + rq2 + "'" + " group by mc,kh,ch order by ch,kh" 'charindex(','+lkh.ch+',''+ldhk.mc+',',1,2,0,')"
Adodc4.Refresh
Set DataGrid1.DataSource = Adodc4
'End If
End Sub
Private Sub DataGrid1_DblClick()
Dim i As String
sj = DataGrid1.Text
Form3.Show
End Sub
Private Sub Form_Load()
Skin1.LoadSkin App.Path + "\Skins\0.skn"
Skin1.ApplySkin Me.hWnd
DTPicker1.Value = Year(Date) & "-" & Month(Date) & "-" & "01"
DTPicker2.Value = Year(Date) & "-" & Month(Date) & "-" & Day(Date)
BSE1.SchemeStyle = 2
BSE1.EndSubClassing
BSE1.InitSubClassing
StatusBar1.Panels(1) = "刘加明"
End Sub
Sub xiaomin()
Dim o As Integer
Set ex = Application.Workbooks.Open(App.Path & "\" & "总单.ljm")
Set exc = ex.Sheets("总单")
exc.Visible = xlSheetVisible
'Wname = ThisWorkbook.Name
'Windows(Wname).Activate
'Windows("总单.xls").Activate
exc.Activate
If Adodc1.Recordset.RecordCount > 0 Then
Adodc1.Recordset.MoveFirst
Do While Adodc1.Recordset.EOF = False
For ii = 5 To 46
If Trim(Adodc1.Recordset.Fields("车号")) = Trim(exc.Cells(ii, 1).Value) Then
Text1.Text = Adodc1.Recordset.Fields("车号")
For iii = 2 To 46
If Trim(Adodc1.Recordset.Fields("品名")) = Trim(exc.Cells(2, iii).Value) Then
exc.Cells(ii, iii) = Trim(Adodc1.Recordset.Fields("数量合计"))
End If
Next iii
End If
Next ii
Adodc1.Recordset.MoveNext
Loop
End If
If 0 = 1 Then
For i = 1 To Adodc1.Recordset.RecordCount - 1
DataGrid1.Row = i
DataGrid1.Col = 0
For ii = 5 To 46
If DataGrid1.Text = exc.Cells(ii, 1) Then
For iii = 2 To 46
If DataGrid1.Text = exc.Cells(2, iii) Then
DataGrid1.Row = i
DataGrid1.Col = 7
exc.Cells(ii, iii) = DataGrid1.Text
End If
Next iii
End If
Next ii
Next i
End If
End Sub
Private Sub xtsj_Click()
Form4.Show
Unload Form1
End Sub
Private Sub xtsz_Click()
Form2.Show
End Sub
Sub xisom()
Dim i, j, k As Integer
Dim strConn As String
Dim pubConn As New adodb.Connection
Dim rsTable As New adodb.Recordset
Dim strSQL As String
Dim xlapp As Variant
Dim xlBook As Variant
Dim xlSHEET As Variant
Set xlapp = CreateObject("excel.application")
Set xlBook = xlapp.Workbooks.Add
Set xlSHEET = xlBook.Worksheets(1)
xlapp.Visible = True
On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
Set xlBook = xlapp.Workbooks.Add
Set xlSHEET = xlBook.ActiveSheet
For k = 1 To DataGrid1.Columns.Count
xlSHEET.Cells(1, k) = DataGrid1.Columns(k - 1).Caption
Next k
For i = 1 To Adodc1.Recordset.RecordCount + 1
For j = 0 To DataGrid1.Columns.Count
xlSHEET.Cells(i + 1, j + 1) = Adodc1.Recordset(j) '
Next j
Adodc1.Recordset.MoveNext
Next i
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -