mhikitorisaki.frm

东通株式会社的人力资源管理系统。VB制作

    Dim j As Integer
    For i = 0 To FGRow - 1 Step 1
        For j = 0 To FGCol - 1 Step 1
            xlsheet.Cells(i + 1, j + 1) = fg.TextMatrix(i, j)
        Next j
    Next i
   
    xlBook.SaveAs filename
    MsgBox "Save OK!", vbOKOnly, "堷庢愭儅僗僞"
    Set xlsheet = Nothing
    xlBook.Close
    Set xlBook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
'    End With
    Exit Sub
handler:
Set xlsheet = Nothing
    xlBook.Close
    Set xlBook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    MsgBox Err.Description, vbExclamation, Me.Caption
End Sub

Private Sub Command2_Click()
    Dim Response As String
    Response = MsgBox("Print Grid Yes or No?", vbYesNo, Me.Caption)
    
    If Response = vbYes Then
    On Error GoTo handler

    Dim xlApp As excel.Application
    Dim xlBook As excel.Workbook
    Dim xlsheet As excel.Worksheet
    Set xlApp = New excel.Application
    Set xlBook = xlApp.Workbooks.Add
    Set xlsheet = xlBook.Worksheets(1)

    xlsheet.Activate
    xlApp.Visible = False
    Dim appRow As Long
    Dim appCol As Long
    Dim FGRow As Long
    Dim FGCol As Long
    
    
    
    FGRow = fg.Rows
    FGCol = fg.Cols
    
    Dim i As Integer
    Dim j As Integer
    For i = 0 To FGRow - 1 Step 1
        For j = 0 To FGCol - 1 Step 1
            xlsheet.Cells(i + 1, j + 1) = fg.TextMatrix(i, j)
        Next j
    Next i

    xlBook.PrintOut
    xlApp.DisplayAlerts = False
    Set xlsheet = Nothing
    xlBook.Close
    Set xlBook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    Exit Sub
    Else
    Exit Sub
    End If
    
handler:
    xlApp.DisplayAlerts = False
    Set xlsheet = Nothing
    xlBook.Close
    Set xlBook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    MsgBox Err.Description, vbExclamation, Me.Caption

    
End Sub

Private Sub Command3_Click()
txtCode.Text = ""
txtName.Text = ""
txtCouse.Text = ""
txtAdd.Text = ""
txtTel.Text = ""
txtCode.Enabled = True
txtCode.BackColor = &HFFFFFF
End Sub

Private Sub Command4_Click()
    Dim i As Long
    With fg
        .Rows = 1
'        .Cols = 5
'        .FixedCols = 0
         
'        .TextMatrix(0, 0) = "No"
'        .TextMatrix(0, 1) = "Name"
        On Error GoTo Err1
        Dim rs As ADODB.Recordset
        Set rs = New ADODB.Recordset
        rs.CursorLocation = adUseClient
        Dim a As String
        a = "select  HIKITORISAKI_CD,HIKITORISAKI_NM,HIKITORI_COUSE,ADDR,TEL from T_MHIKITORISAKI where 1=1"
        If txtCode.Text <> "" Then
            a = a & " and HIKITORISAKI_CD = " & Trim(txtCode.Text)
        End If
        If Trim(txtName.Text) <> "" Then
            a = a & " and HIKITORISAKI_NM like '%" & Trim(txtName.Text) & "%'"
        End If
        If Trim(txtCouse.Text) <> "" Then
            a = a & " and HIKITORI_COUSE = " & Trim(txtCouse.Text)
        End If
        If Trim(txtAdd.Text) <> "" Then
            a = a & " and ADDR like '%" & Trim(txtAdd.Text) & "%'"
        End If
        If Trim(txtTel.Text) <> "" Then
            a = a & " and TEL like '%" & Trim(txtTel.Text) & "%'"
        End If
        rs.Open a, dbConn
        i = 0
          Do While Not rs.EOF
            i = i + 1
            .Rows = .Rows + 1
