以前写的一个VB仓存管理系统（二）

这是模块部分，主要定义了一些public的变量和函数，先发上源码：

 

 

Public username As String, quanxian As String, connstr As String
Public conn As ADODB.Connection, conn0 As ADODB.Connection, rs As ADODB.Recordset, rs0 As ADODB.Recordset
Public inputdata(19) As String
Public fromform As String, myreturn As String, bianma As String
Public myctrl As Boolean

Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) 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 SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
Public Declare Function GetTickCount Lib "kernel32" () As Long
'********************************************************************************************

Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long
Const CB_SETDROPPEDWIDTH = &H160

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 Const GWL_WNDPROC = (-4)
Public Const WM_MOUSEWHEEL = &H20A

Public lpWndProc As Long

Public Sub Hook(hwnd As Long)
    lpWndProc = GetWindowLong(hwnd, GWL_WNDPROC) '获得原始窗口函数句柄
    SetWindowLong hwnd, GWL_WNDPROC, AddressOf WindowProc '装载WM_MOUSEWHEEL消息的处理过程到窗口函数
End Sub
Public Sub SetComboWidth(oComboBox As ComboBox, lWidth As Long)
'lWidth 是宽度，单位是 pixels
SendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0
End Sub

Public Sub UnHook(hwnd As Long)

    SetWindowLong hwnd, GWL_WNDPROC, lpWndProc '御掉Hook，还原原始窗口函数

End Sub

Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '处理WM_MOUSEWHEEL消息的窗口函数

    If uMsg = WM_MOUSEWHEEL Then
        Dim wzDelta As Integer
        wzDelta = HIWORD(wParam)

        If Sgn(wzDelta) = 1 Then
            If TypeOf Screen.ActiveControl Is DataGrid Then Screen.ActiveControl.Scroll 0, -1
        Else
            If TypeOf Screen.ActiveControl Is DataGrid Then Screen.ActiveControl.Scroll 0, 1
        End If

    End If

    WindowProc = CallWindowProc(lpWndProc, hwnd, uMsg, wParam, lParam)

End Function

Public Function HIWORD(MsgParam As Long) As Integer
    '取出32位值的高16位
    HIWORD = (MsgParam And &HFFFF0000) / &H10000
End Function

 

'以上是一些公用变量和窗口美化的API，涉及的东西太多，暂不讲解。

'********************************************************************************************

Public Sub Cipher(ByVal password As String, ByVal from_text As String, to_text As String)
    Const MIN_ASC = 32  ' Space.
    Const MAX_ASC = 126 ' ~.
    Const NUM_ASC = MAX_ASC - MIN_ASC + 1

    Dim offset As Long
    Dim str_len As Integer
    Dim i As Integer
    Dim ch As Integer

    ' Initialize the random number generator.
    offset = NumericPassword(password)
    Rnd -1
    Randomize offset

    ' Encipher the string.
    str_len = Len(from_text)
    For i = 1 To str_len
        ch = Asc(Mid$(from_text, i, 1))
        If ch >= MIN_ASC And ch <= MAX_ASC Then
            ch = ch - MIN_ASC
            offset = Int((NUM_ASC + 1) * Rnd)
            ch = ((ch + offset) Mod NUM_ASC)
            ch = ch + MIN_ASC
            to_text = to_text & Chr$(ch)
        End If
    Next i
End Sub
' Encipher the text using the pasword.
Public Sub Decipher(ByVal password As String, ByVal from_text As String, to_text As String)
    Const MIN_ASC = 32  ' Space.
    Const MAX_ASC = 126 ' ~.
    Const NUM_ASC = MAX_ASC - MIN_ASC + 1

    Dim offset As Long
    Dim str_len As Integer
    Dim i As Integer
    Dim ch As Integer

    ' Initialize the random number generator.
    offset = NumericPassword(password)
    Rnd -1
    Randomize offset

    ' Encipher the string.
    str_len = Len(from_text)
    For i = 1 To str_len
        ch = Asc(Mid$(from_text, i, 1))
        If ch >= MIN_ASC And ch <= MAX_ASC Then
            ch = ch - MIN_ASC
            offset = Int((NUM_ASC + 1) * Rnd)
            ch = ((ch - offset) Mod NUM_ASC)
            If ch < 0 Then ch = ch + NUM_ASC
            ch = ch + MIN_ASC
            to_text = to_text & Chr$(ch)
        End If
    Next i
