VB开发的ERP系统

Private Sub Txt_RsItm_KeyPress(Index As Integer, KeyAscii As Integer)
    '判断输入的有效性
    If KeyAscii = 39 Then KeyAscii = 0
    Select Case tDataType(Index)
           Case 2
               Call InputFieldLimit(Txt_RsItm(Index), 7, KeyAscii)
           Case 1
               Call InputFieldLimit(Txt_RsItm(Index), 6, KeyAscii)
           Case 5                                                   '控制数字型录入
               Call InputFieldLimit(Txt_RsItm(Index), 5, KeyAscii)
    End Select
End Sub


Private Sub Txt_RsItm_LostFocus(Index As Integer)
'失去焦点时作有效判断
    Call DataIsEffect(Index)
End Sub


Private Sub Pi_move(ob As Object)   '屏幕滚动
    Dim i As Integer
    Dim lPos As Long
    For i = Me.VScBar.Min To Me.VScBar.Max
        If ob.Top >= i * (Me.Height - 2000) And ob.Top <= (i + 1) * (Me.Height - 2000) Then
            Exit For
        End If
    Next i
    If i <= Me.VScBar.Max And i <> Me.VScBar Then
        Me.VScBar.Value = i
    End If
    
End Sub

Private Sub Cmd_CommHlp_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    H_MoveInt = Index
End Sub


Private Function SavePic2DB(ByVal rs As ADODB.Recordset, ByVal emp_id As String) As Boolean
'把图片文件以字节形式存储进数据库
  ' note: this requires the record to already exist - it will insert the
  ' picture at the current position in the recordset
  ' Returns true if success - false otherwise
  Const BlockSize = 15000
  
  Dim ByteData() As Byte                                      '存储图片文件的字节数组
  Dim SourceFile As Integer
  Dim FileLength As Long
  Dim Numblocks As Integer
  Dim LeftOver As Long: Dim s As Integer
 On Error GoTo Line1
  
With Pic_Emp
  SourceFile = FreeFile
  
  '以二进制形式打开文件
  Open .Tag For Binary Access Read As SourceFile
  
  '获得文件长度
  FileLength = LOF(SourceFile)

  If FileLength = 0 Then                                       '字节数为0，退出
    Close SourceFile
    SavePic2DB = False
    Exit Function
  Else
    '首先分解图片为几块
    Numblocks = FileLength \ BlockSize
    LeftOver = FileLength Mod BlockSize
    ReDim ByteData(LeftOver)
    
    '读取文件到数组
    Get SourceFile, , ByteData()
    rs.Fields("Pic").AppendChunk ByteData()
    ReDim ByteData(BlockSize)
    For s = 1 To Numblocks
      Get SourceFile, , ByteData()
      rs.Fields("Pic").AppendChunk ByteData()
    Next s
    rs.Update
    '存储成功，返回true
    Close SourceFile
    SavePic2DB = True
  End If
  
End With
Line1:
End Function

Public Function getPicture(strPicField As String, ByVal rs As ADODB.Recordset) As Boolean
'从数据库读取图片，生成磁盘文件
  Const BlockSize = 15000
  Dim ByteData() As Byte                                            '以二进制形式存储图片的字节数组
  Dim DestFileNum As Integer
  Dim DiskFile As String
  Dim FileLength As Long                                            '图片文件的长度
  Dim Numblocks As Integer                                          '图片的块数
  Dim LeftOver As Long                                              '剩余部分
  Dim i As Integer
 On Error GoTo Line1
  
  '删除已存在的图形文件
  DiskFile = App.Path & "\temp.bmp"
  If Len(Dir$(DiskFile)) > 0 Then
     Kill DiskFile
  End If
    
  '把图片文件分解成几部分
  DestFileNum = FreeFile
  FileLength = rs.Fields(strPicField).ActualSize
  Numblocks = FileLength \ BlockSize
  LeftOver = FileLength Mod BlockSize
    
  '打开文件，开始按块存入数据库
  Open DiskFile For Binary As DestFileNum
  rs.Move 0, adBookmarkCurrent
  ByteData() = rs.Fields(strPicField).GetChunk(LeftOver)
  Put DestFileNum, , ByteData()

  For i = 1 To Numblocks
      ByteData() = rs.Fields(strPicField).GetChunk(BlockSize)
      Put DestFileNum, , ByteData()
  Next i

  Close DestFileNum

  getPicture = True
Line1:
End Function



Private Sub Cmd_CommHlp_Click(Index As Integer)
'基本信息输入调用帮助，通用根据情况调用不同类型的帮助
    Dim s As String
    Dim i As Integer
'    ------------------------工号选人----------------------------------------
    If UCase(tFieldName(Index)) = "EMPNO" Then
        SsqlHelp = "Emp"
        Ed_EmpArInfoCorHlp.Show 1
        If Trim(P_Code) <> "" Then
            Txt_RsItm(Index).Text = P_Code
            EmpID = Xtfhcs
            Xtfhcs = ""
            LoadData (EmpID)
        Else
            Exit Sub
        End If
        Call SetTxtStatus(False, False, False, Lrzt)
        For i = 1 To Lbl_ItmName.UBound
            If Txt_RsItm(i).Enabled Then Txt_RsItm(i).SetFocus: Exit For
        Next i
        Exit Sub
    End If
