创作
数据库源码分享

vb6数据库的一些示例

邓伟

基于accsess制作：


'Download by http://www.NewXing.com
Dim phoPath As String '照片路径
Dim tFlag As Integer 'text1索引标记
Dim SQL As String
Dim addlvwJTCY As ListItem '家庭成员
Dim addlvwGRJL As ListItem '个人简历
Dim addlvwSHRY As ListItem '所荣荣誉
Dim sx As Boolean '判断是否刷新


Private Sub cmdADDPHO_Click() '选择照片过程
Dim yPath As String '文件源路径
Dim newPath As String '新文件路径

If Me.Text1(0).Text = "" Or Me.Text1(1).Text = "" Then
   MsgBox "请先录入编号、姓名然后再选择照片！", 64, "提示"
   Exit Sub
End If

On erron GoTo Errline
    Me.CommonDialog1.ShowOpen
    yPath = Me.CommonDialog1.FileName
        If yPath <> "" Then
           newPath = App.Path & "\photos\" & Me.Text1(0).Text & Me.Text1(1).Text & ".jpg"
           FileCopy yPath, newPath
           Me.Image1.Picture = LoadPicture(newPath)
           phoPath = "\photos\" & Me.Text1(0).Text & Me.Text1(1).Text & ".jpg"
        End If
    Exit Sub
Errline:
    MsgBox "操作失败！", 48, "错误"
End Sub



Private Sub cmdDELPHO_Click()
Me.Image1.Picture = LoadPicture(App.Path & "\bg\000.jpg")
phoPath = ""
End Sub

Private Sub Combo1_Click() 'text1赋值
Me.Text1(tFlag).Text = Me.Combo1.Text
Me.Combo1.Visible = False
Me.Text1(tFlag + 1).SetFocus
End Sub

Private Sub Form_Initialize()
Call InitCommonControls 'XP效果
End Sub



Private Sub Form_Load()

Me.Caption = gXtmc
Me.Icon = MDIfrm.Icon '图标

If newFlag <> 0 Then '如果为修改
    Call OpenConn
    SQL = "select * from 基础档案表 where zgid=" & gXhcd
    rs.Open SQL, cn, 1, 1
    For i = 0 To 31
        Me.Text1(i).Text = rs.Fields(i + 1)
    Next
    Me.Text1(32).Text = rs!建档人

    '像片路径---------------
    If rs!像片 <> "" Then
        If Dir(App.Path & rs!像片) <> "" Then '判断像片是否存在
            Me.Image1.Picture = LoadPicture(App.Path & rs!像片)
            phoPath = rs!像片
        End If
    Else
        Me.Image1.Picture = LoadPicture(App.Path & "\bg\000.jpg")
        phoPath = ""
    End If
    '------------------------
    Call CloseConn
    Me.Toolbar1.Buttons(1).Visible = False '新增按钮不可用
    Me.Toolbar1.Buttons(3).Enabled = False
    Me.Toolbar1.Buttons(4).Enabled = False
    

    
Else '如果为新增
    Me.Text1(32).Text = gCzy
    Me.Toolbar1.Buttons(2).Visible = False '新增按钮不可用
    Me.Toolbar1.Buttons(3).Enabled = False
    Me.Toolbar1.Buttons(4).Visible = False
End If
      
'初始化家庭成员列表--------------------------------------------
With Me.lvwJTCY
.ColumnHeaders.Add = "职工姓名"
.ColumnHeaders.Add = "成员姓名"
.ColumnHeaders.Add = "关系"
.ColumnHeaders.Add = "所在单位"
.ColumnHeaders(1).Width = 2000
.ColumnHeaders(2).Width = 2000
.ColumnHeaders(3).Width = 2000
.ColumnHeaders(4).Width = 4700
End With

SQL1 = "select * from 家庭成员表 where czgid=" & gXhcd
Call OpenConn
rs.Open SQL1, cn, 1, 1
Do While Not rs.EOF
Set addlvwJTCY = Me.lvwJTCY.ListItems.Add(, , rs!职工姓名, , 1)
    addlvwJTCY.SubItems(1) = rs!成员姓名
    addlvwJTCY.SubItems(2) = rs!关系
    addlvwJTCY.SubItems(3) = rs!所在单位
    rs.MoveNext
