您的位置: 首页 > 源码资料

更多

vb6(visual basic)常用代码及说明收集

源码资料 时间:2015-03-31 作者/发布人:科杰在线 点击:5213

VB6最大化、最小化命令

Me.WindowState = 0  '0为普通,1为最小,2为最大

当窗口大小化时发生事件
Private Sub Form_Resize() '

如果父窗体被最小化发生事件
If Form1.WindowState = vbMinimized Then

★文本框自动剔除常用符号及空格,只保留汉字及数字的VB代码


'数字0-9 的Ascii码是 48-57
'字母A-Z 的Ascii码是 65-90 小写字母是 97-122 (下面代码是使用Ucase函数转为大写,所以我97-122从缺)
'汉字 16进制区间 B0A1-F7FE B=66 F=70(下面代码是使用16进制码的第一位,其它英文字,数字与符号的16进制第一码不会在B-F之间)
'添加 Command1
Dim i%, h$, aa$, bb$
Private Sub Command1_Click()
aa = "科!@#杰!@#¥在@!@#@线"
bb = ""
For i = 1 To Len(aa)
h = Hex(Asc(Mid(aa, i, 1)))
If (Asc(Left(h, 1)) >= 66 And Asc(Left(h, 1)) <= 70) Or (Asc(Mid(UCase(aa), i, 1)) >= 65 And Asc(Mid(UCase(aa), i, 1)) <= 90) Or (Asc(Mid(UCase(aa), i, 1)) >= 48 And Asc(Mid(UCase(aa), i, 1)) <= 57) Then
bb = bb & Mid(aa, i, 1)
End If
Next i
MsgBox bb
End Sub

VB6的文本框只能输入数字和VB只能输入一小小数点的方法

Private Sub Text1_KeyPress ( KeyAscii As Integer )  
      If KeyAscii > =   Asc ( "0" )   And KeyAscii < =   Asc ( "9" )   Or KeyAscii   =   8 Or KeyAscii   =   Asc ( "." )   Then
            If KeyAscii   =   Asc ( "." )   And InStr ( 1, Text1.Text, ".", vbTextCompare )   > 0 Then
                  KeyAscii   =   0
            End If
            If Text1.SelStart > =   Len ( Text1.Text )   - 2 And _
                  InStr ( 1, Text1.Text, ".", vbTextCompare )   > 0 And _
                  Len ( Text1.Text )   - InstrRev ( Text1.Text, ".", Len ( Text1.Text ) , vbTextCompare )   > =   2 And _
                  KeyAscii <> 8 Then
                   
                  KeyAscii   =   0
            End If
      Else
            KeyAscii   =   0
      End If
End Sub

更强大更实用的限制文本框只能输入特定字符的方法


调用方法

http://pan.baidu.com/share/link?shareid=214382&uk=1711549925


★VB文本框保留小数点后3位

x = Text2.Text
Text1.Text = Format(x, "0.000")

★vb窗口置顶代码

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const SWP_NOMOVE = &H2 '不更动目前视窗位置
Const SWP_NOSIZE = &H1 '不更动目前视窗大小
Const HWND_TOPMOST = -1 '设定为最上层
Const HWND_NOTOPMOST = -2 '取消最上层设定
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Private Sub Form_Load()
If App.PrevInstance = True Then End '防止程序重复运行
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS '窗口置顶
End Sub

★visual Basic 6 如何给窗体窗口加上透明度

'窗口透明度声明开始
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
'窗口透明度声明结束
'窗体透明度开始
Private Sub Form_Activate()
On Error Resume Next
    For i = 0 To 200 Step 5     '0-200是窗体的透明度.从0开始到150.渐渐出现窗体.步长为5
        SetLayeredWindowAttributes Me.hwnd, 0, i, LWA_ALPHA
        DoEvents
    Next i
End Sub   '窗体透明度结束

 
Private Sub Form_Load()
'窗体透明度开始
 Dim rtn As Long
    rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
    rtn = rtn Or WS_EX_LAYERED
    SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn
    SetLayeredWindowAttributes Me.hwnd, 0, 0, LWA_ALPHA
'窗体透明度结束
End Sub

