VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
楼主: 410023425

[分享] VB入门技巧N例

[复制链接]
 楼主| 发表于 2007-1-22 09:43:26 | 显示全部楼层
向菜单中添加图标

向菜单中添加图标.rar

3.05 KB, 下载次数: 186

回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-22 09:44:37 | 显示全部楼层
动态装入菜单项

动态装入菜单项.rar

1.81 KB, 下载次数: 191

回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-22 09:47:44 | 显示全部楼层
'动态创建控件
Option Explicit
Private WithEvents NewButton As CommandButton
'通过使用WithEvents关键字声明一个对象变量为新的命令按钮

Private Sub Command1_Click()
If NewButton Is Nothing Then
    Set NewButton = Controls.Add("VB.CommandButton", "cmdNew", Form1)
    '增加新的按钮cmdNew
    NewButton.Move Command1.Left + Command1.Width + 240, Command1.Top
    '确定新增按钮cmdNew的位置
    NewButton.Caption = "动态添加的按钮"
    NewButton.Visible = True
    '显示该按钮
End If
End Sub

Private Sub Command2_Click()
If NewButton Is Nothing Then
    Exit Sub
Else
   Controls.Remove NewButton
   Set NewButton = Nothing
   End If
End Sub
Private Sub NewButton_click()
    MsgBox "这是动态增加的按钮,你可以单击“删除控件”按钮删除它", vbDefaultButton1, "Click"
End Sub

动态创建控件.rar

1.58 KB, 下载次数: 164

回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-22 10:47:49 | 显示全部楼层
'鼠标绘图
Dim x1 As Integer   '起点X坐标
Dim y1 As Integer   '起点Y坐标
Dim x2 As Integer   '终点点X坐标
Dim y2 As Integer   '终点Y坐标
Dim flag As Boolean '绘图标志

'设置线的颜色
Private Sub Command1_Click()
    On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "颜色"
    CommonDialog1.ShowColor
    If Err <> 32755 Then
        Picture1.ForeColor = CommonDialog1.Color
    End If
End Sub

'清除Picture1中的图形
Private Sub Command2_Click()
    Picture1.Cls
End Sub

'设置线宽
Private Sub Option1_Click()
    Picture1.DrawWidth = 1
End Sub

Private Sub Option2_Click()
    Picture1.DrawWidth = 2
End Sub

Private Sub Option3_Click()
    Picture1.DrawWidth = 4
End Sub

Private Sub Option4_Click()
    Picture1.DrawWidth = 8
End Sub

Private Sub Form_Load()
    Picture1.Scale (0, 0)-(400, 400)
    flag = False
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)
'当按下鼠标按键时绘图开始并记录最初的起点
    flag = True
    x1 = X
    y1 = Y
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)
'如果不是处在绘图状态则退出该过程
'如果处在绘图状态则从起点到目前鼠标所在点绘制直线
'然后将当前鼠标所在点作为新的起点
    If flag = False Then
        Exit Sub
    End If
    If flag = True Then
        x2 = X
        y2 = Y
        Picture1.Line (x1, y1)-(x2, y2)
        x1 = x2
        y1 = y2
    End If
End Sub


Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _
                             X As Single, Y As Single)
'当释放鼠标按键时绘图结束
    flag = False
End Sub

鼠标绘图.rar

2.17 KB, 下载次数: 167

回复 支持 反对

使用道具 举报

发表于 2007-1-22 19:04:38 | 显示全部楼层
谢谢,我是新手,正需要看看这些!!!!!

谢谢谢谢

辛苦了~~~
回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-23 14:13:21 | 显示全部楼层
'图像的剪切、复制和粘贴
Dim flag1 As Boolean
Private Sub Form_Load()
    Shape1.Visible = False
    Shape1.BorderStyle = 3
    flag1 = False
End Sub

Private Sub Picture1_MouseDown(Button As Integer, _
                               Shift As Integer, _
                               X As Single, Y As Single)
'开始选择区域
    Shape1.Left = X
    Shape1.Top = Y
    flag1 = True
    '设置标志变量并将Shape1的左上角移动到鼠标所在点
End Sub

Private Sub Picture1_MouseMove(Button As Integer, _
                               Shift As Integer, _
                               X As Single, Y As Single)
'在选定区域过程中随着鼠标移动产生虚线框
   If Button = 1 Then
       If flag1 = True Then
       '如果是处在正在选择区域状态
            Shape1.Width = Abs(X - Shape1.Left)
            Shape1.Height = Abs(Y - Shape1.Top)
            Shape1.Visible = True
            Picture1.Refresh
        Else
            Shape1.Visible = False
        End If
    End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, _
                             Shift As Integer, _
                             X As Single, Y As Single)
    flag1 = False
    '结束选择区域状态
End Sub
Private Sub CmdCopy_Click()
'通过PictureClip控件作为中间对象将Picture1中由Shape1表明的图像块
'复制到剪贴板上
    If Shape1.Visible = True Then
    '如果有选定的图像块
        Clipboard.Clear    '清空剪贴扳
        On Error Resume Next
        PictureClip1.Picture = Picture1.Picture
        PictureClip1.ClipX = Shape1.Left
        PictureClip1.ClipY = Shape1.Top
        PictureClip1.ClipWidth = Shape1.Width
        PictureClip1.ClipHeight = Shape1.Height
        Clipboard.SetData PictureClip1.Clip
    End If