Loop
Call CloseConn
'END-----------------------------------------------------------
    
'初始化个人简历列表--------------------------------------------
With Me.lvwGRJL
.ColumnHeaders.Add = "职工姓名"
.ColumnHeaders.Add = "开始时间"
.ColumnHeaders.Add = "结束时间"
.ColumnHeaders.Add = "所在单位"
.ColumnHeaders.Add = "职务"
.ColumnHeaders.Add = "证明人"
.ColumnHeaders(1).Width = 1500
.ColumnHeaders(2).Width = 1500
.ColumnHeaders(3).Width = 1500
.ColumnHeaders(4).Width = 3200
.ColumnHeaders(5).Width = 1500
.ColumnHeaders(6).Width = 1500
End With

SQL1 = "select * from 个人简历表 where jzgid=" & gXhcd
Call OpenConn
rs.Open SQL1, cn, 1, 1
Do While Not rs.EOF
Set addlvwGRJL = Me.lvwGRJL.ListItems.Add(, , rs!职工姓名, , 2)
    addlvwGRJL.SubItems(1) = rs!开始时间
    addlvwGRJL.SubItems(2) = rs!结束时间
    addlvwGRJL.SubItems(3) = rs!所在单位
    addlvwGRJL.SubItems(4) = rs!职务
    addlvwGRJL.SubItems(5) = rs!证明人
    rs.MoveNext
Loop
Call CloseConn
'END-----------------------------------------------------------

'初始所获荣誉列表--------------------------------------------
With Me.lvwSHRY
.ColumnHeaders.Add = "职工姓名"
.ColumnHeaders.Add = "获得时间"
.ColumnHeaders.Add = "所获称号"
.ColumnHeaders.Add = "颁发单位"
.ColumnHeaders(1).Width = 2000
.ColumnHeaders(2).Width = 2000
.ColumnHeaders(3).Width = 2000
.ColumnHeaders(4).Width = 4700
End With

SQL1 = "select * from 个人荣誉表 where rzgid=" & gXhcd
Call OpenConn
rs.Open SQL1, cn, 1, 1
Do While Not rs.EOF
Set addlvwSHRY = Me.lvwSHRY.ListItems.Add(, , rs!职工姓名, , 3)
    addlvwSHRY.SubItems(1) = rs!获得时间
    addlvwSHRY.SubItems(2) = rs!所获称号
    addlvwSHRY.SubItems(3) = rs!颁发单位
    rs.MoveNext
Loop
Call CloseConn
'END-----------------------------------------------------------



End Sub

Private Sub Form_Unload(Cancel As Integer)
If sx = True Then
    frmJCDA.cmdSSSSSSX = True '刷新frmJCDA的listview
    sx = False
End If
gXhcd = 0
End Sub



Private Sub Image1_DblClick()
If phoPath <> "" Then '双击以后用IE打开像片
    Shell "explorer.exe " & App.Path & phoPath & "", vbNormalFocus
End If
End Sub

Private Sub Text1_GotFocus(Index As Integer) 'text1失去焦点过程，combo运行过程
Select Case Index

