这是模块部分，主要定义了一些public的变量和函数，先发上源码：
Public username As String, quanxian As String, connstr As StringPublic conn As ADODB.Connection, conn0 As ADODB.Connection, rs As ADODB.Recordset, rs0 As ADODB.RecordsetPublic inputdata(19) As StringPublic fromform As String, myreturn As String, bianma As StringPublic myctrl As Boolean
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongDeclare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongDeclare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongDeclare 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 LongPublic Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPublic Const WS_EX_LAYERED = &H80000Public Const GWL_EXSTYLE = (-20)Public Const LWA_ALPHA = &H2Public Const LWA_COLORKEY = &H1Public 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 LongConst 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 SubPublic Sub SetComboWidth(oComboBox As ComboBox, lWidth As Long)'lWidth 是宽度，单位是 pixelsSendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0End 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) / &H10000End 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 iEnd 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 iEnd 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 = ValueEnd Function
Public Function myopen() Set conn = New ADODB.Connection Set rs = New ADODB.Recordset conn.ConnectionString = connstr conn.ConnectionTimeout = 30 conn.OpenEnd Function
Public Function myclose() On Error Resume Next rs.Close Set rs = Nothing conn.Close Set conn = NothingEnd Function
'以上是把用户的ID和密码加密存放到配置文件和数据库（读取时解密）用到的几个函数。
'以下是几个打开配置文件、连接数据库和输入判断常用到的函数。Public Function myopen0() Set conn0 = New ADODB.Connection Set rs0 = New ADODB.Recordset conn0.ConnectionString = connstr conn0.ConnectionTimeout = 30 conn0.OpenEnd Function
Public Function myclose0() On Error Resume Next
rs0.Close Set rs0 = Nothing conn0.Close Set conn0 = NothingEnd 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 FunctionPublic 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 = TrueEnd 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 FunctionPublic Function toexcel(dgrid As DataGrid, dbutton As dcButton, fform As Form, fuhao As String)On Error Resume Nextdbutton.Caption = "数据导出中，请稍候..."dbutton.Refreshfform.MousePointer = 11dbutton.Visible = True
Dim r As IntegerDim w As IntegerDim k As IntegerDim xlApp As Excel.ApplicationDim xlBook As Excel.WorkbookDim xlSheet As Excel.WorksheetSet xlApp = CreateObject("Excel.Application")Set excelapp = CreateObject("excel.application")
If Err Then Err.Clear Call mymsgbox("您还没有安装EXCEL，请安装后重试！", "", "yes", "c") Exit FunctionEnd If
xlApp.Visible = FalseSet xlBook = xlApp.Workbooks.AddSet 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 IfNext
If fuhao <> "" Thendgrid.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 NextEnd 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 = TrueSet xlApp = Nothing '交还控制给ExcelSet xlBook = NothingSet xlSheet = Nothing
dbutton.Visible = Falsefform.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 FunctionEnd 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
