您所在位置：主题：一个星期贴完自己写的药品进销存管理软件(源码)
牧子
[专家分：160] 发布于 2008-06-06 21:14:00
来本论坛也有几年了(不过我的积分少的可怜),有许多高手给过帮助!也给过许多意见
让我的知识长了许了,个人比较喜欢VB,简单,方便虽然现在使用VB.NET,C#工具但是对
VB还是情有独钟呀.本着人人为我,我为人人的精神现把我前几个月做的一个系统(药品
进销存)源码贴上 其中许多代码来自网上 大约需要十几贴,但是今天就发一贴
文件:
Module1.bas
Public ShowSm As Boolean'显示说明
Public SqlConStr As String'SQL连接字符
Public OperatorName As String'当前用户名
Public OperatorPower As String * 22 '当前用户权限 划分了22个权限
Public SysSetLog As String '本机设置
Public RkNoNum As Integer '单证号码
Public GridObject As Object 'Grid 对象
Public FormCaption As String '保存GRID所用名称,系统中有多个GRID
Public DataRedSet As New ADODB.Recordset
Public DataCon As New ADODB.Connection
Public FindSet As New ADODB.Recordset
Public SaveR As Integer '保存的行
Public GlName As String '多页面调用值
Public AddData As Boolean
Public CkName As String '仓库名
Public DnoStr As String '
Public Declare Function SetWindowPos Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long _
) As Long
Public Const HWND_TOPMOST = -1
Public Const SWP_SHOWWINDOW = &H40
Public Const HWND_NOTOPMOST = -2
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()
'/****************'读取INI文件
Public Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpFileName As String) As Long
'/****************
'/*************把窗体嵌入到PICTURE
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
'Private Sub Command1_Click()
' Form2.Visible = True
' SetParent Form2.hwnd, Form1.hwnd
' MoveWindow Form2.hwnd, 0, 0, 300, 300, 1 '通过该函数控制位置和大小
'End Sub
'/***************************
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &H111
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MOUSEWHEEL = &H20A
Public Oldwinproc As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Function FlexScroll(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'支持滚轮的滚动
Select Case wMsg
Case WM_MOUSEWHEEL
Select Case wParam
Case -7864320 '向下滚
'SendKeys "{PGDN}"
SendKeys "{down}"
SendKeys "{down}"
SendKeys "{down}"
Case 7864320 '向上滚
'SendKeys "{PGUP}"
SendKeys "{up}"
SendKeys "{up}"
SendKeys "{up}"
End Select
End Select
FlexScroll = CallWindowProc(Oldwinproc, hWnd, wMsg, wParam, lParam)
End Function
Public Function py(mystr As String) As String
i = Asc(mystr)
Select Case i
Case -20319 To -20284: py = "a"
Case -20283 To -19776: py = "b"
Case -19775 To -19219: py = "c"
Case -19218 To -18711: py = "d"
Case -18710 To -18527: py = "e"
Case -18526 To -18240: py = "f"
Case -18239 To -17923: py = "g"
Case -17922 To -17418: py = "h"
Case -17417 To -16475: py = "j"
Case -16474 To -16213: py = "k"
Case -16212 To -15641: py = "l"
Case -15640 To -15166: py = "m"
Case -15165 To -14923: py = "n"
Case -14922 To -14915: py = "o"
Case -14914 To -14631: py = "p"
Case -14630 To -14150: py = "q"
Case -14149 To -14091: py = "r"
Case -14090 To -13319: py = "s"
Case -13318 To -12839: py = "t"
Case -12838 To -12557: py = "w"
Case -12556 To -11848: py = "x"
Case -11847 To -11056: py = "y"
Case -11055 To -10247: py = "z"
Case Else: py = mystr
End Select
End Function
Public Function SetGridWith(GridObj As Object, SetStrName As String)
With GridObj
Select Case SetStrName
Case "进货登记"
.ColWidth(0) = 525
.ColWidth(1) = 2685
.ColWidth(2) = 1980
.ColWidth(3) = 905
.ColWidth(4) = 830
.ColWidth(5) = 3135
.ColWidth(6) = 1410
.ColWidth(7) = 1695
.ColWidth(8) = 780
.ColWidth(9) = 780
.ColWidth(10) = 780
.ColWidth(11) = 1845
.ColWidth(12) = 2475
.ColWidth(13) = 2175
.ColWidth(14) = 2775
Case Else
Dim i As Integer
For i = 1 To GridObj.Cols - 1
.ColWidth(i) = 1000
Next i
.ColWidth(0) = 600
End Select
'.RowHeight(1) = 360
'.RowHeight(0) = 360
'.RowHeightMin = 360
End With
End Function
Public Function GetGridWith(GridObj As Object, SetStrName As String, SaveR As Integer)
Dim GridWith(15) As Integer
Dim i As Integer
Dim pat As String
Dim str1 As String
For i = 0 To GridObj.Cols - 1
pat = Space$(100)
str1 = GridObj.TextMatrix(SaveR, i)
a = GetPrivateProfileString(SetStrName, str1, "", pat, 100, App.Path & "\sysini.ini")
GridWith(i) = Val(pat)
GridObj.ColWidth(i) = Val(pat)
Next i
End Function
Public Function SaveGridWith(GridObj As Object, SetStrName As String, SaveRow As Integer)
'MsgBox GridObj.Name
On Error Resume Next
Dim i As Integer
Dim str1 As String
For i = 0 To GridObj.Cols - 1
str1 = GridObj.TextMatrix(SaveRow, i)
a = WritePrivateProfileString(SetStrName, str1, GridObj.ColWidth(i), App.Path & "\sysini.INI")
Next i
MsgBox "设置保存成功"
End Function
Public Function SumGridMoney(GridObj As Object, Bar1 As Object)
Dim TsL, Tmoney As Double
TsL = 0
Tmoney = 0
Dim i As Integer
For i = 1 To GridObj.Rows - 1
TsL = TsL + Val(GridObj.TextMatrix(i, 8))
Tmoney = Tmoney + Val(GridObj.TextMatrix(i, 8)) * Val(GridObj.TextMatrix(i, 9))
Next i
Bar1.Panels(11) = "￥" & Format(Tmoney, "###,###,###.0#")
Bar1.Panels(9) = Format(TsL, "###,###,###.0#")
End Function
Public Function DeleteGrid(Grid1 As Object, Bar1 As Object)
If Grid1.Rows = 2 Then
For i = 1 To Grid1.Cols - 1
Grid1.TextMatrix(1, i) = ""
Next i
Else
Grid1.RemoveItem Grid1.Row
End If
SumGridMoney Grid1, Bar1
End Function
Public Function ToExcel(Grid1 As Object, FileName As String) '保存到EXCEL文件
Dim Ex As New Excel.Application
Ex.Workbooks.Add
Dim i, p, j As Integer
With Ex
.DisplayAlerts = False
.Sheets("Sheet2").Select
.ActiveWindow.SelectedSheets.Delete
'.Selection.EntireColumn.Delete
.Sheets("Sheet3").Select
.ActiveWindow.SelectedSheets.Delete
'.Selection.EntireColumn.Delete
.Sheets("Sheet1").Select
.Sheets("Sheet1").Name = FileName
For i = 0 To Grid1.Rows - 1
For j = 1 To Grid1.Cols - 1
.Cells(i + 1, j) = Grid1.TextMatrix(i, j)
Next j
Next i
.Columns("C:C").EntireColumn.AutoFit
.Columns("A:A").EntireColumn.AutoFit
.Columns("B:B").EntireColumn.AutoFit
.Columns("D:D").EntireColumn.AutoFit
.Columns("E:E").EntireColumn.AutoFit
.Columns("F:F").EntireColumn.AutoFit
.Columns("G:G").EntireColumn.AutoFit
.Columns("H:H").EntireColumn.AutoFit
.Columns("I:I").EntireColumn.AutoFit
.Columns("J:J").EntireColumn.AutoFit
.Columns("K:K").EntireColumn.AutoFit
.Columns("M:M").EntireColumn.AutoFit
.Columns("L:L").EntireColumn.AutoFit
.Columns("N:N").EntireColumn.AutoFit
.Columns("O:O").EntireColumn.AutoFit
.Columns("P:P").EntireColumn.AutoFit
.Columns("Q:Q").EntireColumn.AutoFit
End With
Ex.Visible = True
End Function
让我的知识长了许了,个人比较喜欢VB,简单,方便虽然现在使用VB.NET,C#工具但是对
VB还是情有独钟呀.本着人人为我,我为人人的精神现把我前几个月做的一个系统(药品
进销存)源码贴上 其中许多代码来自网上 大约需要十几贴,但是今天就发一贴
文件:
Module1.bas
Public ShowSm As Boolean'显示说明
Public SqlConStr As String'SQL连接字符
Public OperatorName As String'当前用户名
Public OperatorPower As String * 22 '当前用户权限 划分了22个权限
Public SysSetLog As String '本机设置
Public RkNoNum As Integer '单证号码
Public GridObject As Object 'Grid 对象
Public FormCaption As String '保存GRID所用名称,系统中有多个GRID
Public DataRedSet As New ADODB.Recordset
Public DataCon As New ADODB.Connection
Public FindSet As New ADODB.Recordset
Public SaveR As Integer '保存的行
Public GlName As String '多页面调用值
Public AddData As Boolean
Public CkName As String '仓库名
Public DnoStr As String '
Public Declare Function SetWindowPos Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long _
) As Long
Public Const HWND_TOPMOST = -1
Public Const SWP_SHOWWINDOW = &H40
Public Const HWND_NOTOPMOST = -2
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()
'/****************'读取INI文件
Public Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpFileName As String) As Long
'/****************
'/*************把窗体嵌入到PICTURE
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
'Private Sub Command1_Click()
' Form2.Visible = True
' SetParent Form2.hwnd, Form1.hwnd
' MoveWindow Form2.hwnd, 0, 0, 300, 300, 1 '通过该函数控制位置和大小
'End Sub
'/***************************
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &H111
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MOUSEWHEEL = &H20A
Public Oldwinproc As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Function FlexScroll(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'支持滚轮的滚动
Select Case wMsg
Case WM_MOUSEWHEEL
Select Case wParam
Case -7864320 '向下滚
'SendKeys "{PGDN}"
SendKeys "{down}"
SendKeys "{down}"
SendKeys "{down}"
Case 7864320 '向上滚
'SendKeys "{PGUP}"
SendKeys "{up}"
SendKeys "{up}"
SendKeys "{up}"
End Select
End Select
FlexScroll = CallWindowProc(Oldwinproc, hWnd, wMsg, wParam, lParam)
End Function
Public Function py(mystr As String) As String
i = Asc(mystr)
Select Case i
Case -20319 To -20284: py = "a"
Case -20283 To -19776: py = "b"
Case -19775 To -19219: py = "c"
Case -19218 To -18711: py = "d"
Case -18710 To -18527: py = "e"
Case -18526 To -18240: py = "f"
Case -18239 To -17923: py = "g"
Case -17922 To -17418: py = "h"
Case -17417 To -16475: py = "j"
Case -16474 To -16213: py = "k"
Case -16212 To -15641: py = "l"
Case -15640 To -15166: py = "m"
Case -15165 To -14923: py = "n"
Case -14922 To -14915: py = "o"
Case -14914 To -14631: py = "p"
Case -14630 To -14150: py = "q"
Case -14149 To -14091: py = "r"
Case -14090 To -13319: py = "s"
Case -13318 To -12839: py = "t"
Case -12838 To -12557: py = "w"
Case -12556 To -11848: py = "x"
Case -11847 To -11056: py = "y"
Case -11055 To -10247: py = "z"
Case Else: py = mystr
End Select
End Function
Public Function SetGridWith(GridObj As Object, SetStrName As String)
With GridObj
Select Case SetStrName
Case "进货登记"
.ColWidth(0) = 525
.ColWidth(1) = 2685
.ColWidth(2) = 1980
.ColWidth(3) = 905
.ColWidth(4) = 830
.ColWidth(5) = 3135
.ColWidth(6) = 1410
.ColWidth(7) = 1695
.ColWidth(8) = 780
.ColWidth(9) = 780
.ColWidth(10) = 780
.ColWidth(11) = 1845
.ColWidth(12) = 2475
.ColWidth(13) = 2175
.ColWidth(14) = 2775
Case Else
Dim i As Integer
For i = 1 To GridObj.Cols - 1
.ColWidth(i) = 1000
Next i
.ColWidth(0) = 600
End Select
'.RowHeight(1) = 360
'.RowHeight(0) = 360
'.RowHeightMin = 360
End With
End Function
Public Function GetGridWith(GridObj As Object, SetStrName As String, SaveR As Integer)
Dim GridWith(15) As Integer
Dim i As Integer
Dim pat As String
Dim str1 As String
For i = 0 To GridObj.Cols - 1
pat = Space$(100)
str1 = GridObj.TextMatrix(SaveR, i)
a = GetPrivateProfileString(SetStrName, str1, "", pat, 100, App.Path & "\sysini.ini")
GridWith(i) = Val(pat)
GridObj.ColWidth(i) = Val(pat)
Next i
End Function
Public Function SaveGridWith(GridObj As Object, SetStrName As String, SaveRow As Integer)
'MsgBox GridObj.Name
On Error Resume Next
Dim i As Integer
Dim str1 As String
For i = 0 To GridObj.Cols - 1
str1 = GridObj.TextMatrix(SaveRow, i)
a = WritePrivateProfileString(SetStrName, str1, GridObj.ColWidth(i), App.Path & "\sysini.INI")
Next i
MsgBox "设置保存成功"
End Function
Public Function SumGridMoney(GridObj As Object, Bar1 As Object)
Dim TsL, Tmoney As Double
TsL = 0
Tmoney = 0
Dim i As Integer
For i = 1 To GridObj.Rows - 1
TsL = TsL + Val(GridObj.TextMatrix(i, 8))
Tmoney = Tmoney + Val(GridObj.TextMatrix(i, 8)) * Val(GridObj.TextMatrix(i, 9))
Next i
Bar1.Panels(11) = "￥" & Format(Tmoney, "###,###,###.0#")
Bar1.Panels(9) = Format(TsL, "###,###,###.0#")
End Function
Public Function DeleteGrid(Grid1 As Object, Bar1 As Object)
If Grid1.Rows = 2 Then
For i = 1 To Grid1.Cols - 1
Grid1.TextMatrix(1, i) = ""
Next i
Else
Grid1.RemoveItem Grid1.Row
End If
SumGridMoney Grid1, Bar1
End Function
Public Function ToExcel(Grid1 As Object, FileName As String) '保存到EXCEL文件
Dim Ex As New Excel.Application
Ex.Workbooks.Add
Dim i, p, j As Integer
With Ex
.DisplayAlerts = False
.Sheets("Sheet2").Select
.ActiveWindow.SelectedSheets.Delete
'.Selection.EntireColumn.Delete
.Sheets("Sheet3").Select
.ActiveWindow.SelectedSheets.Delete
'.Selection.EntireColumn.Delete
.Sheets("Sheet1").Select
.Sheets("Sheet1").Name = FileName
For i = 0 To Grid1.Rows - 1
For j = 1 To Grid1.Cols - 1
.Cells(i + 1, j) = Grid1.TextMatrix(i, j)
Next j
Next i
.Columns("C:C").EntireColumn.AutoFit
.Columns("A:A").EntireColumn.AutoFit
.Columns("B:B").EntireColumn.AutoFit
.Columns("D:D").EntireColumn.AutoFit
.Columns("E:E").EntireColumn.AutoFit
.Columns("F:F").EntireColumn.AutoFit
.Columns("G:G").EntireColumn.AutoFit
.Columns("H:H").EntireColumn.AutoFit
.Columns("I:I").EntireColumn.AutoFit
.Columns("J:J").EntireColumn.AutoFit
.Columns("K:K").EntireColumn.AutoFit
.Columns("M:M").EntireColumn.AutoFit
.Columns("L:L").EntireColumn.AutoFit
.Columns("N:N").EntireColumn.AutoFit
.Columns("O:O").EntireColumn.AutoFit
.Columns("P:P").EntireColumn.AutoFit
.Columns("Q:Q").EntireColumn.AutoFit
End With
Ex.Visible = True
End Function