End Sub

' Translate a password into an offset value.
Public Function NumericPassword(ByVal password As String) As Long
    Dim Value As Long
    Dim ch As Long
    Dim shift1 As Long
    Dim shift2 As Long
    Dim i As Integer
    Dim str_len As Integer

    str_len = Len(password)
    For i = 1 To str_len
        ' Add the next letter.
        ch = Asc(Mid$(password, i, 1))
        Value = Value Xor (ch * 2 ^ shift1)
        Value = Value Xor (ch * 2 ^ shift2)

        ' Change the shift offsets.
        shift1 = (shift1 + 7) Mod 19
        shift2 = (shift2 + 13) Mod 23
    Next i
    NumericPassword = Value
End Function

Public Function myopen()
    Set conn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    conn.ConnectionString = connstr
    conn.ConnectionTimeout = 30
    conn.Open
End Function

Public Function myclose()
   On Error Resume Next
    rs.Close
    Set rs = Nothing
    conn.Close
    Set conn = Nothing
End Function

 

 

'以上是把用户的ID和密码加密存放到配置文件和数据库（读取时解密）用到的几个函数。

'以下是几个打开配置文件、连接数据库和输入判断常用到的函数。
Public Function myopen0()
    Set conn0 = New ADODB.Connection
    Set rs0 = New ADODB.Recordset
    conn0.ConnectionString = connstr
    conn0.ConnectionTimeout = 30
    conn0.Open
End Function

Public Function myclose0()
   On Error Resume Next

    rs0.Close
    Set rs0 = Nothing
    conn0.Close
    Set conn0 = Nothing
End Function

Public Function openmyini(rorw As String)

    On Error GoTo myrong

    If rorw = "read" Then
        Open IIf(Right(App.Path, 1) <> "/", App.Path + "/", App.Path) + "/backup/sysset.alin" For Input As #499

        For i = 0 To 19  '读取程序配置
            Line Input #499, inputdata(i)
        Next i

        Close #499
    Else
        If rorw = "write" Then
            Open IIf(Right(App.Path, 1) <> "/", App.Path + "/", App.Path) + "/backup/sysset.alin" For Output As #499

            For i = 0 To 19  '写入配置
                Print #499, inputdata(i)
            Next i

            Close #499
        End If
    End If

myrong:                     '错误处理
    If Err.Number <> 0 Then
        Call mymsgbox("读取配置文件错误，错误号：" & Str(Err.Number), "错误描述：" & Err.Description, "yes", "e")
        Err.Clear
    End If

End Function

Public Function isshuzi(shuzi As String) As Boolean'用正则表达式来判断输入是否为数字
    Dim myreg As New RegExp
    myreg.IgnoreCase = True
    myreg.Global = True
    myreg.MultiLine = True
    myreg.Pattern = "^[0-9]+/.{0,1}[0-9]{0,4}$"
    isshuzi = myreg.Test(shuzi)
End Function
Public Function shuzizimu(mystr As String) As Boolean'判断输入是否为数字和字母
    Dim myreg1 As New RegExp
    myreg1.IgnoreCase = True
    myreg1.Global = True
    myreg1.MultiLine = True
    myreg1.Pattern = "^[A-Za-z0-9]+$"
    shuzizimu = myreg1.Test(mystr)
End Function

 

 

 

