VB常用代码总结（一）【转】

墨衍会员 · AI 创作全网分发码龄21年

关注

转载最新推荐文章于 2026-02-06 03:10:01 发布 1.1k 阅读 AI 写同款· GEO 优化 ›

Excel中汉字转拼音的VB代码 8、如果要去除拼音之间的空格。7、选中转换后的拼音需要放在哪个列，例如要把B列的第2行的内容转换成拼音，放在D列的第2个单元格，输入公式。”命令，插入一个新模块。再双击插入的模块，进入模块代码编辑状态；”组合键，进入Visual Basic编辑状态，灰色的编辑界面。1、打开要转换成拼音的excel表格。5、把下代码粘贴到步骤4中的空白处。以上代码中，可能缺少部分汉字。B2，是指源头单元格的坐标。返回Excel编辑状态。阅读详情

VB常用代码总结（一）【转】

移动无标题栏的窗体(borderstyle=none)
dim mouseX as integer
dim mouseY as integer
dim moveX as integer
dim moveY as integer
dim down as boolean
form_mousedown: 'mousedown事件
down=true
mouseX=x
mouseY=y
form_mouseup: 'mouseup事件
down=false
form_mousemove
if down=true then
   moveX=me.left-mouseX+X
   moveY=me.top-mouseY+Y
   me.move moveX,moveY
end if
*******************************
闪烁控件
比如要闪烁一个label（标签）
添加一个时钟控件间隔请根据实际需要设置 enabled属性设为true
代码为：label1.visible=not label1.visible

禁止使用 Alt+F4 关闭窗口
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Const MF_BYPOSITION = &H400&

Private Sub Form_Load()
Dim hwndMenu As Long
Dim c As Long
hwndMenu = GetSystemMenu(Me.hwnd, 0)

c = GetMenuItemCount(hwndMenu)

DeleteMenu hwndMenu, c - 1, MF_BYPOSITION

c = GetMenuItemCount(hwndMenu)
DeleteMenu hwndMenu, c - 1, MF_BYPOSITION
End Sub
*
启动控制面板大全
'打开控制面板
Call Shell("rundll32.exe shell32.dll,Control_RunDLL", 9)
'辅助选项属性-键盘
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1", 9)
'辅助选项属性-声音
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2", 9)
'辅助选项属性-显示
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3", 9)
'辅助选项属性-鼠标
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4", 9)
'辅助选项属性-常规
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5", 9)
'添加/删除程序属性-安装/卸载
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,1", 9)
'添加/删除程序属性-Windows安装程序
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,2", 9)
'添加/删除程序属性-启动盘
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,3", 9)
'显示属性-背景
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 9)
'显示属性-屏幕保护程序
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1", 9)
'显示属性-外观
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2", 9)
'显示属性-设置
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3", 9)
'Internet 属性-常规
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,0", 9)
'Internet 属性-安全
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,1", 9)
'Internet 属性-内容
Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,2", 9)
'Internet 属性-连接
Call Shell("rundll32.exe shell32.dll,Control_RunDLL I
*
怎样关闭一个程序
你可以使用API函数FindWindow和PostMessage来寻找一个窗口并且关闭它。下面的范例演示如何关闭一个标题为"Calculator"的窗口。
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "Calculator")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "Error posting message."
End If
Else
MsgBox "The Calculator is not open."
End If

For this code to work, you must have declared the API functions in a module in your project. You must put the following in the declarations section of the module.

Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Const WM_CLOSE = &H10
*
如何使Form的背景图随Form大小改变
单纯显示图形用Image即可,而且用Image也正好可解决你的问题
设定Image的Stretch=true
在加入以下的code
Private Sub Form_Resize()
Image1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub

或者使用以下的方式来做也可以

Private Sub Form_Paint()
Me.PaintPicture Me.Picture, 0, 0, ScaleWidth, ScaleHeight
End Sub
*
软件的注册
可用注册表简单地保存已用的天数或次数
'次数限制（如３０次）如下：
Private Sub Form_Load()
Dim RemainDay As Long
RemainDay = GetSetting("MyApp", "set", "times", 0)
If RemainDay = 30 Then
   MsgBox "试用次数已满，请注册"
   Unload Me