Case Is = 5 '性别
        tFlag = 5
        Me.Combo1.Width = Me.Text1(5).Width
        Me.Combo1.Top = Me.Text1(5).Top
        Me.Combo1.Left = Me.Text1(5).Left
        Me.Combo1.Clear
        Me.Combo1.AddItem "男"
        Me.Combo1.AddItem "女"
        Me.Combo1.Visible = True
        'Me.Combo1.SetFocus
        
    Case Is = 6 '婚否
        tFlag = 6
        Me.Combo1.Width = Me.Text1(6).Width
        Me.Combo1.Top = Me.Text1(6).Top
        Me.Combo1.Left = Me.Text1(6).Left
        Me.Combo1.Clear
        Me.Combo1.AddItem "未婚"
        Me.Combo1.AddItem "已婚"
        Me.Combo1.Visible = True
        'Me.Combo1.SetFocus
        
    Case Is = 8 '民族
        tFlag = 8
        Call addCOM(tFlag, "民族")
        
    Case Is = 9 '政治面貌
        tFlag = 9
        Call addCOM(tFlag, "政治面貌")
        
    Case Is = 12 '职工类型
        tFlag = 12
        Call addCOM(tFlag, "职工类型")
        
        
    '------------------单位
    Case Is = 13
        tFlag = 13
        Me.Combo1.Width = Me.Text1(13).Width
        Me.Combo1.Top = Me.Text1(13).Top
        Me.Combo1.Left = Me.Text1(13).Left
        Me.Combo1.Clear
        Call OpenConn
        SQL = "select DISTINCT 单位名称 from 单位设置"
        rs.Open SQL, cn, 1, 1
            Do While Not rs.EOF
                Me.Combo1.AddItem rs!单位名称
                rs.MoveNext
            Loop
        Call CloseConn
        Me.Combo1.Visible = True
    
    Case Is = 14 '部门
        tFlag = 14
        Me.Combo1.Width = Me.Text1(14).Width
        Me.Combo1.Top = Me.Text1(14).Top
        Me.Combo1.Left = Me.Text1(14).Left
        Me.Combo1.Clear
        Call OpenConn
        SQL = "select * from 单位设置 where 单位名称='" & Me.Text1(13).Text & "' and root=1"
        rs.Open SQL, cn, 1, 1
            Do While Not rs.EOF
                Me.Combo1.AddItem rs!部门名称
                rs.MoveNext
            Loop
        Call CloseConn
        Me.Combo1.Visible = True
        
    Case Is = 19
        tFlag = 19
        Call addCOM(tFlag, "学历")
    
    Case Is = 20
        tFlag = 20
        Call addCOM(tFlag, "学历")
        
    Case Is = 22
        tFlag = 22
        Call addCOM(tFlag, "岗位")
        
    Case Is = 23
        tFlag = 23
        Call addCOM(tFlag, "岗别")
        
    Case Is = 24
        tFlag = 24
        Call addCOM(tFlag, "档次")
        
    Case Is = 25
        tFlag = 25
        Call addCOM(tFlag, "职务")
        
    Case Is = 26
        tFlag = 26
        Call addCOM(tFlag, "职称")
        
    Case Is = 27
        tFlag = 27
        Call addCOM(tFlag, "来源")
        
    Case Is = 28
        tFlag = 28
        Call addCOM(tFlag, "用工形式")
    
    Case Else
        Me.Combo1.Visible = False
End Select
End Sub

Private Sub Text1_LostFocus(Index As Integer) 'text1失去焦点后检查编号是否重复，格式化日期
Select Case Index

    Case Is = 0 '检查编号是否重复
        Call OpenConn
        SQL = "select 编号 from 基础档案表 where 编号='" & Me.Text1(0).Text & "'"
        rs.Open SQL, cn, 1, 1
            If rs.RecordCount > 0 Then
                
                msg = MsgBox("该编号已经存在，是否继续？", vbYesNo + 64, "提示")
                
                If msg = vbNo Then
                    Me.Text1(0).Text = ""
                    Me.Text1(0).SetFocus
                End If
                
            End If
        Call CloseConn

    Case Is = 11
        '~~~~~~~~~~日期格式~~~~~~~~~~~~~~~~
        If IsDate(Text1(11).Text) Then
           Text1(11).Text = Format(Text1(11).Text, "yyyy-mm-dd")
        Else
           Text1(11) = ""
        End If
        
    Case Is = 17
        If IsDate(Text1(17).Text) Then
           Text1(17).Text = Format(Text1(17).Text, "yyyy-mm-dd")
        Else
           Text1(17) = ""
        End If
           
    Case Is = 18
        If IsDate(Text1(18).Text) Then
           Text1(18).Text = Format(Text1(18).Text, "yyyy-mm-dd")
        Else
           Text1(18) = ""
        End If
        
    Case Is = 29
        If IsDate(Text1(29).Text) Then
           Text1(29).Text = Format(Text1(29).Text, "yyyy-mm-dd")
        Else
           Text1(29) = ""
        End If
        
    Case Is = 30
        If IsDate(Text1(30).Text) Then
           Text1(30).Text = Format(Text1(30).Text, "yyyy-mm-dd")
        Else
           Text1(30) = ""
        End If
