百货/超市行业

开发平台：
Visual Basic

mdlMain.bas：源码内容
							Attribute VB_Name = "mdlMain"
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2008/01/21
'描    述：汽车维修管理系统SQL2000版
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：Mndsoft@163.com
'e-mail  ：Mndsoft@126.com
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
Option Explicit
'*********************************
'公司：辽宁正昊企业集团
'设计：孙新
'编码：孙新
'时间：2007-11-23
'*********************************
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 Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal lSize As Long, ByVal lpFilename As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFilename As String) As Long
Public g_Conn As New Connection     '用于全局的数据连接
Public g_CnStr As String            '用于全局的数据连接字符串
Public g_Admin As String            '当前用户名
Public g_DBname As String           '当前数据库名
Public g_ACCname As String          '当前帐套名
Public g_QX(15) As Boolean
Private Const gintMAX_SIZE% = 255   'Maximum buffer size
Public Const qMSG$ = "您无此权限，请管理员分配。"
'连接到数据库
Public Function ConnectToDatabase(ByVal ServerName As String, ByVal DBName As String, ByVal UserName As String, ByVal strPwd As String) As Boolean
  On Error GoTo ERR_CONN
  '连接到数据库
  With g_Conn
     .CursorLocation = adUseClient
     .CommandTimeout = 10
     
      ' 连接到SQL Server数据库
        g_CnStr = "Provider=SQLOLEDB.1;Persist Security Info=True;" & _
        "User ID=" & UserName & ";Data Source=" & ServerName & _
        ";pwd=" & strPwd & ";Initial Catalog=" & DBName
        .ConnectionString = g_CnStr
     .Open
  End With
  ConnectToDatabase = True
  Exit Function
  
ERR_CONN:
  ConnectToDatabase = False
  MsgBox Err.Description
  
End Function
Function IDnum(clas As String, tbn As String) As String
'*********************************************************
'* 名称：IDNUM
'* 功能：生成单据编号
'* 用法：IDNUM(类别,表名)
'*********************************************************
Dim pid As String
Dim Rs As ADODB.Recordset
Set Rs = g_Conn.Execute("SELECT IDN FROM " & tbn & " WHERE LEFT(IDN,13)='" & clas & Format(Now(), "yyyy-mm-dd") & "' ORDER BY IDN")
If Rs.RecordCount = 0 Then
    pid = clas & Format(Now(), "yyyy-mm-dd") & "-" & Format(1, "###000")
ElseIf Not Rs.EOF Then Rs.MoveLast
    If clas & Format(Now(), "yyyy-mm-dd") = Left(Rs("idn"), 13) Then
        pid = Left(Rs("IDN"), 13) & "-" & Format(Val(Right(Rs("idn"), 3)) + 1, "###000")
    ElseIf clas & Format(Now(), "yyyy-mm-dd") <> Left(Rs("idn"), 13) Then
        pid = clas & Format(Now(), "yyyy-mm-dd") & "-" & Format(1, "###000")
    End If
End If
Set Rs = Nothing
IDnum = pid
End Function
Public Function ConvertBTD(strBin As String) As String
  Dim tmpVal   As String
  Dim iCount   As Long
    For iCount = 1 To Len(strBin)
            tmpVal = Val(tmpVal) + Val(Mid$(strBin, iCount, 1)) * (2 ^ (Len(strBin) - iCount))
    Next iCount
ConvertBTD = tmpVal
End Function
Public Function ConvertDTB(strBin As String) As String
  Dim tmpVal   As String
  Dim iCount   As Long
  iCount = Val(strBin)
    While (iCount <> 0)
        tmpVal = iCount Mod 2 & tmpVal
        iCount = (iCount - iCount Mod 2) / 2
    Wend
    ConvertDTB = tmpVal
End Function
Public Function ReadIniFile(ByVal strIniFile As String, ByVal strSection As String, ByVal strKey As String, Optional ByVal strKeyDefault As String = vbNullString) As String
    Dim strBuffer As String
    strBuffer = Space$(gintMAX_SIZE)
    If GetPrivateProfileString(strSection, strKey, strKeyDefault, strBuffer, gintMAX_SIZE, strIniFile) Then
       ReadIniFile = StringFromBuffer(strBuffer)
    End If
End Function
Private Function StringFromBuffer(Buffer As String) As String
    Dim nPos As Long
    nPos = InStr(Buffer, vbNullChar)
    If nPos > 0 Then
        StringFromBuffer = Left$(Buffer, nPos - 1)
    Else
        StringFromBuffer = Buffer
    End If