'    ------------------------日期性帮助--------------------------------------
    If tDataType(Index) = 7 Then
       Xtfhcs = ""
       XT_calendar.Show 1
       If Xtfhcs <> "" Then
        Txt_RsItm(Index).Text = Xtfhcs
        Xtfhcs = ""
       End If
       Txt_RsItm(Index).SetFocus
       Exit Sub
    End If
'   ---------------------------其他帮助------------------------------------
    SsqlHelp = Str(tItmId(Index))
    Ed_EmpArInfoCorHlp.Show 1
    
    If P_Name <> "" Then
       Txt_RsItm(Index).Text = P_Name
       tIsCode(2, Index) = P_Code
       P_Name = ""
       P_Code = ""
    End If

    If Txt_RsItm(Index).Enabled = True Then Txt_RsItm(Index).SetFocus
End Sub

Private Sub VScBar_Change()     '滚动条
    If ScollBarIsEffect = True Then
        Me.Pict.Top = -(Me.VScBar.Value * (Me.Height - 2000))
    End If
    
End Sub


'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
'对工具条按钮的不同处理
Dim i As Integer
Select Case Button.Key
        Case "PrinterSet"                                                               '打印设置
            PrintSetFrm.Show 1
        Case "Printer"                                                                  '打印
            DY_DytsFrm.Show 1
        Case "Preview"                                                                  '预览
            Print_EmpInfo
        Case "New"                                                                      '新增
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
            Call MF_New
        Case "Modi"                                                                     '修改
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
            
            Call MF_Modi
        Case "Del"                                                                      '删除
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
            Call MF_Del
        Case "Save"                                                                     '保存
            Call MF_Save
        Case "Cancel"                                                                   '取消
            Call MF_Cancel
        Case "Refresh"
            
        Case "First"                                                                    '首个
            Move_Cursor (Button.Key)
        Case "Previous"                                                                 '上一个
            Move_Cursor (Button.Key)
        Case "Next"                                                                     '下一个
            Move_Cursor (Button.Key)
        Case "Last"                                                                     '末尾
            Move_Cursor (Button.Key)
        Case "Set"                                                                      '设定
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
            Ed_EmpArInfoSetFrm.Show 1
            Call SetReserve
        Case "Help"                                                                     '帮助
            Call F1bz
        Case "Exit"                                                                     '退出
            Unload Me
End Select

Exit Sub
Err_Del:
End Sub


'========================自定义过程=================================

Private Function MF_New() As Boolean
'供工具条按钮调用的函数（新增记录），成功返回真，否则假
MF_New = False
On Error GoTo errD
    Lrzt = 1
    EmpID = 0
    SwitchToolBar ("1")
    Call SetTxtStatus(True, False, False, Lrzt)
    ReserveItmRefurbish
    With Me.Txt_RsItm(1)
        If .Enabled And .Visible Then
            .SetFocus
        End If
    End With
MF_New = True
errD:
End Function

Private Function MF_Del() As Boolean
'供工具条按钮调用的函数（删除记录），成功返回真，否则假
MF_Del = False
On Error GoTo errD
    If Not DelArRec(EmpID) Then Exit Function
    Lrzt = 0
    If UCase(FormOwner) = "SELF" Then
        Call SetTxtStatus(True, True, False, Lrzt)
    Else
        lID.Caption = lpId.Caption
        EmpID = lID.Caption
        LoadData (EmpID)
        Call SetTxtStatus(False, True, False, Lrzt)
        If QuerySet.State = 1 Then QuerySet.Close
        Set QuerySet = Cw_DataEnvi.DataConnect.Execute(QuerySql)
        QuerySet.Find "Rs_BasicInfo#EmpID  = " & EmpID
        Qr_RsBasicFrm.BeenModify = True
    End If
MF_Del = True
errD:
End Function

Private Function MF_Modi() As Boolean
'供工具条按钮调用的函数（删除记录），成功返回真，否则假
Dim i As Integer
MF_Modi = False

On Error GoTo errD
    Lrzt = 2
    SwitchToolBar (Lrzt)
    If UCase(FormOwner) = "SELF" Then                                            '窗体是自己打开的
        Call SetTxtStatus(False, True, True, Lrzt)
    Else                                                                         '窗体是经过查询结果调用生成的
        Call SetTxtStatus(False, False, False, Lrzt)
    End If

    For i = 1 To Lbl_ItmName.UBound
        If Txt_RsItm(i).Enabled Then Txt_RsItm(i).SetFocus: Exit For
    Next i

MF_Modi = True
Exit Function

errD:
End Function


Private Function MF_Cancel() As Boolean
'供工具条按钮调用的函数（取消动作处理），成功返回真，否则假
MF_Cancel = False
On Error GoTo errD
    If UCase(FormOwner) = "SELF" Then                                           '窗体是自己打开的