VB程序学习代码记录20160724

为工具栏添加事件代码

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
        Case "add"
        Case "modify"
        Case "delete"
        Case "save"
        Case "cancel"
        Case "find"
        Case "close"
    End Select
End Sub

状态栏设置时间日期

Private Sub Timer1_Timer()
    StatusBar1.Panels(1).Text = Format(Date, "YYYY-MM-DD")
    StatusBar1.Panels(2).Text = Format(Time, "hh:mm")
End Sub

状态栏实例

Private Sub Command1_Click()
    Form2.Hide
    Form1.Show
End Sub
Private Sub Text1_Change()
    If Text1.Text <> "" Then
        StatusBar1.Panels(2).Text = "当前用户为:" & Text1.Text
    Else
        MsgBox "请输入用户名！", vbCritical, "信息提示"
    End If
End Sub
Private Sub Timer1_Timer()
    StatusBar1.Panels(3).Text = Format(Date, "YYYY年MM月DD日") & Format(Now, "hh点mm分ss秒")
End Sub

工具栏实例

Private Sub Command1_Click()
    Form1.Hide
    Form2.Show
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
    Case "add"   '添加
        MsgBox "单击“添加”按钮！", vbInformation, "信息提示"
    Case "modify"    '修改
        MsgBox "修改“添加”按钮！", vbInformation, "信息提示"
    Case "delete"    '删除
        MsgBox "单击“删除”按钮！", vbInformation, "信息提示"
    Case "save"   '保存
        MsgBox "单击“保存”按钮！", vbInformation, "信息提示"
    Case "cancel"  '取消
        MsgBox "单击“取消”按钮！", vbInformation, "信息提示"
    Case "find"   '找找
        MsgBox "单击“查找”按钮！", vbInformation, "信息提示"
    Case "dyt"     '移到第一条记录
        MsgBox "单击“第一条”按钮！", vbInformation, "信息提示"
    Case "syt"     '移到上一条记录
        MsgBox "单击“第二条”按钮！", vbInformation, "信息提示"
    Case "xyt"    '移到下一条记录
        MsgBox "单击“下一条”按钮！", vbInformation, "信息提示"
    Case "myt"     '移到最后一条记录
        MsgBox "单击“末一条”按钮！", vbInformation, "信息提示"
    Case "close"
        Unload Me
    End Select
End Sub

公用对话框（打开文件）

Private Sub Command1_Click()
    CommonDialog1.Filter = "bmp图片(*.BMP)|*.BMP|JPG 图片(*.JPG|*.JPG|GIF 图片(*.GIF(|*.GIF|所有文件(*.*)|*.*"
    CommonDialog1.Action = 1
    Text1.Text = CommonDialog1.FileTitle
    Text2.Text = CommonDialog1.FileName
End Sub

公用对话框（保存文件）

Private Sub Command3_Click()
    CommonDialog1.DialogTitle = "保存纯文本文件"
    CommonDialog1.Filter = "文本文件|*.txt"
    CommonDialog1.InitDir = "E:\"
    CommonDialog1.Action = 2
    If CommonDialog1.FileName <> "" Then
        Open CommonDialog1.FileName For Output As #1
        Print #1, Text1.Text
        Close #1
    End If
End Sub

公用对话框（颜色对话框）

Private Sub Command4_Click()
    CommonDialog1.Action = 3
    Text1.BackColor = CommonDialog1.Color
End Sub

公共对话框（字体对话框）

Private Sub Command5_Click()
    CommonDialog1.Flags = 3
    CommonDialog1.Action = 4
    If CommonDialog1.FontName <> "" Then
        Text1.FontName = CommonDialog1.FontName
    End If
    Text1.FontSize = CommonDialog1.FontSize
    Text1.FontBold = CommonDialog1.FontBold
    Text1.FontItalic = CommonDialog1.FontItalic
End Sub

公用对话框（打印）

Private Sub Command6_Click()
    'CommonDialog1.Action = 5
    CommonDialog1.ShowPrinter
End Sub

公共对话框实例

Private Sub Command1_Click()
    CommonDialog1.Action = 1
    CommonDialog1.Filter = "TXT文件(*.txt)|*.txt"
    Text1.Text = CommonDialog1.FileTitle
    Text2.Text = CommonDialog1.FileName
End Sub
Private Sub Command2_Click()
    CommonDialog1.ShowColor
    Text1.BackColor = CommonDialog1.Color
End Sub
Private Sub Command3_Click()
    CommonDialog1.ShowFont
    Text1.FontSize = CommonDialog1.FontSize
    Text1.FontBold = CommonDialog1.FontBold
    Text1.FontItalic = CommonDialog1.FontItalic
End Sub

编写程序自动注册

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Const max_path = 260
Private Const max_path1 = 261
Dim sysdir As String

Private Sub form_activate()
    On Error GoTo orroelink
    Dim retval, retval1, retval2
    Dim chrlen As Long
    Dim windir As String, mypath As String, a1 As String, a2 As String
    sysdir = Space(max_path)
    chrlen = GetSystemDirectory(sysdir, max_path)
    If chrlen = max_path Then chrlen = GetSystemDirectory(sysdir, max_path)
    sysdir = Left(sysdir, chrlen)
    Shell ("regsvr32 /s" & sysdir & "\Scrrun.dll 开启")
    a1 = Dir(sysdir & "\Flash.ocx")
    If a1 = "" Then
        FileCopy App.Path & "\link\Flash.ocx", sysdir & "\Flash.ocx"
        Shell ("regsvr32 /s" & sysdir & "\flash.ocx")
    End If
    a2 = Dir(sysdir & "\MCI32.OCX")
    If a2 = "" Then
        FileCopy App.Path & "\link\MCI32.OCX", sysdir & "\MCI32.OCX"
        Shell ("regsvr32 /s " & sysdir & "\MCI32.OCX")
    End If
    Exit Sub
orroelink:
    MsgBox Err.Description, vbOKOnly, "提示信息"
End Sub

图像列表控件

Private Sub Form_Load()
    ImageList1.ListImages.Add , "gz", LoadPicture("C:\Users\Qi\Desktop\VB_ICO图标\apply.ico")
    Set Form1.Icon = ImageList1.ListImages(1).Picture
End Sub

与listview控件关联

Private Sub Form_Load()
    Set TreeView1.ImageList = ImageList1
    TreeView1.Nodes.Add , , "a1", "员工1", "yg"
End Sub