End Function
Sub LoadResStrings(frm As Form)
  On Error Resume Next
  Dim ctl As Control
  Dim obj As Object
  Dim fnt As Object
  Dim sCtlType As String
  Dim nVal As Integer
  '设置窗体的 caption 属性
  frm.Caption = LoadResString(CInt(frm.Tag))
  
  '设置字体
  Set fnt = frm.Font
  fnt.Name = LoadResString(20)
  fnt.Size = CInt(LoadResString(21))
  
  '设置控件的标题，对菜单项使用 caption 属性并对所有其他控件使用 Tag 属性
  For Each ctl In frm.Controls
    Set ctl.Font = fnt
    sCtlType = TypeName(ctl)
    If sCtlType = "Label" Then
      ctl.Caption = LoadResString(CInt(ctl.Tag))
    ElseIf sCtlType = "Menu" Then
      ctl.Caption = LoadResString(CInt(ctl.Caption))
    ElseIf sCtlType = "TabStrip" Then
      For Each obj In ctl.Tabs
        obj.Caption = LoadResString(CInt(obj.Tag))
        obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
      Next
    ElseIf sCtlType = "Toolbar" Then
      For Each obj In ctl.Buttons
        obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
      Next
    ElseIf sCtlType = "ListView" Then
      For Each obj In ctl.ColumnHeaders
        obj.Text = LoadResString(CInt(obj.Tag))
      Next
    Else
      nVal = 0
      nVal = Val(ctl.Tag)
      If nVal > 0 Then ctl.Caption = LoadResString(nVal)
      nVal = 0
      nVal = Val(ctl.ToolTipText)
      If nVal > 0 Then ctl.ToolTipText = LoadResString(nVal)
    End If
  Next
End Sub
'替换字符串中的单引号
Public Function RealString(strOrigional) As String
  RealString = Replace(strOrigional, "'", "''")
End Function
Public Function PassIsTrue(ByVal strUname As String, ByVal strPass As String, Optional ByVal strTable As String = "Users") As Boolean
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("SELECT COUNT(*) FROM " & strTable & " Where UserName='" & strUname & "' and Upass='" & strPass & "'")
  PassIsTrue = (Rs(0).Value = 1)
  Set Rs = Nothing
End Function
Public Function IsSys(strUser As String) As Boolean
  Dim Rs As New ADODB.Recordset
  Set Rs = g_Conn.Execute("select issys from users where username='" & strUser & "'")
  IsSys = Rs(0).Value
  Set Rs = Nothing
End Function
'保存最后登陆的用户
Public Function LetUser(ByVal strUser As String, Optional ByVal strTable As String = "Users")
  '参数是表的名称
   g_Conn.Execute ("Update " & strTable & " SET LastLogin = '" & Now() & "' Where UserName='" & strUser & "'")
  
End Function
'得到某个数据表中主键的下一个值，即当前主键值加1
Public Function NextID(ByVal strTable As String, ByVal strID As String) As Long
  '两个参数分别是表的名称与主键的名称
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("SELECT MAX(" & strID & ") FROM " & strTable & "")
  
  If IsNull(Rs(0)) Then
    '如果值为NULL，则说明无任何数据记录，此时ID应为1
    NextID = 1
  Else
    '使新ID为最大ID值+1
    NextID = Rs(0).Value + 1
  End If
  Set Rs = Nothing
End Function
'得到某个数据表中主键的最大值
Public Function MaxID(ByVal strTable As String, ByVal strID As String) As Long
  '两个参数分别是表的名称与主键的名称
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("SELECT MAX(" & strID & ") FROM " & strTable)
  
  If IsNull(Rs(0)) Then
    '如果值为NULL，则说明无任何数据记录，此时ID应为1
    MaxID = 0
  Else
    '使新ID为最大ID值+1
    MaxID = Rs(0).Value
  End If
  Set Rs = Nothing
End Function
'查看某个数据表中，是否存在某个字段等于某个值的记录（整型）
Public Function ExistByID(ByVal strTable As String, ByVal strID As String, _
                          ByVal lngID As Long) As Boolean
  '第一个参数为表名，第二个为字段名，第三个为具体的字段值
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("Select Count(*) from " & strTable & _
                          " where " & strID & "=" & lngID)
  ExistByID = (Rs(0).Value >= 1)
  Set Rs = Nothing
End Function
'查看某个数据表中，是否存在某个字段等于某个值的记录（整型）
Public Function ExistByValueID(ByVal strTable As String, ByVal strID As String, _
                          ByVal strIDv As Long, ByVal strValue As String, _
                          ByVal strValuev As String) As Boolean
  '第一个参数为表名，第二个为字段名，第三个为具体的字段值
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("Select Count(*) from " & strTable & _
                          " where " & strID & "<>" & strIDv & " and " & strValue & "='" & strValuev & "'")
  ExistByValueID = (Rs(0).Value >= 1)
  Set Rs = Nothing