'觉得VB自带的msgbox太丑，自己定义了一个。
Public Function mymsgbox(str1 As String, str2 As String, mybutton As String, myicon As String) As Boolean

    Select Case myicon
      Case "i"
        Form6.Image2.Picture = LoadPicture(App.Path + "/picture/信息.gif")
      Case "c"
        Form6.Image2.Picture = LoadPicture(App.Path + "/picture/警告.gif")
      Case "e"
        Form6.Image2.Picture = LoadPicture(App.Path + "/picture/错误.gif")
      Case Else
        Form6.Image2.Picture = LoadPicture(App.Path + "/picture/询问.gif")
    End Select

    Form6.Label1.Caption = str1
    Form6.Label2.Caption = str2

    If IIf(Form6.Label1.Width > Form6.Label2.Width, Form6.Label1.Width + 300, Form6.Label2.Width + 300) > 5190 Then
        Form6.Width = IIf(Form6.Label1.Width > Form6.Label2.Width, Form6.Label1.Width + 300, Form6.Label2.Width + 300)
        Form6.Image1.Width = Form6.Width
        If Form6.Width > 15200 Then
            Form6.Width = 15200

            If Form6.Label1.Width > 15200 Then
                Form6.Label1.Width = 14400
                Form6.Label1.WordWrap = True
            End If

            If Form6.Label2.Width > 15200 Then
                Form6.Label2.Width = 14400
                Form6.Label2.WordWrap = True
            End If
        End If

    End If
    If str2 = "" Then Form6.Label1.Top = Form6.Label1.Top + 198
    Form6.Label1.Left = (Form6.Width - Form6.Label1.Width) / 2 + 118
    Form6.Label2.Left = (Form6.Width - Form6.Label2.Width) / 2 + 118

    Select Case mybutton
      Case "yes"
        Form6.dcButton1.Visible = True
        Form6.dcButton1.Left = (Form6.Width - Form6.dcButton1.Width) / 2
      Case "yesback"
        Form6.dcButton1.Visible = True
        Form6.dcButton3.Visible = True
        Form6.dcButton1.Left = Form6.Width / 2 - Form6.dcButton1.Width - 500
        Form6.dcButton3.Left = Form6.Width / 2 + 500
      Case "closeback"
        Form6.dcButton3.Visible = True
        Form6.dcButton4.Visible = True
        Form6.dcButton4.Left = Form6.Width / 2 - Form6.dcButton4.Width - 500
        Form6.dcButton3.Left = Form6.Width / 2 + 500
      Case Else
        Form6.dcButton1.Visible = True
        Form6.dcButton2.Visible = True
        Form6.dcButton1.Left = Form6.Width / 2 - Form6.dcButton1.Width - 500
        Form6.dcButton2.Left = Form6.Width / 2 + 500
    End Select
   
    Form6.Show 1
   
End Function

 

'自己做的drawdown

Public Function mydrawdomn(comboi As ComboBox, fromtable As String, listfiles As String, tj As String, myvalue As String) As Boolean

    Call myopen

    If tj <> "" Then
        If tj = "notj" Then
            rs.Open "select distinct " & listfiles + " from " & fromtable, conn, adOpenStatic, adLockReadOnly, adCmdText
        Else
            rs.Open "select distinct " & listfiles + " from " & fromtable + " where " & tj + " = '" & myvalue + "'", conn, adOpenStatic, adLockReadOnly, adCmdText
        End If
    Else
        rs.Open "select distinct " & listfiles + " from " & fromtable + " where " & listfiles + " like '%" & comboi.Text + "%'", conn, adOpenStatic, adLockReadOnly, adCmdText
    End If
   
    comboi.Clear

    For i = 0 To rs.RecordCount

        If Not rs.EOF Then
            comboi.AddItem rs(0), i
            rs.MoveNext
        End If

    Next i

    Call myclose

End Function

 

 

Public Function isfileopen(sfile As Variant) As Boolean
    isfileopen = False
    Dim openfile As New FileSystemObject, targetfilename  As String
    If Not openfile.FileExists(sfile) Then
        Call mymsgbox("系统模板文件损坏或丢失，请联系您的系统管理员！", "", "yes", "c")
        Exit Function
    End If

    targetfilename = "c:/temp"
    On Error GoTo erropen
    openfile.MoveFile sfile, targetfilename
    openfile.MoveFile targetfilename, sfile

Exit Function

erropen:
    isfileopen = True
End Function

'下面函数用以判断程序是否在运行，如果是，则在运行时返回True。

Public Function IsRunning(ByVal ProgramID) As Boolean     '传入进程标识ID

    Dim hProgram As Long     '被检测的程序进程句柄

    hProgram = OpenProcess(0, False, ProgramID)

    If Not hProgram = 0 Then

        IsRunning = True

    Else

        IsRunning = False

    End If

    CloseHandle hProgram

