www.pudn.com > 考勤管理系统源码(VB含串口接口程序).zip > modCommFun.bas
Attribute VB_Name = "modCommFun"
Option Explicit
Global Const gFIXEDROWS = 1
Public Const gGridBackColor = &H80000018
Public Const gGridForeColor = &H0
Public Const gCellSelBackColor = &H80000001 '查询结果的背景色
Public Const gCellSelForeColor = vbWhite
Public Const gTRUE = -1
Public Const gFALSE = 0
Public Function EraseSpecialSign(ByVal Str As String) As String '过滤'"
Dim m_Ch As String
Dim i As Integer
EraseSpecialSign = ""
For i = 1 To Len(Str)
m_Ch = Mid(Str, i, 1)
If m_Ch <> "'" And Not (AscB(LeftB(m_Ch, 1)) = 34 And AscB(RightB(m_Ch, 1)) = 0) Then
EraseSpecialSign = EraseSpecialSign & m_Ch
End If
Next i
End Function
Public Function CheckIsDigit(KeyAscii As Integer, Optional TempStr As String) As Integer
If TempStr = "Price" Then
If KeyAscii <> 46 And (KeyAscii < 48 Or KeyAscii > 57) Then
CheckIsDigit = 0
Else
CheckIsDigit = KeyAscii
End If
Else
If KeyAscii < 48 Or KeyAscii > 57 Then
CheckIsDigit = 0
Else
CheckIsDigit = KeyAscii
End If
End If
End Function
Public Sub GotFocus(Text1 As TextBox)
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub
Public Sub SendKeyTab(KeyCode As Integer)
If KeyCode = 13 Then
SendKeys "{TAB}"
End If
End Sub
Public Function GetTheVeryLen(m_Txt As String, m_Len As Integer) As String
GetTheVeryLen = StrConv(Trim(m_Txt), vbNarrow)
GetTheVeryLen = LeftB(GetTheVeryLen, m_Len)
End Function
Private Function DeleteLastPart(Str As String) As String
Dim i As String
i = InStr(Str, "(")
If i > 0 Then
Str = Left(Str, i - 1)
Else
i = InStr(Str, "（")
If i > 0 Then
Str = Left(Str, i - 1)
End If
End If
DeleteLastPart = Str
End Function
Public Function FixedLen(tempVar As Variant, ByVal tempLen As Long, Optional ByVal Opsition As Long = 0) As String
Dim tempString As String
Dim ByteLen As Long
tempString = Trim(CStr(tempVar))
If IsNumeric(tempString) Then
tempString = Left(tempString, tempLen)
ByteLen = Len(tempString)
Else
tempString = Left(tempString, Int(tempLen / 2))
ByteLen = LenB(StrConv(tempString, vbFromUnicode))
End If
If Opsition = 0 Then '左对齐
FixedLen = tempString & Space(tempLen - ByteLen)
ElseIf Opsition = 1 Then '右对齐
FixedLen = Space(tempLen - ByteLen) & tempString
ElseIf Opsition = 2 Then '居中
FixedLen = Space(Int((tempLen - ByteLen) / 2)) & tempString & Space(tempLen - ByteLen - Int((tempLen - ByteLen) / 2))
End If
End Function
Public Sub EditGridTxt(msfGrid As MSFlexGrid, obj As Control, Optional aPosition As AlignmentConstants = vbLeftJustify)
Dim i As Long
With msfGrid
If .row = 0 Then
obj.Visible = False
Exit Sub
End If
If TypeOf obj Is TextBox Or TypeOf obj Is ComboBox Then
obj.Visible = False
obj.Width = .CellWidth
If TypeOf obj Is TextBox Then
obj.Text = ""
obj.Top = .Top + .CellTop
obj.Left = .Left + .CellLeft
obj.Height = .CellHeight
obj.Left = .Left + .CellLeft
obj.Alignment = aPosition
obj.Text = .Text
obj.SelStart = 0
obj.SelLength = Len(obj)
ElseIf TypeOf obj Is ComboBox Then
obj.Top = .Top + .CellTop
obj.Left = .Left + .CellLeft
For i = 0 To obj.ListCount
If obj.List(i) = Trim(.Text) Then
If Trim(.Text) = Empty Then
If obj.ListCount > 0 Then
obj.ListIndex = 0
End If
Else
obj.ListIndex = i
End If
Exit For
End If
Next
End If
obj.Visible = True
obj.SetFocus
End If
End With
End Sub
Public Function GetMaxDayInAMonth(myYear As Integer, MyMonth As Integer) As Integer
If MyMonth = 2 Then
If (myYear Mod 400) = 0 Then
GetMaxDayInAMonth = 29
ElseIf (myYear Mod 100) = 0 Then
GetMaxDayInAMonth = 28
ElseIf (myYear Mod 4) = 0 Then
GetMaxDayInAMonth = 29
Else
GetMaxDayInAMonth = 28
End If
Else
If MyMonth < 8 Then
GetMaxDayInAMonth = IIf((MyMonth Mod 2) = 0, 30, 31)
Else
GetMaxDayInAMonth = IIf((MyMonth Mod 2) = 0, 31, 30)
End If
End If
End Function
Public Function ValiText(KeyIn As Integer, ValidateString As String, Editable As Boolean) As Integer
Dim ValidateList As String
Dim KeyOut As Integer
If Editable = True Then
ValidateList = UCase(ValidateString) & Chr(8)
Else
ValidateList = UCase(ValidateString)
End If
If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
KeyOut = KeyIn
Else
KeyOut = 0
Beep
End If
ValiText = KeyOut
End Function
'Private Sub SetHandIco()
' Dim picPath As String
' picPath = App.Path + "\pic\hand.ico"
' If Dir(picPath) <> "" Then
' Set gicoHand = LoadPicture(picPath)
' End If
'End Sub
Public Sub SortGridByCol(myGrid As MSFlexGrid)
With myGrid
If .row = .FixedRows Then
.Sort = 1
End If
End With
End Sub
Public Sub FillCbo(myCbo As ComboBox, myArray() As ItemStruc, Optional IniValue As Integer = 1) 'optional为所有类别准备
Dim i As Integer
With myCbo
.Clear
If UBound(myArray) >= 1 Then
For i = IniValue To UBound(myArray)
.AddItem myArray(i).Name
.ItemData(.NewIndex) = myArray(i).ID
Next
If .ListCount > 0 Then
.ListIndex = 0
End If
End If
End With
End Sub
Public Sub LookForCbo(myCbo As ComboBox, intFind As Integer)
Dim i As Integer
With myCbo
For i = 0 To .ListCount - 1
If .ItemData(i) = intFind Then
.ListIndex = i
Exit For
End If
Next
End With
End Sub
Public Sub LookForCboByStr(myCbo As ComboBox, strFind As String)
Dim i As Integer
With myCbo
For i = 0 To .ListCount - 1
If Trim(.List(i)) = strFind Then
.ListIndex = i
Exit For
End If
Next
End With
End Sub
Public Sub getItemData(cboMycbo As ComboBox, myItem As Integer)
With cboMycbo
If .ListIndex = -1 Then
myItem = .ItemData(0)
Else
myItem = .ItemData(.ListIndex)
End If
End With
End Sub
Public Sub SetGridColor(myGrid As MSFlexGrid)
With myGrid
.RowHeight(.FixedRows - 1) = 300
.BackColor = gGridBackColor '&H80000018 '&HC0FFFF '&HC0FFC0
.BackColorFixed = &HC0C0C0 '&HC0FFC0
.ForeColorFixed = &HC00000 ' &H0& '&HFF00FF '&HC0& &HFF0000 ' '&H80000002 '&HC00000 '
.ForeColor = gGridForeColor ' &H0
.BackColorSel = &H8000000D '&HC00000
.GridColor = &HC0C0C0
.GridColorFixed = &H0& ' &H808080 ' &HC0C0C0
'.ForeColorFixed =
.BackColorBkg = &H80000018 ' &HFFFFFF ''&HC0FFFF
.AllowUserResizing = flexResizeColumns
.ScrollBars = flexScrollBarBoth
.Rows = gFIXEDROWS
End With
End Sub
Public Sub ToDeleteFromGrid(myGrid As MSFlexGrid, intKeyRow As Integer, strMsg As String, strMyDataBase As Database, strTableName As String, strDeleteField As String)
If Trim(strMsg) <> Empty Then
If MsgBox(strMsg, _
vbQuestion + vbYesNo + vbDefaultButton2, _
gTitle) = vbNo Then Exit Sub
End If
Dim strKey As String
With myGrid
strKey = Trim(.TextMatrix(.row, intKeyRow))
SetDelFlagForTable Trim(strKey), strMyDataBase, strTableName, strDeleteField, True
If .Rows = .FixedRows + 1 Then
.Rows = .FixedRows
Else
.RemoveItem .row
End If
End With
End Sub
Public Sub SetDelFlagForTable(varKey As Variant, strMyDataBase As Database, strTableName As String, strDeleteField As String, Optional isStr As Boolean = True)
Dim Sql As String
Sql = "update " & strTableName _
& " set F_DelFlag=" & gTRUE _
& " where " & strDeleteField & "="
If isStr Then
Sql = Sql & "'" & varKey & "'"
Else
Sql = Sql & varKey
End If
strMyDataBase.Execute Sql
End Sub
Public Sub DeleteFromDataBase(varKey As Variant, strMyDataBase As Database, strTableName As String, strDeleteField As String, Optional isStr As Boolean = True)
Dim Sql As String
Sql = "delete * from " & strTableName _
& " where " & strDeleteField & "="
If isStr Then
Sql = Sql & "'" & varKey & "'"
Else
Sql = Sql & varKey
End If
strMyDataBase.Execute Sql
End Sub
Public Function IsExist(strMyDataBase As Database, strTableName As String, strFindField As String, varFindValue As Variant, Optional isStr As Boolean = True) As Boolean
Dim Rst As Recordset
Dim Sql As String
Sql = "select * from " & strTableName & _
" where " & strFindField & "=" '& strFindValue & "'"
If isStr Then
Sql = Sql & "'" & varFindValue & "'"
Else
Sql = Sql & varFindValue
End If
Set Rst = strMyDataBase.OpenRecordset(Sql, dbOpenSnapshot)
If Rst.RecordCount > 0 Then
IsExist = True
Else
IsExist = False
End If
Rst.Close
Set Rst = Nothing
End Function
Public Sub CloseColor(msfGrid As MSFlexGrid)
Dim i As Integer
Dim j As Integer
With msfGrid
If .Redraw Then .Redraw = False
For i = .FixedRows To .Rows - 1
.row = i
.col = 0
If .CellBackColor = gCellSelBackColor Then
For j = 0 To .Cols - 1
.col = j
.CellBackColor = gGridBackColor
.CellForeColor = gGridForeColor
Next
End If
Next
.Redraw = True
End With
End Sub
Public Sub SetTxtPosition(tmpGrid As MSFlexGrid, tmpTxt As TextBox)
With tmpGrid
tmpTxt.Top = .Top + .CellTop
tmpTxt.Left = .Left + .CellLeft
tmpTxt.Width = .CellWidth
tmpTxt.Height = .CellHeight
tmpTxt = .Text
tmpTxt.Visible = True
tmpTxt.SetFocus
End With
End Sub
Public Function JoinSqlStr(varToLook As Variant, WhereFlag As Boolean, strFindField As String, Optional isStr As Boolean = True) As String
Dim Sql As String
If isStr Then
If varToLook = Empty Then
JoinSqlStr = Empty
Exit Function
End If
Else
If varToLook = 0 Then
JoinSqlStr = Empty
Exit Function
End If
End If
If WhereFlag Then
Sql = Sql & " and "
Else
Sql = Sql & " Where "
WhereFlag = True
End If
Sql = Sql & " InStr(1," & strFindField & ",'" & varToLook & "',0)>0 "
JoinSqlStr = Sql
End Function
Public Sub SaveRegister()
Dim AppSet As String
Dim StrSet As String
AppSet = "OutProd"
StrSet = "Setting"
SaveSetting AppSet, StrSet, "OwnName", gOwnName
SaveSetting AppSet, StrSet, "OwnAddress", gOwnAddress
SaveSetting AppSet, StrSet, "OwnPhone", gOwnPhone
SaveSetting AppSet, StrSet, "OwnFax", gOwnFax
SaveSetting AppSet, StrSet, "OwnPost", gOwnPost
SaveSetting AppSet, StrSet, "OwnOwner", gOwnOwner
End Sub
Public Sub GetRegister()
Dim AppSet As String
Dim StrSet As String
AppSet = "OutProd"
StrSet = "Setting"
Const DEFAULTNAME = "WX工作室"
Const DEFAULTADDRESS = ""
Const DEFAULTPHONE = "13600670114"
Const DEFAULTFAX = ""
Const DEFAULTPOST = ""
Const DEFAULTOWNER = ""
Const DEFAULTLOGINNAME = "默认用户"
Const DEFAULTLOGINPASS = ""
gLoginName = GetSetting(AppSet, StrSet, "LoginName", DEFAULTLOGINNAME)
gOwnName = GetSetting(AppSet, StrSet, "OwnName", DEFAULTNAME)
gOwnAddress = GetSetting(AppSet, StrSet, "OwnAddress", DEFAULTADDRESS)
gOwnPhone = GetSetting(AppSet, StrSet, "OwnPhone", DEFAULTPHONE)
gOwnFax = GetSetting(AppSet, StrSet, "OwnFax", DEFAULTFAX)
gOwnPost = GetSetting(AppSet, StrSet, "OwnPost", DEFAULTPOST)
gOwnOwner = GetSetting(AppSet, StrSet, "OwnOwner", DEFAULTOWNER)
End Sub
Public Sub KeyDownByUpDown(tmpGrid As MSFlexGrid, KeyCode As Integer)
Dim sRow, SCol As Integer
With tmpGrid
Select Case KeyCode
Case vbKeyDown
sRow = .row + 1
If sRow = .Rows Then
sRow = .FixedRows + 1
End If
Case vbKeyUp
sRow = .row - 1
If sRow = 0 Then
sRow = .Rows - 1
End If
End Select
SCol = .col
.row = sRow
.col = SCol
.RowSel = sRow
End With
End Sub