End Function
'查看某个数据表中，是否存在某个字段等于某个值的记录（字符型）
Public Function ExistByName(ByVal strTable As String, ByVal strFieldName As String, ByVal strName As String) As Boolean
  '第一个参数为表名，第二个为字段名，第三个为具体的字段值
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("Select Count(*) from " & strTable & " where " & strFieldName & "='" & strName & "'")
  ExistByName = (Rs(0).Value >= 1)
  Set Rs = Nothing
End Function
'以上两个函数实际上可以合并，本程序中为了说明问题，故而分开
'根据给定的主键值，获取某一指定的字段值
Public Function GetValueByID(ByVal strTable As String, ByVal strID As String, _
                  ByVal lngID As Long, ByVal strValueField As String) As String
  '第一个参数为表名，第二个为主键字段名，第三个为主键字段值，第四个为要获取值的字段名
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("Select " & strValueField & " from " & strTable & _
                          " where " & strID & "=" & lngID)
  If Rs.RecordCount = 1 Then
    GetValueByID = Rs(0).Value
  Else
    GetValueByID = ""
  End If
  Set Rs = Nothing
End Function
'根据给定的主键值，获取某一指定的字段值
Public Function GetIDByValue(ByVal strTable As String, ByVal strValue As String, _
                  ByVal strIDField As Long, ByVal strValueField As String) As String
  '第一个参数为表名，第二个为主键字段名，第三个为主键字段值，第四个为要获取值的字段名
  Dim Rs As Recordset
  Set Rs = g_Conn.Execute("Select " & strIDField & " from " & strTable & _
                          " where " & strValueField & "=" & strValue)
  If Rs.RecordCount = 1 Then
    GetIDByValue = Rs(0).Value
  Else
    GetIDByValue = ""
  End If
  Set Rs = Nothing
End Function
'//
'// 执行一条无返回结果的 SQL 语句
'//
Public Function RunSql(strSQL As String, ByRef strErrMsg As String) As Boolean
  
  On Error Resume Next
  
  g_Conn.Execute strSQL '执行SQL语句
  
  '根据是否出错，返回给调用者相应的信息
  If Err.Number = 0 Then
    RunSql = True
  Else
    strErrMsg = Err.Description
    RunSql = False
  End If
End Function
'//
'// 执行一条有返回结果的 SQL 语句
'//
Public Function GetRecordset(strSQL As String, ByRef strErrMsg As String, ByRef Rs As Recordset) As Boolean
  
  On Error Resume Next
  
  Set Rs = g_Conn.Execute(strSQL) '执行SQL语句
  
  '根据是否出错，返回给调用者相应的信息
  If Err.Number = 0 Then
    GetRecordset = True
  Else
    strErrMsg = Err.Description
    GetRecordset = False
  End If
End Function
Public Function GetID(strKey As String) As Long
  GetID = Val(Right(strKey, Len(strKey) - 1))
End Function
Public Function ListViewToExcel(ByRef lvw As MSComctlLib.ListView) As Boolean
    Dim i, iCols, iRows         As Integer
    Dim itm                     As ListItem
    Dim objExcel                As Excel.Application
    Dim objWorkbook             As Excel.Workbook
    Dim objWorksheet            As Excel.Worksheet
    
    If lvw.SelectedItem Is Nothing Then MsgBox "表格没有任何资料。", vbOKOnly + vbInformation, "导出失败": Exit Function
    Screen.MousePointer = vbHourglass
    
    
    On Error Resume Next
    Set objExcel = New Excel.Application
          
    If Err.Number > 0 Then MsgBox "本机未安装 Excel 。", vbOKOnly + vbCritical, "加载 Excel 失败": Exit Function
    
    Set objWorkbook = objExcel.Workbooks.Add
    Set objWorksheet = objWorkbook.Sheets(1)
    
    objWorksheet.Rows(1).Font.Bold = True
    objWorksheet.Cells.Font.Size = 9
    For i = 1 To lvw.ColumnHeaders.Count
        objWorksheet.Cells(1, i) = lvw.ColumnHeaders(i).Text
    Next i
    
    iCols = i - 1
    iRows = 1
    For Each itm In lvw.ListItems
        iRows = iRows + 1
        For i = 1 To iCols
            If i = 1 Then
                objWorksheet.Cells(iRows, 1) = itm.Text
            Else
                objWorksheet.Cells(iRows, i) = itm.SubItems(i - 1)
            End If
        Next i
    Next itm
    
    objWorksheet.Columns.AutoFit
    objExcel.Application.Visible = True
    
    
    Set objWorksheet = Nothing
    Set objWorkbook = Nothing
    Set objExcel = Nothing
    Screen.MousePointer = vbDefault
    
End Function

						