★用vb访问网址的方法

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Sub pc354()
webpc354 = Text1.Text
Call ShellExecute(Me.hwnd, "open", webpc354, "", "", SW_SHOW)
End Sub
Private Sub Command1_Click()
pc354
End Sub

VB点击文本框自动全选文本

Text1.SelStart = 0
Text1.SelLength = Len(Text1)

怎样计算文件夹下txt文件的个数?

'添加Text1 Command1
'本代码不侦测下一层的文件夹,就只搜你在text1里输入的路径.
Private Sub Form_Load()
 Text1.Text = "c:\"
End Sub
Private Sub Command1_Click()
 On Error Resume Next
 Dim sSave As String, Ret As Long, r As Long, rtn As Long, kk As Long
 Dim fol, fso, fil, fils, s, f, fldr
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set fldr = fso.GetFolder(Text1.Text)
 Set fils = fldr.Files
 kk = 0
 Me.Cls
 For Each fil In fils
 s = s & fil.Name
 aa = midstr & "\" & fil.Name
 If UCase(Right(aa, 3)) = "TXT" Then
 songname = aa
 i = InStrRev(songname, "\")
 If i > 0 Then
 bb = Mid(songname, i + 1) ' 获取文件名
 Print bb
 kk = kk + 1
 End If
 End If
 Next
 MsgBox "共有" & Str(kk) & " 个.txt的文件"
End Sub

批量给控件组定义颜色

Private Sub Form_Load()
For ii = 1 To 88
Text1(ii).BackColor = vbWhite
Next
End Sub

将文本文件加载到文本框控件数组中

'建一个按钮,一个文本框,然后复制这个文本框成数组,文本内容有几行,就要复制几个文本框
Private Sub Command1_Click()
Open "c:\1.txt" For Input As #1
Dim i As Integer, s As String
While Not EOF(1)
  Line Input #1, s
  i = i + 1
  Text1(i).Text = s
Wend
Close #1
End Sub

在窗体任意位置点鼠标左键可以拖动窗体

Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim ReturnVal As Long
    X = ReleaseCapture()
    ReturnVal = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End Sub

程序窗体没有标题栏,却能在任务栏显示程序名称的方法

  把VB窗体fomr1的boderstyle属性设置为0-none,同时把form1的showintaskbar属性设置为TRUE

让按钮不再显示出难看的虚线

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_KILLFOCUS = &H8 '使按钮失去焦点
Private Sub Form_Activate() 
  Command1_Click
End Sub
Private Sub Command1_Click()
  MsgBox "科杰在线pc354.com"
  SendMessage Command1.hwnd, WM_KILLFOCUS, 0, 0 '使按钮失去焦点
End Sub

VB在退出后可以自动保存窗体大小和位置,下次打开时保持

Private Sub Form_Load()
    Me.Width = GetSetting(App.Title, Me.Name, "Width", 7200)
    Me.Height = GetSetting(App.Title, Me.Name, "Height", 6300)
    Me.Top = GetSetting(App.Title, Me.Name, "Top", 100)
    Me.Left = GetSetting(App.Title, Me.Name, "Left", 100)
   
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Call SaveSetting(App.Title, Me.Name, "Width", Me.Width)
    Call SaveSetting(App.Title, Me.Name, "Height", Me.Height)
    Call SaveSetting(App.Title, Me.Name, "Top", Me.Top)
    Call SaveSetting(App.Title, Me.Name, "Left", Me.Left)
End Sub
 
科杰在线pc354.com收集整理,转载请注明出处,谢谢
最后修改日期:2015.1.30 12:00
--------------------------全文完----------------------------
0% (0)
0% (0)
整站字母快速检索: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1 2 3 4 5 6 7 8 9 0

综合报道 经济形势 劳动就业 政策法规 热点推荐 创业新闻 创业指导 创业课堂 创业故事 大学生创业 | 装修日记 | 学驾驶经历 | 免费信息发布 | 网站地图

地址:合肥市临泉路香格里拉花园 邮箱:pc354@163.com QQ:55769640 | 皖ICP备06007228号 
版权所有:科杰服务(www.pc354.com) 建议使用IE7.0或以上版本,最少1280分辨率浏览本站,可获得最佳浏览效果

飞到顶部