'            .TextMatrix(i, 0) = rs.Fields(0) 'HIKITORISAKI_CD
'            .TextMatrix(i, 1) = rs.Fields(1) 'HIKITORISAKI_NM
'            .TextMatrix(i, 2) = rs.Fields(2) 'HIKITORI_COUSE
'            .TextMatrix(i, 3) = rs.Fields(3) 'ADDR
'            .TextMatrix(i, 4) = rs.Fields(4) 'TEL
''            .Cell(flexcpText, i, 0, i, 0) = CStr(rs.Fields(0))  'sno
''            .Cell(flexcpText, i, 1, i, 1) = rs.Fields(1)  'sname
            For j = 0 To rs.Fields.Count - 1 Step 1
            If IsNull(rs.Fields(j)) Then
                .TextMatrix(i, j) = ""
            Else
                .TextMatrix(i, j) = rs.Fields(j)
            End If
            Next j

            rs.MoveNext
        
        Loop
        rs.Close
        Set rs = Nothing

End With
   Exit Sub
Err1:
MsgBox Err.Description, vbExclamation, Me.Caption
'rs.Close
Set rs = Nothing

End Sub

Private Sub Command5_Click()

Dim rs As ADODB.Recordset
        Set rs = New ADODB.Recordset
        rs.CursorLocation = adUseClient
        
On Error GoTo Err1
If txtCode.Enabled = True Then

Dim strSql As String
strSql = "insert into T_MHIKITORISAKI (HIKITORISAKI_CD,HIKITORISAKI_NM,HIKITORI_COUSE,ADDR,TEL) values ("
If txtCode.Text = "" Then
MsgBox "Not allowed Null !"
Exit Sub
Else
strSql = strSql & txtCode.Text
strSql = strSql & ",'" & Trim(txtName.Text) & "'"
End If
If Trim(txtCouse.Text) = "" Then
    strSql = strSql & ",Null"
Else
    strSql = strSql & "," & txtCouse.Text
End If
If Trim(txtAdd.Text) = "" Then
    strSql = strSql & ",Null"
Else
strSql = strSql & ",'" & txtAdd.Text & "',"
End If
If Trim(txtTel.Text) = "" Then
    strSql = strSql & ",Null"
Else
strSql = strSql & "'" & txtTel.Text & "'"
End If
strSql = strSql & ")"

dbConn.Execute strSql
        
MsgBox ("Insert ok!")
Call Command4_Click
Else

        Dim updateSql As String

        Dim nameSql As String
        If Trim(txtName.Text) = "" Then
        nameSql = "Null"
        Else
        nameSql = "'" & Trim(txtName.Text) & "'"
        End If
        
        Dim couseSql As String
        If txtCouse.Text = "" Then
        couseSql = "Null"
        Else
        couseSql = txtCouse.Text
        End If
        
        Dim addrSql As String
        If Trim(txtAdd.Text) = "" Then
        addrSql = "Null"
        Else
        addrSql = "'" & Trim(txtAdd.Text) & "'"
        End If
        
        Dim telSql As String
        If Trim(Val(txtTel.Text)) = "" Then
        telSql = "Null"
        Else
        telSql = "'" & Trim(Val(txtTel.Text)) & "'"
        End If
        
        
        updateSql = "update T_MHIKITORISAKI set HIKITORISAKI_NM=" & nameSql & ",HIKITORI_COUSE=" & couseSql & ",ADDR=" & addrSql & ",TEL=" & telSql & " where HIKITORISAKI_CD=" & Trim(Val(txtCode.Text))
      
        dbConn.Execute updateSql
        MsgBox ("update ok!")
        Call Command4_Click
End If
       
    Set rs = Nothing
     Exit Sub
Err1:
MsgBox Err.Description, vbExclamation, Me.Caption
Set rs = Nothing
End Sub

Private Sub Command6_Click()
dbConn.Close
End
End Sub


Private Sub fg_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)