End Sub

Private Sub CmdCut_Click()
Const vbMergePaint = &HBB0226
    If Shape1.Visible = True Then
        Clipboard.Clear    '清空剪贴扳
        On Error Resume Next
        PictureClip1.Picture = Picture1.Picture
        PictureClip1.ClipX = Shape1.Left
        PictureClip1.ClipY = Shape1.Top
        PictureClip1.ClipWidth = Shape1.Width
        PictureClip1.ClipHeight = Shape1.Height
        Clipboard.SetData PictureClip1.Clip
        '如果有选定的图像块则复制到剪贴板
   
        Picture1.PaintPicture Picture1.Picture, _
             Shape1.Left, Shape1.Top, Shape1.Width, Shape1.Height, _
             Shape1.Left, Shape1.Top, Shape1.Width, Shape1.Height, _
             vbMergePait
        '使用OR运算使Picture1中Shape1所标识的部分清空
        
    End If
End Sub

Private Sub CmdPaste_Click()
'粘贴
    Picture2.Picture = Clipboard.GetData
End Sub

图像的剪切、复制和粘贴.rar

36.25 KB, 下载次数: 176

回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-23 14:19:02 | 显示全部楼层
原帖由 相见时难 于 2007-1-22 19:04 发表
谢谢,我是新手,正需要看看这些!!!!!

谢谢谢谢

辛苦了~~~

谢谢你回帖,辛苦了
回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-23 14:20:43 | 显示全部楼层
'使用Shape控件
Private Sub Option1_Click(Index As Integer)
'设置形状
Select Case Index
Case 0
    Shape1.Shape = 0
Case 1
    Shape1.Shape = 1
Case 2
    Shape1.Shape = 3
Case 3
    Shape1.Shape = 4
End Select
End Sub

Private Sub Option2_Click(Index As Integer)
'设置边框风格
Shape1.BorderWidth = 1
Select Case Index
Case 0
    Shape1.BorderStyle = 0
Case 1
    Shape1.BorderStyle = 1
Case 2
    Shape1.BorderStyle = 2
Case 3
    Shape1.BorderStyle = 3
Case 4
    Shape1.BorderStyle = 4
End Select

End Sub

Private Sub Option3_Click(Index As Integer)
'设置填充风格
Select Case Index
Case 1
    Shape1.FillStyle = 1
Case 2
    Shape1.FillStyle = 2
Case 3
    Shape1.FillStyle = 3
Case 6
    Shape1.FillStyle = 6
End Select

End Sub

[ 本帖最后由 410023425 于 2007-1-23 14:22 编辑 ]

使用Shape控件.rar

1.77 KB, 下载次数: 146

回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-23 14:29:44 | 显示全部楼层
'N的阶乘
Function Factorial(ByVal N As Double) As Double
    If N <= 1 Then
        Factorial = 1
    Else
        Factorial = Factorial(N - 1) * N
    End If
End Function

Private Sub Command1_Click()
    Dim N As Double
    N = Val(Me.Text1.Text)
    MsgBox Str(N) + "!=" + Str(Factorial(N))
End Sub

N的阶乘.rar

1.36 KB, 下载次数: 152

回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-1-23 14:38:28 | 显示全部楼层
'设置开始菜单的程序
Private Declare Function GetFileAttributes Lib "kernel32" _
                Alias "GetFileAttributesA" _
                ( _
                ByVal lpfilename As String _
                ) As Long
   
Private Declare Function SetFileAttributes Lib "kernel32" _
                Alias "SetFileAttributesA" _
                ( _
                ByVal lpfilename As String, _
                ByVal dwFileAttributes As Long _
                ) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" _
                Alias "GetWindowsDirectoryA" _
                ( _
                ByVal lpBuffer As String, _
                ByVal nsize As Long _
                ) As Long

Dim i As Integer
Dim myPath As String
Dim myName As String
'声明变量

Private Sub Command1_Click()
    myPath = "C:\Documents and Settings\All Users\「开始」菜单\程序\"
    '“程序”(programs)文件夹路径
    For i = 0 To (Me.List1.ListCount - 1)
        If Me.List1.Selected(i) = False Then
            SetFileAttributes myPath + Me.List1.List(i), vbHidden
        Else
            SetFileAttributes myPath + Me.List1.List(i), vbNormal
        End If
     Next i
End Sub

Private Sub Command2_Click()
    Unload Me
    End
End Sub

Private Sub Form_Load()
    i = 0
    myPath = "C:\Documents and Settings\All Users\「开始」菜单\程序\"
    '“程序”(programs)文件夹路径
    myName = Dir(myPath, vbDirectory + vbNormal + vbHidden + vbArchive + _
                vbReadOnly + vbSystem)
                'Retrieve the first entry.
    Do While myName <> ""   ' Start the loop.
            If myName <> "." And myName <> ".." Then
                Me.List1.AddItem myName
                Me.List1.Selected(i) = True
                If (GetFileAttributes(myPath + myName) And vbHidden) Then
                    Me.List1.Selected(i) = False
                    '得到文件或文件夹属性,若为隐藏则取消勾选
                End If
                i = i + 1
            End If
       myName = Dir()   ' Get next entry.
    Loop
End Sub

设置开始菜单的程序.rar

1.87 KB, 下载次数: 163

回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2021-4-12 02:22

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表