End If
MsgBox "现在剩下：" & 30 - RemainDay & "试用次数，好好珍惜！"
RemainDay = RemainDay + 1
SaveSetting "MyApp", "set", "times", RemainDay
End Sub

'时间限制的（如３０天）
Private Sub Form_Load()
Dim RemainDay As Long
RemainDay = GetSetting("MyApp", "set", "day", 0)
If RemainDay = 30 Then
    MsgBox "试用期已过，请注册"
    Unload Me
End If
MsgBox "现在剩下：" & 30 - RemainDay & "试用天数，好好珍惜！"
if day(now)-remainday>0 then RemainDay = RemainDay + 1
SaveSetting "MyApp", "set", "times", RemainDay
End Sub
*************************
MMControl控件全屏播放
Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" _
        Alias "mciSendStringA" (ByVal lpstrCommand As _
        String, ByVal lpstrReturnString As Any, ByVal _
        uReturnLength As Long, ByVal hwndCallback As _
        Long) As Long

Private Declare Function mciSendCommand Lib "winmm.dll" _
        Alias "mciSendCommandA" (ByVal wDeviceID As Long, _
        ByVal uMessage As Long, ByVal dwParam1 As Long, _
        dwParam2 As MCI_OVLY_RECT_PARMS) As Long

Private Declare Function GetShortPathName Lib "kernel32" _
        Alias "GetShortPathNameA" (ByVal lpszLongPath As _
        String, ByVal lpszShortPath As String, ByVal _
        cchBuffer As Long) As Long

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type MCI_OVLY_RECT_PARMS
dwCallback As Long
rc As RECT
End Type

Const MCI_OVLY_WHERE_SOURCE = &H20000
Const MCI_OVLY_WHERE_DESTINATION = &H40000
Const MCI_WHERE = &H843

Dim Play As Boolean

Private Sub Form_Load()
MMControl1.Wait = True
MMControl1.UpdateInterval = 50
MMControl1.hWndDisplay = Picture1.hWnd
Picture1.ScaleMode = 3
Timer1.Interval = 50
End Sub

Private Sub Form_Unload(Cancel As Integer)
MMControl1.Command = "stop"
MMControl1.Command = "close"
End Sub

Private Sub Command1_Click()
MMControl1.Command = "stop"
MMControl1.Command = "close"
Play = False

CommonDialog1.Filter = ("VB-Dateien (.avi)|.avi;")
CommonDialog1.InitDir = App.Path
CommonDialog1.ShowOpen

If CommonDialog1.filename <> "" Then
    MMControl1.DeviceType = "avivideo"
    MMControl1.filename = CommonDialog1.filename
    MMControl1.Command = "open"
    MMControl1.Notify = True
    Label4.Caption = MMControl1.Length

    If Check2.Value = vbChecked And Option2 Then
      Call AdaptPicture
    End If

    If Option3.Value Then Call Option3_Click
    Me.Caption = CommonDialog1.filename
End If
End Sub

Private Sub Command2_Click()
If Not Option3.Value Then
    If Play = False And MMControl1.filename <> "" Then
      MMControl1.Command = "play"
      Play = True
    End If
Else
    Call Option3_Click
End If
End Sub

Private Sub Command3_Click()
Play = False
MMControl1.Command = "stop"
End Sub

Private Sub Command4_Click()
MMControl1.Command = "pause"
End Sub

Private Sub MMControl1_Done(NotifyCode As Integer)
If Play And Check1.Value = vbChecked Then
    Play = False
    MMControl1.Command = "stop"
    MMControl1.Command = "prev"
    MMControl1.Command = "play"
    Play = True
End If
End Sub

Private Sub MMControl1_StatusUpdate()
Label2.Caption = MMControl1.Position
End Sub

Private Sub Option1_Click()
Check1.Enabled = True
Check2.Enabled = False
MMControl1.hWndDisplay = 0
End Sub