If Button = 2 Then
        'fg.Row = fg.MouseRow
        'PopupMenu file1
    Else
        'Text1.Text = fg.TextMatrix(fg.MouseRow, fg.MouseCol)
        If fg.MouseRow > 0 Then
        
        txtCode.Text = Trim(fg.TextMatrix(fg.MouseRow, 0))
        txtName.Text = Trim(fg.TextMatrix(fg.MouseRow, 1))
        txtCouse.Text = Trim(fg.TextMatrix(fg.MouseRow, 2))
        txtAdd.Text = Trim(fg.TextMatrix(fg.MouseRow, 3))
        txtTel.Text = Trim(fg.TextMatrix(fg.MouseRow, 4))
        
        txtCode.Enabled = False
        txtCode.BackColor = &H8000000B
        Else
        Exit Sub
        End If

    End If
End Sub

Private Sub fg_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
        fg.Row = fg.MouseRow
        PopupMenu file1
End If
End Sub



Private Sub file1del_Click()
If fg.MouseRow <> 0 Then
Dim rs As ADODB.Recordset
        Set rs = New ADODB.Recordset
        rs.CursorLocation = adUseClient
        
On Error GoTo Err1
dbConn.Execute "delete from T_MHIKITORISAKI where HIKITORISAKI_CD='" & Trim(fg.TextMatrix(fg.MouseRow, 0)) & "'"
MsgBox ("Delete ok!")
End If
Call Command4_Click
Call Command3_Click
Set rs = Nothing
Exit Sub
Err1:
MsgBox Err.Description, vbExclamation, Me.Caption

End Sub

Private Sub Form_Load()
Call mysub1(txtCouse)
End Sub
Public Sub mysub1(txtCouse)
Dim i As Long
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
Dim a As String, b As String
a = "select COUSE_ID,COUSE_NM from T_MHAISO where 1=1"
  rs.Open a, dbConn
  i = 0
Do While Not rs.EOF
    txtCouse.AddItem rs.Fields(0) & ":" & rs.Fields(1)
    rs.MoveNext
    
    Loop
    rs.Close
    Set rs = Nothing

  
  
  
End Sub

Private Sub txtAdd_KeyPress(KeyAscii As Integer)
If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) Then
If Len(txtCode.Text) >= 100 Then
KeyAscii = 0
End If
If InStr(Chr(KeyAscii), "'") Then
 KeyAscii = 0
End If
End If

End Sub

Private Sub txtCode_KeyPress(KeyAscii As Integer)
 Dim strValid     As String
          strValid = "0123456789"
    If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) Then
          If KeyAscii > 26 Then
                  If InStr(strValid, Chr(KeyAscii)) = 0 Then
                         KeyAscii = 0
                  End If
          End If
    If Len(txtCode.Text) >= 5 Then
    KeyAscii = 0
    End If
    End If
End Sub

Private Sub txtCouse_Click()
Dim a As String, b As String
a = txtCouse.Text
b = Left(a, Len(a) - InStr(1, a, ":") - 1)
txtCouse.Text = b
End Sub

Private Sub txtCouse_KeyPress(KeyAscii As Integer)
 Dim strValid     As String
          strValid = "0123456789"
    If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) Then
          If KeyAscii > 26 Then
                  If InStr(strValid, Chr(KeyAscii)) = 0 Then
                         KeyAscii = 0
                  End If
          End If
    If Len(txtCouse.Text) >= 5 Then
    KeyAscii = 0
    End If
    End If

End Sub

Private Sub txtName_KeyPress(KeyAscii As Integer)
If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) Then
If Len(txtName.Text) >= 100 Then
KeyAscii = 0
End If
If InStr(Chr(KeyAscii), "'") Then
 KeyAscii = 0
End If
End If
End Sub

Private Sub txtTel_KeyPress(KeyAscii As Integer)
 Dim strValid     As String
          strValid = "0123456789-"
    If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) Then
          If KeyAscii > 26 Then
                  If InStr(strValid, Chr(KeyAscii)) = 0 Then
                         KeyAscii = 0
                  End If
          End If
    If Len(txtTel.Text) >= 20 Then
    KeyAscii = 0
    End If
    End If
End Sub