End Function
Public Function toexcel(dgrid As DataGrid, dbutton As dcButton, fform As Form, fuhao As String)
On Error Resume Next
dbutton.Caption = "数据导出中，请稍候..."
dbutton.Refresh
fform.MousePointer = 11
dbutton.Visible = True

Dim r As Integer
Dim w As Integer
Dim k As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set excelapp = CreateObject("excel.application")

If Err Then
   Err.Clear
   Call mymsgbox("您还没有安装EXCEL，请安装后重试！", "", "yes", "c")
   Exit Function
End If

xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
    xlSheet.Columns.AutoFit
   
For k = 0 To dgrid.Columns.Count - 1 'DataGrid所有的列数
    xlSheet.Cells(1, k + 1) = dgrid.Columns(k).Caption '第一行为DataGrid的列标题
Next
   dgrid.Scroll 0, -dgrid.FirstRow '导出前拉动过垂直滚动条
   dgrid.Row = 0
  
For r = 0 To dgrid.ApproxCount - 1 'DataGrid的所有行数
      
    For w = 0 To dgrid.Columns.Count - 1 'DataGrid所有的列数,若将此数改小到不拉DataGrid的垂直滚动条的时候能看见的行数的时候正常
        dgrid.Col = w
        xlSheet.Cells(r + 2, w + 1) = dgrid.Text '从第二行显示'DataGrid的内容
    Next
   
   If r < dgrid.ApproxCount - 1 Then
    dgrid.Row = dgrid.Row + 1
    End If
Next

If fuhao <> "" Then
dgrid.Scroll 0, -dgrid.FirstRow '导出前拉动过垂直滚动条   ****这个一定要****
dgrid.Row = 0
  
For mm = 0 To dgrid.ApproxCount - 1 'DataGrid的所有行数
   dgrid.Col = 0
  
   For nn = 0 To 4
      If InStr(dgrid.Text, fuhao) <> 0 Then xlSheet.Range(xlSheet.Cells(mm + 2, 1), xlSheet.Cells(mm + 2, dgrid.Columns.Count)).Interior.ColorIndex = 6
      dgrid.Col = nn
   Next nn
  
   If mm < dgrid.ApproxCount - 1 Then dgrid.Row = dgrid.Row + 1
  
Next
End If

With xlSheet
 .Range(.Cells(1, 1), .Cells(1, dgrid.Columns.Count)).Font.Name = "宋体"    '设标题为黑体字
 .Range(.Cells(1, 1), .Cells(1, dgrid.Columns.Count)).Font.Bold = True    '标题字体加粗
 .Range(.Cells(1, 1), .Cells(dgrid.ApproxCount + 1, dgrid.Columns.Count)).Borders.LineStyle = xlContinuous '设表格边框样式
 .Range(.Cells(1, 2), .Cells(dgrid.ApproxCount + 1, dgrid.Columns.Count)).HorizontalAlignment = xlCenter   '设置垂直居中
 .Range(.Cells(1, 2), .Cells(dgrid.ApproxCount + 1, dgrid.Columns.Count)).VerticalAlignment = xlCenter     '设置水平居中
End With

xlApp.Visible = True
Set xlApp = Nothing  '交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

dbutton.Visible = False
fform.MousePointer = 0

End Function

 

 

 

 

Public Function killw(myw)   '去掉小数点后多余的0

myd = InStr(myw, ".") '是否有小数

If myd <> 0 Then   '如果有小数

If Right(myw, 1) = "." Then  '特殊情况，最后一位为小数点(.)
   myw = Left(myw, Len(myw) - 1)
   Exit Function
End If

If Right(myw, 1) <> "0" Then Exit Function '特殊情况，最后一位即不为0

   mye = Len(myw) - myd   '得到小数位数

   For k = 1 To mye       '判断有几个0
      If Mid(myw, Len(myw) - k, 1) <> "0" Then
        myl = k - 1
        Exit For
      End If
   Next k
  
   myw = Left(myw, Len(myw) - myl)
  
End If

End Function