Private Sub Option2_Click()
Check1.Enabled = True
Check2.Enabled = True
MMControl1.hWndDisplay = Picture1.hWnd
End Sub

Private Sub Option3_Click()‘－－－－－－－－－－－注意这里
Dim R&, AA$
    Check1.Enabled = False
    Check2.Enabled = False
    MMControl1.Command = "stop"
    Play = False

    AA = Space$(255)
    R = GetShortPathName(CommonDialog1.filename, AA, Len(AA))
    AA = Mid$(AA, 1, R)
    R = mciSendString("play " & AA & " fullscreen ", 0&, 0, 0&)
End Sub

Private Sub Check2_Click()
If Check2.Value = vbChecked And MMControl1.filename <> "" Then
    Call AdaptPicture
End If
End Sub

Private Sub Timer1_Timer()
Dim x%, AA$
    x = MMControl1.Mode
    Select Case x
      Case 524: AA = "NotOpen"
      Case 525: AA = "Stop"
      Case 526: AA = "Play"
      Case 527: AA = "Record"
      Case 528: AA = "Seek"
      Case 529: AA = "Pause"
      Case 530: AA = "Ready"
    End Select
    Label6.Caption = AA
End Sub

Private Sub AdaptPicture()
Dim Result&, Par As MCI_OVLY_RECT_PARMS

    Par.dwCallback = MMControl1.hWnd
    Result = mciSendCommand(MMControl1.DeviceID, _
             MCI_WHERE, MCI_OVLY_WHERE_SOURCE, Par)
    If Result <> 0 Then
      MsgBox ("Fehler")
    Else
      Picture1.Width = (Par.rc.Right - Par.rc.Left) * 15 + 4 * 15
      Picture1.Height = (Par.rc.Bottom - Par.rc.Top) * 15 + 4 * 15
    End If
End Sub
******************************************************************
通用对话框专辑（全）
使用API调用Winodws各种通用对话框(Common Diaglog)的方法（一）

1.文件属性对话框
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long '可选参数
lpClass As String '可选参数
hkeyClass As Long '可选参数
dwHotKey As Long '可选参数
hIcon As Long '可选参数
hProcess As Long '可选参数
End Type

Const SEE_MASK_INVOKEIDLIST = &HC
Const SEE_MASK_NOCLOSEPROCESS = &H40
Const SEE_MASK_FLAG_NO_UI = &H400

Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" _
(SEI As SHELLEXECUTEINFO) As Long
Public Function ShowProperties(filename As String, OwnerhWnd As Long) As Long
'打开指定文件的属性对话框,如果返回值<=32则出错
Dim SEI As SHELLEXECUTEINFO
Dim r As Long
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = OwnerhWnd
.lpVerb = "properties"
.lpFile = filename
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
End With
r = ShellExecuteEX(SEI)
ShowProperties = SEI.hInstApp
End Function

新建一个工程,添加一个按钮和名为Text1的文本框
把以下代码置入CommandbButton_Click 中
Dim r As Long
Dim fname As String
'从Text1 中获取文件名及路径
fname = (Text1)
r = ShowProperties(fname, Me.hwnd)
If r <= 32 Then MsgBox "Error"

2.使用Win95的关于对话框
Private Declare Function ShellAbout Lib "shell32.dll" _
Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, _
ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
示例:
Dim x As Long
x = shellabout (Form1.hwnd, "Visual Basic 6.0", _
"Alp Studio MouseTracker Ver 1.0", Form1.icon)

2.调用"捕获打印机端口"对话框
Private Declare Function WNetConnectionDialog Lib "mpr.dll" _
(ByVal hwnd As Long, ByVal dwType As Long) As Long
示例:
Dim x As Long
x = WNetConnectionDialog(Me.hwnd, 2)

3.调用颜色对话框
Private Type ChooseColor
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long