End Select
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button) '按钮组
Select Case Button.Key
    Case Is = "tolXZ" '新增按钮
        Me.Frame1.Enabled = True
        For i = 0 To 31
            Me.Text1(i).Text = ""
        Next
        Me.Image1.Picture = LoadPicture(App.Path & "\bg\000.jpg")
        Me.Toolbar1.Buttons(1).Enabled = False '点击新增按钮后
        Me.Toolbar1.Buttons(3).Enabled = True
        
    Case Is = "tolXG" '修改按钮
        Me.Frame1.Enabled = True
        Me.Toolbar1.Buttons(2).Enabled = False
        Me.Toolbar1.Buttons(3).Enabled = True
        Me.Toolbar1.Buttons(4).Enabled = True
    
    Case Is = "tolBC" '保存按钮
        If Me.Text1(0).Text = "" Then
            MsgBox "保存失败,编号不能为空！", 48, "错误"
            Exit Sub
        End If
        If Me.Text1(1).Text = "" Then
            MsgBox "保存失败,姓名不能为空！", 48, "错误"
            Exit Sub
        End If
        If Me.Text1(12).Text = "" Then
            MsgBox "保存失败,职工类型不能为空！", 48, "错误"
            Exit Sub
        End If
        If Me.Text1(13).Text = "" Then
            MsgBox "保存失败,职工所在单位不能为空！", 48, "错误"
            Exit Sub
        End If
        If Me.Text1(14).Text = "" Then
            MsgBox "保存失效,职工所在部门不能为空！", 48, "错误"
            Exit Sub
        End If
        
        sx = True '是新增记录或是已经修改，需要刷新上一级窗体列表。
        
       If newFlag = 0 Then '如果是新记录
            Call OpenConn
            SQL = "select * from 基础档案表"
            rs.Open SQL, cn, 3, 3
            rs.AddNew
                For i = 0 To 31
                    rs.Fields(i + 1) = Me.Text1(i).Text
                Next
                rs!建档人 = Me.Text1(32).Text
                rs!像片 = phoPath
            rs.Update
            Call CloseConn
            phoPath = "" '清空像片路径
            Me.Frame1.Enabled = False
            MsgBox "记录添加成功！", 64, "提示"
            Me.Toolbar1.Buttons(1).Enabled = True
            Me.Toolbar1.Buttons(3).Enabled = False
        Else '如果是修改记录
             Call OpenConn
            SQL = "select * from 基础档案表 where zgid=" & gXhcd
            rs.Open SQL, cn, 3, 3
                For i = 0 To 31
                    rs.Fields(i + 1) = Me.Text1(i).Text
                Next
                rs!建档人 = gCzy
                rs!像片 = phoPath
            rs.Update
            Call CloseConn
            Me.Frame1.Enabled = False
            MsgBox "记录更新成功！", 64, "提示"
            Me.Toolbar1.Buttons(2).Enabled = True
            Me.Toolbar1.Buttons(3).Enabled = False
            Me.Toolbar1.Buttons(4).Enabled = False
        End If

        
    Case Is = "tolSC" '删除按钮
        msg = MsgBox("是否要删除该记录？", vbYesNo + 64, "提示")
        If msg = vbYes Then
            Call OpenConn
            cn.Execute ("delete * from 基础档案表 where zgid=" & gXhcd)
            Call CloseConn
            MsgBox "记录删除成功！", 64, "提示"
            Unload Me
        End If
    Case Is = "tolCSSZ" '参数设置按钮
        frmXTSZ.Show 1
        
    Case Is = "tolTC" '退出按钮
        Unload Me
End Select
End Sub


Private Sub addCOM(indexFlag As Integer, SQLxm As String) 'combo位置、项目设置过程
        Me.Combo1.Width = Me.Text1(indexFlag).Width
        Me.Combo1.Top = Me.Text1(indexFlag).Top
        Me.Combo1.Left = Me.Text1(indexFlag).Left
        Me.Combo1.Clear
        Call OpenConn
        SQL = "select * from 参数设置表 where 项目='" & SQLxm & "'"
        rs.Open SQL, cn, 1, 1
            Do While Not rs.EOF
                Me.Combo1.AddItem rs!值
                rs.MoveNext
            Loop
        Call CloseConn
        Me.Combo1.Visible = True
End Sub
VB ACCESS企事业人事及工资管理系统下载
VB ACCESS增删改查程序小例子下载
VB ACCESS中把子查询用作派生的表查询下载

Views: 7

Hi, I’m 邓伟

本来无一物，何处惹尘埃

近期文章

发表回复