将以下代码置入某一事件中:
Dim cc As ChooseColor
Dim CustColor(16) As Long
cc.lStructSize = Len(cc)
cc.hwndOwner = Form1.hWnd
cc.hInstance = App.hInstance
cc.flags = 0
cc.lpCustColors = String$(16 * 4, 0)
Dim a
Dim x
Dim c1
Dim c2
Dim c3
Dim c4
a = ChooseColor(cc)
Cls
If (a) Then
MsgBox "Color chosen:" & Str$(cc.rgbResult)

For x = 1 To Len(cc.lpCustColors) Step 4
c1 = Asc(Mid$(cc.lpCustColors, x, 1))
c2 = Asc(Mid$(cc.lpCustColors, x + 1, 1))
c3 = Asc(Mid$(cc.lpCustColors, x + 2, 1))
c4 = Asc(Mid$(cc.lpCustColors, x + 3, 1))
CustColor(x / 4) = (c1) + (c2 * 256) + (c3 * 65536) + (c4 * 16777216)
MsgBox "Custom Color " & Int(x / 4) & " = " & CustColor(x / 4)
Next x
Else
MsgBox "Cancel was pressed"
End If

4.调用复制磁盘对话框
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

示例:
向窗体中添加一个名为Drive1的DriveListBox,将以下代码置入某一事件中
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg&
DriveLetter = UCase(Drive1.Drive)
DriveNumber = (Asc(DriveLetter) - 65)
DriveType = GetDriveType(DriveLetter)
If DriveType = 2 Then 'Floppies, etc
RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " _
& DriveNumber & "," & DriveNumber, 1) 'Notice space after
Else ' Just in case 'DiskCopyRunDll
RetFromMsg = MsgBox("Only floppies can" & vbCrLf & _
"be diskcopied!", 64, "DiskCopy Example")
End If

5.调用格式化软盘对话框
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
参数设置:
fmtID-
3.5" 5.25"
-------------------------
0 1.44M 1.2M
1 1.44M 1.2M
2 1.44M 1.2M
3 1.44M 360K
4 1.44M 1.2M
5 720K 1.2M
6 1.44M 1.2M
7 1.44M 1.2M
8 1.44M 1.2M
9 1.44M 1.2M

选项
0 快速
1 完全
2 只复制系统文件
3 只复制系统文件
4 快速
5 完全
6 只复制系统文件
7 只复制系统文件
8 快速
9 完全
示例:要求同上
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg%
DriveLetter = UCase(Drive1.Drive)
DriveNumber = (Asc(DriveLetter) - 65) ' Change letter to Number: A=0
DriveType = GetDriveType(DriveLetter)
If DriveType = 2 Then 'Floppies, etc
RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Else
RetFromMsg = MsgBox("This drive is NOT a removeable" & vbCrLf & _
"drive! Format this drive?", 276, "SHFormatDrive Example")
Select Case RetFromMsg
Case 6 'Yes
' UnComment to do it...
'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Case 7 'No
' Do nothing
End Select
End If
-----------------------------------------------------------------------------

收录于

vb老鸟

标签

#vb #shell #function #string #internet

VB.NET转C#代码转换工具实操指南本文还有配套的精品资源，点击获取简介：本文介绍了"VB.NET to C# Converter"工具的重要性和应用，该工具能够高效地将VB.NET代码自动转换为C#代码，保留变量名和注释，减少开发者的转换工作量。VB.NET和C#作为.NET平台上的两种语言，各有特点，其中C#在现代编程领域具有广泛应用。工具支持试用版和完整版，试用版可永久使用但处理代码行数有限。详细操作... 阅读详情

0

杨哥儿

博客等级

码龄21年 217粉丝 17原创

+ 关注专栏目录订阅专栏

评论

成就一亿技术人!

拼手气红包6.0元

还能输入1000个字符

插入表情

表情包

代码片

HTML/XML
objective-c
Ruby
PHP
C
C++
JavaScript
Python
Java
CSS
SQL
其它

条评论被折叠查看

被折叠的条评论为什么被折叠?

到【灌水乐园】发言

查看更多评论

添加红包

成就一亿技术人!

hope_wisdom

发出的红包

实付元

使用余额支付

点击重新获取

扫码支付

钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。