VB程序代码(简单小程序)

VB小程序

1、VB定时器'*************************************************************'新建一个窗体，放两个控件：label和timer'*************************************************************Public hor As LongPublic minu, sec As IntegerPrivate Sub Form_Load()'设置计时器时间间隔为1秒。

'考虑到Sub Timer1_Timer()中判断等操作要花时间，所以Timer1.Interval设为994 Timer1.Interval = 994Dim longTime, tmp As Long'********************************longTime = 65'时间值，要你自己从数据库取，我就不写了！'********************************'初始化显示时间hor = CLng(longTime / 3600 - 0.5)'小时数tmp = longTime - 3600 * hor '剩余秒数minu = CLng(tmp / 60 - 0.5) '分钟数tmp = tmp - 60 * minu'剩余秒数sec = tmp'秒数Label1.Caption = CStr(hor) + ":" + Format(CStr(minu), "##00") + ":" + Format(CStr(sec), "##00") End SubPrivate Sub Timer1_Timer()If sec = 0 ThenIf minu = 0 ThenIf hor = 0 ThenExit SubElsehor = hor - 1End Ifminu = 59Elseminu = minu - 1sec = 59End IfElsesec = sec - 1End IfLabel1.Caption = CStr(hor) + ":" + Format(CStr(minu), "##00") + ":" + Format(CStr(sec), "##00") End Sub2、VB倒计时Dim h, m, s As IntegerPrivate Sub Command1_Click()Label1.Visible = FalseText1.Visible = TrueIf Command1.Caption = "倒计时" Then Timer1.Enabled = TrueCommand1.Caption = "停止"Command2.Enabled = FalseElseTimer1.Enabled = FalseCommand1.Caption = "倒计时"Command2.Caption = "重设倒计时" Command2.Enabled = TrueEnd IfEnd SubPrivate Sub Command2_Click()If Command2.Caption = "重设倒计时" Then Call againCommand1.Enabled = TrueEnd IfEnd SubPrivate Sub Command3_Click()a = MsgBox("你确定要退出嗎")EndEnd SubPrivate Sub Form_Load()ClsText1.Text = ""a = MsgBox("以下是一個倒計時程序,請按以下要求輸入你要倒计的时间")h = Val(InputBox("请输入倒计时的,小時数,若无填0", "小時/输入", 0))m = Val(InputBox("请输入倒计时的,分钟数,若无填0", "小時/输入", 0))s = Val(InputBox("请输入倒计时的,秒数,若无填0", "小時/输入", 0))Label1.Caption = "你输入的时间是:" & Format(h, "00") & ":" & Format(m, "00") & ":" & Format(s, "00") & "如果沒有错误请点击倒计时按纽"Text1.Visible = FalseEnd SubPrivate Sub Timer1_Timer()If s > 0 Thens = s - 1End IfIf s < 1 And m > 0 Thenm = m - 1s = 60End IfIf m < 1 And s = 0 And h > 0 Thenh = h - 1m = 60End IfIf h < 0 Thenh = 0End IfIf m < 0 Thenm = 0End IfText1.Text = Format(h, "00") & ":" & Format(m, "00") & ":" & Format(s, "00")If h = 0 And m = 0 And s = 0 ThenText1.Text = "時間到了"Command1.Caption = "倒计时"Command1.Enabled = FalseTimer1.Enabled = FalseCommand2.Enabled = TrueEnd IfEnd SubSub again()ClsText1.Text = ""a = MsgBox("以下是一個倒計時程序,請按以下要求輸入你要倒计的时间")h = Val(InputBox("请输入倒计时的,小時数,若无填0", "小時/输入", 0))m = Val(InputBox("请输入倒计时的,分钟数,若无填0", "小時/输入", 0))s = Val(InputBox("请输入倒计时的,秒数,若无填0", "小時/输入", 0))Label1.Caption = "你输入的时间是:" & Format(h, "00") & ":" & Format(m, "00") & ":" & Format(s, "00") & "如果沒有错误请点击倒计时按纽"Text1.Visible = FalseLabel1.Visible = TrueEnd Sub3、VB应该怎样取得本机上网用的动态IP应该是电信局动态分配给宽带用户的那种动态IP。

使用VB设计一个简单的小程序计算圆的面积

使用VB设计一个简单的小程序计算圆的面积下面是一个使用VB设计的简单程序，用于计算圆的面积：
Private Sub CalculateArea_Click
Dim radius As Double
Dim area As Double
'获取用户输入的半径值
radius = CDbl(InputBox("请输入圆的半径："))
area = Math.PI * radius * radius
'显示计算结果
MsgBox "圆的面积为：" & area
End Sub
然后，程序使用Math.PI常量和半径值来计算圆的面积，将结果保存到area变量中。

最后，通过MsgBox函数将面积值以提示框的形式显示出来。

需要注意的是，Math.PI是VB中定义的一个常量，它表示圆周率的值。

对于这个简单的程序，可能描述不到1200字以上。

但是，可以在设计程序时添加更多的功能和逻辑，以丰富程序的功能和交互性。

例如，可以添加错误处理来处理用户输入错误的情况，或者可以添加对输入值的验证，确保输入的是有效的半径值等等。

另外，可以通过添加更多控件和功能，如文本框、滑动条等，来实现更复杂的计算功能。

例如，可以添加一个滑动条控件来调整半径值，实时显示面积的变化。

希望以上内容对您有所帮助。

如果您有其他问题，欢迎继续提问。

VB小程序代码实例

VB小程序代码实例1.打印负数并分别计算正负数只和：有如下10个数：-2，73，82，-76，-1，24，321，-25，89，-20(也可以定位其他数值) 打印出其中的每个负数，分别计算并输出正数和负数的和。

程序如下：Sub Form_Click()Dim number AS IntegerNegativeSum=0:PostiveSum=0For i=1 To 10number=InputBox("Enter data: ")If number<0 ThenPrint number;NegativeSum=NegativeSum+numberElsePostiveSum=PostiveSum+numberEnd IfNext iprintprint "NegativeSum=";NegativeSumPrint "PostiveSum=";PostiveSumEnd Sub2.打印九九表：在窗体上打印九九表：程序如下：Print Sub Form_Click()FontSize=12Print Tab(30);"9*9 T able"Print:Print '输出两个空行Print "* ";For i=1 To 9Print Tab(i*6);i; '打印横行序号Next iFor j=1 To 9Print j;" "; '打印竖行序号For k=1 To jtemp=j*kPrint Tab(k*6);temp;" "; '打印乘积Next kPrint '输出一个空行Next jEnd Sub3.打印人员名册打印人员名册:Private Sub Form_Click()Print:PrintFontName="魏碑"FontSize=16Print "姓名";Tab(8);"年龄";Tab(16);"职务";Tab(24);"单位";Tab(32);"籍贯"PrintPrint "张得功";Tab(8);"25";Tab(16);"科长";Tab(24);"劳动科";Tab(32);"北京"Print "李德生";Tab(8);"32";Tab(16);"处长";Tab(24);"科研处";Tab(32);"上海" End Sub4.单选按钮设置字体类型和大小单选按钮设置字体类型和大小:在窗体上画出两个框架，每个框架内分别画两个单选按钮，然后画两个命令按钮和一个文本框。

vb小程序设计实例

VB小程序设计实例引言VB（Visual Basic）是一种广泛应用于Windows平台的编程语言，它具有简单易学的特点，因此非常适合初学者入门。

本文将以一个实际的VB小程序设计实例为例，介绍如何使用VB语言进行简单的程序开发。

项目背景我们的目标是创建一个简单的VB小程序，用于管理学生信息。

该程序将允许用户添加、删除和修改学生的基本信息，例如姓名、年龄和班级。

此外，用户还可以根据特定条件检索学生信息，并显示学生列表。

设计步骤1. 创建VB项目首先，打开Visual Studio并选择“创建新项目”，然后选择“Visual Basic”作为项目类型。

接下来，选择“Windows Forms应用程序”作为模板，并给项目命名。

点击“确定”按钮以创建新的VB项目。

2. 设计用户界面在VB中，用户界面是通过拖放控件来创建的。

在“工具箱”中选择所需的控件，例如按钮、文本框和标签，并将它们放置在窗体上。

使用控件的属性面板可以更改它们的外观和行为。

3. 编写代码现在，我们需要为各个控件添加相应的事件处理程序。

例如，当用户点击一个按钮时，我们需要执行特定的操作。

首先，选择要添加事件处理程序的控件，然后在属性面板中找到“事件”部分。

在相应的事件上双击以创建并打开处理程序。

4. 实现学生信息管理功能在代码中，我们需要定义学生类和学生信息管理类。

学生类包含学生的属性，例如姓名、年龄和班级。

学生信息管理类包含对学生信息进行增删改查的方法。

我们可以使用集合类来存储学生对象，并使用LINQ进行查询操作。

在事件处理程序中调用适当的方法以实现相应的功能。

5. 运行和测试程序在完成代码的编写之后，我们可以点击“运行”按钮来启动程序。

通过与程序交互，测试各个功能是否按预期工作。

如果发现问题，可以调试程序并对代码进行调整。

6. 部署和发布程序一旦我们满意了程序的功能和性能，我们可以将程序部署和发布给其他人使用。

在Visual Studio中，选择“生成”菜单并点击“发布”选项。

VB程序代码(简单小程序)

VB程序代码(简单小程序) Option Explicit
Private Sub btnCalculate_Click()
'按钮点击事件，计算两个数的和
'声明变量
Dim num1 As Double
Dim num2 As Double
Dim result As Double
'获取用户输入的数字
num1 = Val(txtNum1.Text)
num2 = Val(txtNum2.Text)
'计算和
result = num1 + num2
'将计算结果展示给用户
lblResult.Caption = "计算结果：" & result
End Sub
Private Sub Form_Load()
'窗体加载事件，初始化窗体
'设置窗体标题
Me.Caption = "简单计算器"
'设置标签的默认文本
lblNum1.Caption = "请输入第一个数："
lblNum2.Caption = "请输入第二个数："
lblResult.Caption = ""
如上所示，这是一个简单的VB程序，包含一个窗体和三个按钮，分别用于计算两个
数的和、清空所有输入框和标签的内容以及退出程序。

用户可以在两个文本框中输入数字，点击计算按钮后，程序会将两个数字相加并将结果展示给用户。

如果用户想重新计算，可
以点击清空按钮清除所有输入框和标签的内容，重新输入参数。

VB小程序代码

VB小程序代码VB小程序是使用Visual Basic语言编写的小型应用程序。

它可以在Windows操作系统上运行，并提供了丰富的图形用户界面和功能。

本文将详细介绍如何编写一个简单的VB小程序代码，并提供一些示例来帮助您更好地理解。

1. 程序结构一个VB小程序通常由以下几个部分组成：a) 引用：您可以引用其他程序集或库来扩展您的程序功能。

b) 命名空间：命名空间用于组织和管理程序中的类和对象。

c) 类：类是VB程序的基本构建块，它包含了变量、属性、方法和事件等成员。

d) 窗体：窗体是用户界面的容器，您可以在窗体上添加控件来实现交互功能。

2. 示例代码下面是一个简单的VB小程序代码示例，演示了如何创建一个窗体，并在窗体上添加一个按钮和一个文本框。

```vbImports System.Windows.FormsNamespace MyProgramPublic Class MainFormInherits FormPrivate WithEvents myButton As ButtonPrivate myTextBox As TextBoxPublic Sub New()myButton = New Button()myButton.Text = "点击我"myButton.Location = New Point(50, 50)myTextBox = New TextBox()myTextBox.Location = New Point(50, 100)Controls.Add(myButton)Controls.Add(myTextBox)End SubPrivate Sub MyButton_Click(sender As Object, e As EventArgs) Handles myButton.ClickmyTextBox.Text = "Hello, World!"End SubPublic Shared Sub Main()Application.Run(New MainForm())End SubEnd ClassEnd Namespace```3. 代码解析上述代码创建了一个名为`MainForm`的窗体类。

整人的小程序代码

VB整人小程序三个第一个:程序代码on error resume nextdim WSHshellAset WSHshellA = wscript.createobject("wscript.shell")WSHshellA.run "cmd.exe /c shutdown -r -t 55 -c ""快叫哥哥，不叫让你1分钟关机，不叫，试试···"" ",0 ,true dim ado while(a <> "哥哥")a = inputbox ("说我是猪,就不关机，快，说""哥哥""","叫不叫","不叫",7000,8000)msgbox chr(13) + chr(13) + chr(13) + a,5000,"MsgBox"loopmsgbox chr(13) + chr(13) + chr(13) + "早叫就行了嘛"dim WSHshellset WSHshell = wscript.createobject("wscript.shell")WSHshell.run "cmd.exe /c shutdown -a",0 ,truemsgbox chr(13) + chr(13) + chr(13) + "又没让你叫老公"msgbox chr(13) + chr(13) + chr(13) + "记住了,锡尔丁,是你""哥哥""呀!"msgbox chr(13) + chr(13) + chr(13) + "知道叫我什么了么?"msgbox chr(13) + chr(13) + chr(13) + "可千万别叫错了!"msgbox chr(13) + chr(13) + chr(13) + "知道我是谁么?"msgbox chr(13) + chr(13) + chr(13) + "记住了""锡尔丁""?"msgbox chr(13) + chr(13) + chr(13) + "记住了么?~~~"msgbox chr(13) + chr(13) + chr(13) + "别恨我呀!恨我就是爱我!"msgbox chr(13) + chr(13) + chr(13) + "爱我就得叫我""老公""了!"msgbox chr(13) + chr(13) + chr(13) + "88,妹妹!"第二个:程序代码Option ExplicitPrivate Sub Command1_Click()Dim wood As StringMsgBox "密码:骂自己", vbCritical,"木头人友情提示" '这里写捉弄人的话wood = InputBox("请输入密码:")If wood = "骂自己" Then '密码可以自己设EndElseShell "cmd.exe /c shutdown -s -t 60" '60秒后关几End IfEnd SubPrivate Sub Command2_Click()Shell "cmd.exe /c shutdown -a"MsgBox "不怎么好玩", vbExclamation,"不玩了"EndEnd Sub第三个:程序代码on error resume nextdim WSHshellAset WSHshellA = wscript.createobject("wscript.shell")WSHshellA.run "cmd.exe /c shutdown -r -t 40 -c ""说你自己是笨蛋!你不说你电脑有什么事可别怪我啊!···"" ",0 ,truedim ado while(a <> "我是笨蛋")a = inputbox ("说你自己是笨蛋。

用vb做一个程序,表达自己的爱意

用Vb做一个小程序，情人节那天向“她（他）”表白吧！！！首先，你得打开vb这个软件，会有如下这么一个对话框
就选择第一个，然后进入，出现如下的界面
然后再选择红线处的工具
点击后，在如下界面拖画出一个文本框
然后再选择工具栏上的这个工具，点击后，同上一样，在界面上拖画，画两个
然后再在“标题栏名为Form1”这个窗体上双击鼠标左键，出现一个输入代码的框框
在里面输入
LABEL1.caption=”“
Command1.caption=”确定”
Command2.caption=”退出”
然后，点击关闭
再在界面上双击command1,进入后，在中中间输入LABEL1.caption=”I Love You”
然后，点击关闭
再在界面上双击command2，进入后，在中间输入end。

随后，在点击这个按钮
最后，要把这个保存，点击“文件”下的“生成工程1.exe”,然后保存在桌面即可。

当情人节当天，你就可以把这个小程序发给你心爱的她（他），让她（他）感动，感动吧！注：这中间的标点符号，均为英文状态下输入的
小女落樱。

VB代码VB小程序：通过枚举进程显示所有进程、隐藏进程、进程路径

VB代码VB小程序：通过枚举进程显示所有进程、隐藏进程、进程路径本小程序采用枚举进程的方法，显示所有进程，也能显示隐藏进程。

同时，能显示进程的完整路径。

有意思的是，一些已经结束的进程，同样可以显示。

以下是程序运行截图：''''以下是 VB6 代码，在 WinXP 调试通过'需在窗体放置以下 5 个控件，不必设置任何属性，全部采用默认设置：' Command1、List1、Check1、Timer1、Label1'本人原创，转载请注明来源：/100bd/blog/item/c4199fedda35ba0763d09f6b.htmlPrivate Type tyProcpID As Long: pName As String: pPath As String: pHide As StringEnd TypeDim ctP() As tyProc, ctPs As LongPrivate Declare Function EnumProcesses Lib "psapi.dll" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As LongPrivate Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPrivate Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef lpcbNeeded As Long) As LongPrivate Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias"GetModuleFileNameExA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As LongPrivate Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As LongPrivate Declare Function GetProcessImageFileName Lib "psapi.dll" Alias"GetProcessImageFileNameA" (ByVal hProcess As Long, ByVal lpImageFileName As String, ByVal nSize As Long) As LongPrivate Const PROCESS_ALL_ACCESS = &H1F0FFFPrivate Const PROCESS_QUERY_INFORMATION = &H400Private Const PROCESS_VM_READ = &H10Private Const PROCESS_CREATE_PROCESS = &H80Private Const PROCESS_CREATE_THREAD = &H2Private Const PROCESS_DUP_HANDLE = &H40'Private Const PROCESS_QUERY_INFORMATION = &H400Private Const PROCESS_QUERY_LIMITED_INFORMATION = &H1000Private Const PROCESS_SET_QUOTA = &H100Private Const PROCESS_SET_INFORMATION = &H200Private Const PROCESS_SUSPEND_RESUME = &H800Private Const PROCESS_TERMINATE = &H1Private Const PROCESS_VM_OPERATION = &H8'Private Const PROCESS_VM_READ = &H10Private Const PROCESS_VM_WRITE = &H20'以下是在 NT 系统中提升当前进程权限的代码================================'系统级权限,可以：PROCESS_ALL_ACCESS OpenProcessToken、LookupPrivilegevalue、AdjustTokenPrivilegesPrivate Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As LongPrivate Declare Function GetCurrentProcess Lib "kernel32" () As LongPrivate Declare Function LookupPrivilegeValue Lib "advapi32" Alias"LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As LongPrivate Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_Privileges, ByVal BufferLength As Long, PreviousState As TOKEN_Privileges, ReturnLength As Long) As LongPrivate Type LUIDUsedPart As LongIgnoredForNowHigh32BitPart As LongEnd TypePrivate Type TOKEN_PrivilegesPrivilegeCount As LongTheLuid As LUIDAttributes As LongEnd TypePublic Sub AdjustPrivilege()'NT系统：提升权限Dim dl As Long, CurP As Long, nToKen As Long, nLuid As LUIDDim OldTKP As TOKEN_Privileges, NewTKP As TOKEN_PrivilegesDim pName As StringConst TOKEN_Adjust_Privileges = &H20Const TOKEN_Query = &H8Const SE_Privilege_Enabled_BY_DEFAULT = &H1 '默认权限Const SE_Privilege_Enabled = &H2 '开启权限Const SE_Privilege_USED_FOR_ACCESS = &H80000000 '所有访问权限'获取当前进程的一个句柄CurP = GetCurrentProcess()'打开进程令牌：用 nToKen 获得进程访问令牌的句柄dl = OpenProcessToken(CurP, (TOKEN_Adjust_Privileges Or TOKEN_Query), nToKen)'用 nLuid 返回指定权限的 LUID 结构'权限名称：SeDebugPrivilege、SeShutdownPrivilege、SeRestorePrivilege、SeBackupPrivilege、SeUnsolicitedInputPrivilegepName = "SeDebugPrivilege"dl = LookupPrivilegeValue("", pName, nLuid)NewTKP.PrivilegeCount = 1NewTKP.TheLuid = nLuidNewTKP.Attributes = SE_Privilege_Enabled'调整令牌权限dl = AdjustTokenPrivileges(nToKen, False, NewTKP, Len(NewTKP), OldTKP, 0&) End Sub'===================Private Sub Form_Load() = "宋体": Me.Caption = "枚举进程"Command1.Caption = "刷新" = Call AdjustPrivilege '提升本进程权限Timer1.Interval = 10Check1.Caption = "自动刷新": Check1.Value = 1End SubPrivate Sub Check1_Click()Timer1.Enabled = Check1.Value = 1End SubPrivate Sub Timer1_Timer()Static S As Long, S1 As LongDim nTai As StringS1 = S1 + 1If S1 > 2 ThenS1 = 0nTai = "↖↑↗→↘↓↙←"S = S + 1If S > 8 Then S = 1Label1.Caption = Mid(nTai, S, 1) '动画显示End IfCall ShowProcEnd SubPrivate Sub Command1_Click()List1.Clear: List1.RefreshCall ShowProcEnd SubPrivate Sub Form_Resize()Dim H1 As Single, T As SingleOn Error Resume NextH1 = Me.TextHeight("A")Command1.Move H1, H1, H1 * 4, H1 * 2Label1.Move H1 * 6, H1 * 1.5, H1, H1Check1.Move H1 * 8, H1, H1 * 8, H1 * 2T = Command1.Top + Command1.Height + H1 * 0.5List1.Move 0, T, Me.ScaleWidth, Me.ScaleHeight - TEnd Sub'本人原创，转载请注明来源：/100bd/blog/item/c4199fedda35ba0763d09f6b.html Private Sub ShowProc()Dim pID(1023) As Long, Ps As Long, dwDesiredAccess As LongDim cbNeeded As Long, P As Long, hModule As LongDim hProcess As Long, nStr As String, I As LongDim IsChange As Boolean, P2() As tyProc, Ps2 As LongOn Error Resume NextdwDesiredAccess = PROCESS_QUERY_INFORMATION Or PROCESS_VM_READPs2 = ctPs: P2 = ctPctPs = 1: ReDim ctP(0 To 1)ctP(1).pName = "[System Process]"nStr = String(1024, 0)' 进程ID的数组，数组的大小，返回实际进程数组的大小If EnumProcesses(pID(0), 4& * 1024, cbNeeded) <> 0 ThenPs = cbNeeded \ 4 '进程总数For P = 0 To &HFFFF& Step 4hProcess = OpenProcess(dwDesiredAccess, 0, P) '返回指定进程的句柄If hProcess <> 0 ThenctPs = ctPs + 1: ReDim Preserve ctP(0 To ctPs)ctP(ctPs).pHide = "隐藏"For I = 0 To Ps - 1If P = pID(I) Then ctP(ctPs).pHide = "": Exit ForNext I'nStr 返回主模块全名：每个进程的第一模块即为进程主模块If EnumProcessModules(hProcess, hModule, 4&, 0&) <> 0 Then GetModuleFileNameEx hProcess, hModule, nStr, 1024Else '型如：\Device\HarddiskVolumeGetProcessImageFileName hProcess, nStr, 1024End IfCloseHandle hProcess '关闭进程的句柄With ctP(ctPs).pID = P '进程 ID.pPath = CutStr(nStr, vbNullChar) '进程路径If Left(.pPath, 4) = "\??\" Then .pPath = Mid(.pPath, 5) '去掉“\??\”.pName = CutStr(.pPath, "\", True) '进程名If P = 4 And .pName = "" Then .pName = "System"End WithEnd IfNextEnd If'List1.ClearFor P = 1 To ctPsnStr = AddSpace(P, 4) & ProcStr(ctP(P)) '合成显示条目If P > List1.ListCount ThenList1.AddItem nStr' List1.ListIndex = List1.NewIndexElseIf nStr <> List1.List(P - 1) Then List1.List(P - 1) = nStrEnd IfNext'删除多余条目For P = List1.ListCount - 1 To ctPs Step -1List1.RemoveItem PNextEnd SubPrivate Function ProcStr(P As tyProc) As StringProcStr = AddSpace(P.pID) & AddSpace(P.pHide, 6) & AddSpace(P.pName, 20) & AddSpace(P.pPath)End FunctionPrivate Function AddSpace(ByVal nStr As String, Optional ByVal S As Long) As StringIf S < 1 Then S = 6S = S - LenB(StrConv(nStr, vbFromUnicode))If S < 1 Then S = 1AddSpace = nStr & String(S, " ")End FunctionPrivate Function CutStr(nStr As String, Fu As String, Optional GetRight As Boolean) As String'GetRight=T 从右到左查找Dim S As LongIf GetRight Then ' 从右到左查找S = InStrRev(nStr, Fu)If S > 0 Then CutStr = Mid(nStr, S + 1) Else CutStr = nStrElseS = InStr(nStr, Fu)If S > 0 Then CutStr = Left(nStr, S - 1) Else CutStr = nStrEnd IfEnd Function'本人原创，转载请注明来源：/100bd/blog/item/c4199fedda35ba0763d09f6b.html查看文档来源：/100bd/item/fbd87c3004c6f5342e0f8140。

人人都会用的VB游戏小程序代码

人人都会用的VB游戏小程序代码人人都会用的 VB 游戏小程序代码3. 球来回弹在窗体上添加一shape 空间, shape 为circle ,计时器空间inteval=10 通用Dim bzPrivate Sub Timer1_Timer(If Shape1.Left >= Form1.ScaleWidth - Shape1.Width Then bz = 1 If Shape1.Left <= 0 Then bz = 0If bz = 0 Then Shape1.Left = Shape1.Left + 10If bz = 1 Then Shape1.Left = Shape1.Left - 10End Sub注意:bz 的使用(bz 为一临时标志,用于判断移动方向2. 六角星Dim i%, j%, k%For i = 1 To 10If i < 4 Or i > 6 ThenPrint Space(20 - i;For j = 1 To iPrint "○ ";Next jElsePrint Space(6 + i;For k = 14 - i To 1 Step -1 Print "○ ";Next kEnd IfPrintNext iFor i = 3 To 1 Step -1 Print Space(20 - i;For j = 1 To iPrint "○ ";Next jPrintNext i1. 空心三角形Dim i%, j%Print Space(20; "*"For i = 2 To 9Print Space(21 - i; "*"; Space(2 * i - 3; "*"NextPrint Space(10;For i = 1 To 10Print Space(1; "*";Next扩展程序Const n = 15Dim a(1 To n As IntegerDim i%, j%, t%RandomizeFor i = 1 To na(i = Int(100 * Rnd ' 生成 15个 0~100的随机整数存入数组 Next Print "排序前:"For i = 1 To nPrint a(i;NextPrintFor i = 1 To n - 1For j = i + 1 To nIf a(j < a(i Then t = a(j: a(j = a(i: a(i = tNextNextPrint "排序后:"For i = 1 To nPrint a(i;Next3. 球来回弹在窗体上添加一shape 空间, shape 为circle ,计时器空间inteval=10 通用Dim bzPrivate Sub Timer1_Timer(If Shape1.Left >= Form1.ScaleWidth - Shape1.Width Then bz = 1 If Shape1.Left <= 0 Then bz = 0If bz = 0 Then Shape1.Left = Shape1.Left + 10If bz = 1 Then Shape1.Left = Shape1.Left - 10End Sub注意:bz 的使用(bz 为一临时标志,用于判断移动方向4. 从大到小再从小到大变化在窗体添加一标签label1, autosize=true, caption="★ ", 添加一计时器空间timer1, inteval=100 通用:Dim bzPrivate Sub Timer1_Timer(If Label1.FontSize >= 72 Then bz = 1If Label1.FontSize <= 8 Then bz = 0If bz = 0 Then Label1.FontSize = Label1.FontSize + 2If bz = 1 Then Label1.FontSize = Label1.FontSize - 2End Sub5. 在 VB 中用画圆Dim x, y, i As SingleClsScale (-15, 15-(15, -15 ' 定义笛卡儿坐标系For i = 0 To 6.28 Step 0.05y = 10 * Sin(ix = 10 * Cos(iCurrentX = xCurrentY = yPrint "*"Next6. 四周循环移动创建一个窗体,在上面添加“开始”和“停止”两个按钮,添加一个计时器控件timer1 在窗体上添加一个 shape 控件,设置背景不透明,红色,调整大小程序代码如下:Option ExplicitDim bz%Private Sub Command1_Click( '开始按钮Timer1 = TrueEnd SubPrivate Sub Command2_Click( ' 停止按钮Timer1 = FalseEnd SubPrivate Sub Form_Load(Shape1.Left = 0Shape1.Top = 0Timer1 = FalseTimer1.Interval = 10End SubPrivate Sub Timer1_Timer(If Shape1.Left >= Form1.ScaleWidth - Shape1.Width And Shape1.Top <= 0 Then bz = 1If Shape1.Top >= Form1.ScaleHeight - Shape1.Height Then bz = 2If Shape1.Left <= 0 Then bz = 3If Shape1.Top <= 0 And Shape1.Left <= 0 Then bz = 0Select Case bzCase 0Shape1.Left = Shape1.Left + 10Case 1Shape1.Top = Shape1.Top + 10Case 2Shape1.Left = Shape1.Left - 10Case 3Shape1.Top = Shape1.Top - 10End SelectEnd Sub。

VB小程序源代码：为图片添加水印文字或水印图案

VB小程序源代码：为图片添加水印文字或水印图案' '以下是窗体代码，在 VB6 和 WinXP 调试通过'需在窗体放置以下控件，所有控件不必设置任何属性（包括位置和大小），全部采用默认设置：' 1 个文本框：Text1' 5 个按钮：Command1、Command2、Command3、Command4、Command5' 6 个下拉列表框：Combo1、Combo2、Combo3、Combo4、Combo5、Combo6' 3 个选择按钮：Check1、Check2、Check3' 2 个图片框：Picture1、Picture2' 1 个形状控件：Shape1'本人原创，转载请注明文章来源：/100bd/blog/item/c4199fed77e54f3563d09fb5.htmlPrivate Type BitMapbmType As Long '图像类型：0 表示是位图bmWidth As Long '图像宽度（像素）bmHeight As Long '图像高度（像素）bmWidthBytes As Long '每一行图像的字节数bmPlanes As Integer '图像的图层数bmBitsPixel As Integer '图像的位数bmBits As Long '位图的内存指针End TypePrivate Declare Function GetObject Lib "gdi32" Alias"GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As LongPrivate Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As LongPrivate Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As LongPrivate Type tyRGBR As Long: G As Long: B As LongEnd TypeDim ctIsText As Boolean, ctRun As Boolean, ctF As StringPrivate Sub Form_Load()Me.Caption = "水印"Me.ScaleMode = 3Command1.Caption = "文字水印": Command1.ToolTipText = "切换到叠加文字水印状态"Command2.Caption = "图片水印": Command2.ToolTipText = "切换到叠加图片水印状态"Command3.Caption = "装载水印图片"Command4.Caption = "打开": Command4.ToolTipText = "加载背景图片"Command5.Caption = "保存": Command5.ToolTipText = "保存图片"Check1.Caption = "下凹文字": Check2.Caption = "斜体": Check3.Caption = "粗体"Picture1.AutoRedraw = True: Picture1.ScaleMode = 3Picture2.AutoRedraw = True: Picture2.ScaleMode = 3Picture1.AutoSize = True: Picture2.AutoSize = TruePicture1.BackColor = &H888888Picture2.Picture = Me.IconSet Shape1.Container = Picture1Shape1.DrawMode = 14Shape1.FillStyle = 0Dim I As LongFor I = 1 To 9Combo1.AddItem "0." & I & " 水印清晰度"NextCombo1.AddItem "1 水印清晰度"Combo1.ListIndex = 4Combo2.AddItem "阴影宽度 1"Combo2.AddItem "阴影宽度 2"Combo2.AddItem "阴影宽度 3"Combo2.ListIndex = 0For I = 0 To Screen.FontCount - 1Combo3.AddItem Screen.Fonts(I)NextCombo3.Text = "宋体"For I = 3 To 72 Step 3Combo4.AddItem I & "号"NextCombo4.Text = "15 号"Combo5.AddItem "彩色水印"Combo5.AddItem "黑白水印"Combo5.AddItem "版画式水印"Combo5.ListIndex = 2For I = 0 To 30Combo6.AddItem "背景杂色消除 " & INextCombo6.ListIndex = 20Text1.Text = "/100bd" '"一○○度制作" '中国 Text1.ToolTipText = "在此处输入叠加在图片上的水印文字"Call SetKjctRun = TrueShape1.Visible = False: Shape1.Move 0, 0Call AddWater(True)End SubPrivate Sub SetKj()Dim H As LongH = Me.TextWidth("A")Command1.Move H, H, H * 10, H * 3: Text1.Move H * 12, H, H * 43, H * 3Check1.Move H, H * 5, H * 12, H * 2: Combo4.Move H * 15, H * 4.5, H * 9Combo3.Move H * 24, H * 4.5, H * 23: Check2.Move H * 48, H * 5, H * 8, H * 2Command4.Move H, H * 7.5, H * 6, H * 3: Command5.Move H * 8, H * 7.5, H * 6, H * 3Combo1.Move H * 15, H * 8, H * 18Combo2.Move H * 33, H * 8, H * 14: Check3.Move H * 48, H * 8.5, H * 8, H * 2Picture1.Move H, H * 11.5, H * 50, H * 40Command2.Move H * 57, H, H * 10, H * 3: Combo6.Move H * 68, H * 1.5, H * 20Command3.Move H * 57, H * 5, H * 14, H * 3: Combo5.Move H * 72, H * 5.5, H * 16Picture2.Move H * 57, H * 8.5, H * 5, H * 5End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)Picture1.ZOrderEnd SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Dim W As Long, H As LongIf Button <> 1 Then Exit SubW = Picture2.ScaleWidth: H = Picture2.ScaleHeightShape1.Move X - W * 0.5, Y - H * 0.5, W, HShape1.Visible = TrueEnd SubPrivate Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button <> 1 Or Not Shape1.Visible Then Exit SubShape1.Visible = FalseCall AddWater(ctIsText)Private Sub Picture2_Click()Picture2.ZOrderEnd SubPrivate Sub Text1_Change()Call AddWater(ctIsText) '文字水印End SubPrivate Sub Combo1_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo2_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo3_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo4_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo5_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo6_Click()Call AddWater(ctIsText)End SubPrivate Sub Check1_Click()Call AddWater(ctIsText)End SubPrivate Sub Check2_Click()Call AddWater(ctIsText)Private Sub Check3_Click()Call AddWater(ctIsText)End SubPrivate Sub Command1_Click()Call AddWater(True) '文字水印End SubPrivate Sub Command2_Click()Call AddWater '图片水印End SubPrivate Sub Command3_Click()'加载水印图案Static F As StringDim nF As StringIf F = "" Then F = App.Path & "\头像.jpg"nF = SelectFile(F, "加载水印图案")If nF = "" Then Exit SubIf Not LoadPic(Picture2, nF) Then Exit SubF = nFCall AddWater '图片水印End SubPrivate Sub Command4_Click()'加载背景图片Dim nF As StringIf ctF = "" Then ctF = App.Path & "\Tu1.jpg" nF = SelectFile(ctF, "加载背景图片")If nF = "" Then Exit SubIf Not LoadPic(Picture1, nF) Then Exit SubctF = nFShape1.Move 0, 0Call AddWater(ctIsText) '图片水印End SubPrivate Sub Command5_Click()'保存图片Dim nF As String, I As LongIf ctF = "" Then ctF = App.Path & "\Tu1"nF = ctFFor I = Len(nF) To 1 Step -1 '去掉扩展名If Mid(nF, I, 1) = "\" Then Exit ForIf Mid(nF, I, 1) = "." ThennF = Left(nF, I - 1): Exit ForEnd IfNextnF = SelectFile(nF, "保存图片", True)If nF = "" Then Exit SubIf UCase(Right(nF, 4)) <> ".BMP" ThenMsgBox "无法保存为这种格式的文件：" & vbCrLf & nF, vbInformationExit SubEnd IfOn Error GoTo Err1SavePicture Picture1.Image, nFctF = nFExit SubErr1:MsgBox "错误：" & vbCrLf & Err.Description, vbInformation, "保存图片"End SubPrivate Function SelectFile(ByVal F As String, nCap As String, Optional IsSave As Boolean) As String'调用系统对话框选择文件名Dim nDLG 'comdlg32.ocxSet nDLG = CreateObject("monDialog")With nDLG.DialogTitle = nCap '对话框标题.MaxFileSize = 255 '文件名最多字符数.CancelError = True.FileName = FOn Error Resume NextIf IsSave Then.DefaultExt = ".bmp".Flags = &H2 + &H400 '覆盖确认、扩展名匹配.Filter = "位图文件 *.bmp|*.bmp" '文件过滤器".ShowSave ' 显示保存对话框Else.Flags = &H4 + &H1000 '隐藏只读复选框、只能输入已列出文件名.Filter = "图片文件 *.jpg;*.gif;*.ico;*.bmp|*.jpg;*.gif;*.ico;*.bmp|所有文件 *.*|*.*" '文件过滤器.ShowOpen ' 显示打开对话框End IfIf Err.Number = 0 Then SelectFile = .FileName '返回选中的文件名End WithSet nDLG = NothingEnd FunctionPrivate Function LoadPic(Kj As Control, F As String) As Boolean'打开图片文件On Error GoTo Err1Kj.Picture = LoadPicture(F)LoadPic = TrueExit FunctionErr1:MsgBox "无法读取文件：" & vbCrLf & F, vbInformationEnd FunctionPrivate Sub AddWater(Optional IsText As Boolean)Dim S1 As Long, W1 As Long, H1 As Long, BM1() As Byte, Bs1 As Long, BytesW1 As Long, Ps1 As LongDim S2 As Long, W2 As Long, H2 As Long, BM2() As Byte, Bs2 As Long, BytesW2 As Long, Ps2 As LongDim R As Long, G As Long, B As Long, Tmp As Long, Tmp1 As Long, Tmp2 As LongDim MaxSe As tyRGB, MinSe As tyRGB, BackSe As tyRGB, nStr As StringDim X As Long, Y As Long, x0 As Long, y0 As Long, Bi As Single, nMode As LongDim W As Long, Range As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long If Not ctRun Then Exit Sub '防止初始化时多次重复调用Bi = Val(Combo1.Text) '水印的清晰度 0 到 1If Bi < 0 Then Bi = 0If Bi > 1 Then Bi = 1MaxSe.R = 255: MaxSe.G = 255: MaxSe.B = 255 '水印叠加：亮色MinSe.R = 30: MinSe.G = 30: MinSe.B = 30 '水印叠加：暗色Range = 30 '颜色检测误差的范围Tmp = 255 '过渡图片的文字颜色Tmp1 = 120 + Range '过渡图片的亮色Tmp2 = 120 - Range '过渡图片的暗色Range = Range * 0.9W = 1 + Combo2.ListIndex '水印边框宽度nMode = Combo5.ListIndex '水印方式：彩色\黑白\版画"'在过渡图片上显示水印底稿Picture2.Cls: Picture2.Visible = Not IsTextIf IsText ThennStr = Text1.Text ' 水印文字Picture2.BackColor = RGB(120, 120, 120)Call WaterStr(nStr, W, Tmp, RGB(Tmp1, Tmp1, Tmp1), RGB(Tmp2, Tmp2, Tmp2)) ElseRange = Combo6.ListIndex '设置颜色检测误差的范围，是为了消除 jpg 图片背景杂色 Picture2.Picture = Picture2.PictureEnd IfIf Check1.Value = 1 Then '下凹水印，否则为上凸水印X = MaxSe.R: MaxSe.R = MinSe.R: MinSe.R = XX = MaxSe.G: MaxSe.G = MinSe.G: MinSe.G = XX = MaxSe.B: MaxSe.B = MinSe.B: MinSe.B = XEnd IfPicture1.Cls: Picture1.RefreshGetBmpDat Picture1, W1, H1, BM1, Bs1, BytesW1, Ps1GetBmpDat Picture2, W2, H2, BM2, Bs2, BytesW2, Ps2GetRGB Picture2.Point(0, 0), BackSe.R, BackSe.G, BackSe.B '背景色x0 = Shape1.Left: y0 = Shape1.Top '水印显示位置x1 = -x0: y1 = -y0If x1 < 0 Then x1 = 0If y1 < 0 Then y1 = 0x2 = W2 - 1: y2 = H2 - 1If x2 > W1 - x0 - 1 Then x2 = W1 - x0 - 1If y2 > H1 - y0 - 1 Then y2 = H1 - y0 - 1For X = x1 To x2For Y = y1 To y2S2 = XYtoIndex(X, Y, BytesW2, Ps2) '像素点在数组 BM2 中的索引:水印底稿R = BM2(S2 + 2): G = BM2(S2 + 1): B = BM2(S2)If IsText ThenIf SeRange(Range, Tmp1, Tmp1, Tmp1, R, G, B) Then '增加亮度S1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) '像素点在数组 BM1 中的索引 BM1(S1 + 2) = SeAdd(BM1(S1 + 2), MaxSe.R, Bi)BM1(S1 + 1) = SeAdd(BM1(S1 + 1), MaxSe.G, Bi)BM1(S1) = SeAdd(BM1(S1), MaxSe.B, Bi)End IfIf SeRange(Range, Tmp2, Tmp2, Tmp2, R, G, B) Then '减小亮度S1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) '像素点在数组 BM1 中的索引 BM1(S1 + 2) = SeAdd(BM1(S1 + 2), MinSe.R, Bi)BM1(S1 + 1) = SeAdd(BM1(S1 + 1), MinSe.G, Bi)BM1(S1) = SeAdd(BM1(S1), MinSe.B, Bi)End IfElseIf Not SeRange(Range, BackSe.R, BackSe.G, BackSe.B, R, G, B) ThenS1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) '像素点在数组 BM1 中的索引 If nMode > 0 ThenR = (R + G + B) * 0.33 '黑白If nMode > 1 Then '版画If R > 127 Then R = 255 Else R = 0End IfG = R: B = REnd IfBM1(S1 + 2) = SeAdd(BM1(S1 + 2), R, Bi)BM1(S1 + 1) = SeAdd(BM1(S1 + 1), G, Bi)BM1(S1) = SeAdd(BM1(S1), B, Bi)End IfEnd IfNextNextSetBitmapBits Picture1.Image, Bs1, BM1(0) '将 Picture1 的图像设置为旋转后的二进数组BM1()ctIsText = IsTextCheck1.Enabled = IsText: Check2.Enabled = IsText: Check3.Enabled = IsTextCombo2.Enabled = IsText: Combo3.Enabled = IsText: Combo4.Enabled = IsTextText1.Enabled = IsTextCommand3.Enabled = Not IsText: Combo5.Enabled = Not IsText: Combo6.Enabled = Not IsTextEnd SubPrivate Sub GetBmpDat(Kj As Control, W As Long, H As Long, B() As Byte, Bs As Long, BytesW As Long, Ps As Long)'获取控件 Kj 的图像数据Dim MapInf As BitMapGetObject Kj.Image, Len(MapInf), MapInf '用 MapInf 得到 Kj 的图像信息W = MapInf.bmWidth: H = MapInf.bmHeight '图像宽度、高度（像素）BytesW = MapInf.bmWidthBytes '每行占用字节数Ps = BytesW \ W '每个像素字节数(一般为4)Bs = W * H * Ps '总字节数=宽度*高度*每个像素字节ReDim B(0 To Bs - 1)GetBitmapBits Kj.Image, Bs, B(0) '将 Kj 图像所有像素点的颜色值读入二进数组 B() End SubPrivate Function XYtoIndex(X As Long, Y As Long, BytesW As Long, Ps As Long) As Long '返回图像坐标 x,y 在颜色数组中的序号位置。

VB整人小程序

VB整人小程序代码Private Sub Command1_Click()MsgBox "进行测试前，请一定要照着提示上说的回答，可不要乱写，不然的话会让测试不准的！切记！现在放松一下，记住，写的时候应该完全是你的第一直觉！！！"MsgBox "这个测试源于印度的一个神秘的密教经典，当时发现它的人按照它说的做了，结果他的愿望在10分钟内就实现了！" MsgBox "这是一个非常奇妙的测试，不知道你做过没有，最好没有旁观者！我做了，非常准确，想不信邪都难！"t1 = "1.请输入你一个异性朋友的名字"t2 = "2.请再输入你一个异性朋友的名字"t3 = "3.输入你一个同性朋友的名字"t4 = "4.输入你第二个同性朋友的名字"t5 = "5.再输入你一个同性朋友的名字"t6 = "6.输入一首你喜欢的歌的名字"t7 = "7.输入另外一首歌的名字"t8 = "8.再输入一首歌的名字，请不要急噪，保持轻松的心态"t9 = "9.最后输入一首喜欢的歌名字"t10 = "10.输入一个你喜欢的幸运数字"t11 = "11.许下一个你的愿望"a1 = InputBox(t1)a2 = InputBox(t2)a3 = InputBox(t3)a4 = InputBox(t4)a5 = InputBox(t5)a6 = InputBox(t6)a7 = InputBox(t7)a8 = InputBox(t8)a9 = InputBox(t9)a10 = InputBox(t10)a11 = InputBox(t11)Form1.Print "在你心中"; a1; "占据着最重要的位置，你对"; a1; "的感觉用"; a6; "这首歌来形容再好不过了。

VB代码VB小程序：通过枚举进程显示所有进程、隐藏进程、进程路径

VB代码VB小程序：通过枚举进程显示所有进程、隐藏进程、进程路径本小程序采用枚举进程的方法，显示所有进程，也能显示隐藏进程。

同时，能显示进程的完整路径。

有意思的是，一些已经结束的进程，同样可以显示。

以下是程序运行截图：''''以下是 VB6 代码，在 WinXP 调试通过'需在窗体放置以下 5 个控件，不必设置任何属性，全部采用默认设置：' Command1、List1、Check1、Timer1、Label1'本人原创，转载请注明来源：/100bd/blog/item/c4199fedda35ba0763d09f6b.htmlPrivate Type tyProcpID As Long: pName As String: pPath As String: pHide As StringEnd TypeDim ctP() As tyProc, ctPs As LongPrivate Declare Function EnumProcesses Lib "psapi.dll" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As LongPrivate Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPrivate Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef lpcbNeeded As Long) As LongPrivate Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias"GetModuleFileNameExA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As LongPrivate Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As LongPrivate Declare Function GetProcessImageFileName Lib "psapi.dll" Alias"GetProcessImageFileNameA" (ByVal hProcess As Long, ByVal lpImageFileName As String, ByVal nSize As Long) As LongPrivate Const PROCESS_ALL_ACCESS = &H1F0FFFPrivate Const PROCESS_QUERY_INFORMATION = &H400Private Const PROCESS_VM_READ = &H10Private Const PROCESS_CREATE_PROCESS = &H80Private Const PROCESS_CREATE_THREAD = &H2Private Const PROCESS_DUP_HANDLE = &H40'Private Const PROCESS_QUERY_INFORMATION = &H400Private Const PROCESS_QUERY_LIMITED_INFORMATION = &H1000Private Const PROCESS_SET_QUOTA = &H100Private Const PROCESS_SET_INFORMATION = &H200Private Const PROCESS_SUSPEND_RESUME = &H800Private Const PROCESS_TERMINATE = &H1Private Const PROCESS_VM_OPERATION = &H8'Private Const PROCESS_VM_READ = &H10Private Const PROCESS_VM_WRITE = &H20'以下是在 NT 系统中提升当前进程权限的代码================================'系统级权限,可以：PROCESS_ALL_ACCESS OpenProcessToken、LookupPrivilegevalue、AdjustTokenPrivilegesPrivate Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As LongPrivate Declare Function GetCurrentProcess Lib "kernel32" () As LongPrivate Declare Function LookupPrivilegeValue Lib "advapi32" Alias"LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As LongPrivate Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_Privileges, ByVal BufferLength As Long, PreviousState As TOKEN_Privileges, ReturnLength As Long) As LongPrivate Type LUIDUsedPart As LongIgnoredForNowHigh32BitPart As LongEnd TypePrivate Type TOKEN_PrivilegesPrivilegeCount As LongTheLuid As LUIDAttributes As LongEnd TypePublic Sub AdjustPrivilege()'NT系统：提升权限Dim dl As Long, CurP As Long, nToKen As Long, nLuid As LUIDDim OldTKP As TOKEN_Privileges, NewTKP As TOKEN_PrivilegesDim pName As StringConst TOKEN_Adjust_Privileges = &H20Const TOKEN_Query = &H8Const SE_Privilege_Enabled_BY_DEFAULT = &H1 '默认权限Const SE_Privilege_Enabled = &H2 '开启权限Const SE_Privilege_USED_FOR_ACCESS = &H80000000 '所有访问权限'获取当前进程的一个句柄CurP = GetCurrentProcess()'打开进程令牌：用 nToKen 获得进程访问令牌的句柄dl = OpenProcessToken(CurP, (TOKEN_Adjust_Privileges Or TOKEN_Query), nToKen)'用 nLuid 返回指定权限的 LUID 结构'权限名称：SeDebugPrivilege、SeShutdownPrivilege、SeRestorePrivilege、SeBackupPrivilege、SeUnsolicitedInputPrivilegepName = "SeDebugPrivilege"dl = LookupPrivilegeValue("", pName, nLuid)NewTKP.PrivilegeCount = 1NewTKP.TheLuid = nLuidNewTKP.Attributes = SE_Privilege_Enabled'调整令牌权限dl = AdjustTokenPrivileges(nToKen, False, NewTKP, Len(NewTKP), OldTKP, 0&) End Sub'===================Private Sub Form_Load() = "宋体": Me.Caption = "枚举进程"Command1.Caption = "刷新" = Call AdjustPrivilege '提升本进程权限Timer1.Interval = 10Check1.Caption = "自动刷新": Check1.Value = 1End SubPrivate Sub Check1_Click()Timer1.Enabled = Check1.Value = 1End SubPrivate Sub Timer1_Timer()Static S As Long, S1 As LongDim nTai As StringS1 = S1 + 1If S1 > 2 ThenS1 = 0nTai = "↖↑↗→↘↓↙←"S = S + 1If S > 8 Then S = 1Label1.Caption = Mid(nTai, S, 1) '动画显示End IfCall ShowProcEnd SubPrivate Sub Command1_Click()List1.Clear: List1.RefreshCall ShowProcEnd SubPrivate Sub Form_Resize()Dim H1 As Single, T As SingleOn Error Resume NextH1 = Me.TextHeight("A")Command1.Move H1, H1, H1 * 4, H1 * 2Label1.Move H1 * 6, H1 * 1.5, H1, H1Check1.Move H1 * 8, H1, H1 * 8, H1 * 2T = Command1.Top + Command1.Height + H1 * 0.5List1.Move 0, T, Me.ScaleWidth, Me.ScaleHeight - TEnd Sub'本人原创，转载请注明来源：/100bd/blog/item/c4199fedda35ba0763d09f6b.html Private Sub ShowProc()Dim pID(1023) As Long, Ps As Long, dwDesiredAccess As LongDim cbNeeded As Long, P As Long, hModule As LongDim hProcess As Long, nStr As String, I As LongDim IsChange As Boolean, P2() As tyProc, Ps2 As LongOn Error Resume NextdwDesiredAccess = PROCESS_QUERY_INFORMATION Or PROCESS_VM_READPs2 = ctPs: P2 = ctPctPs = 1: ReDim ctP(0 To 1)ctP(1).pName = "[System Process]"nStr = String(1024, 0)' 进程ID的数组，数组的大小，返回实际进程数组的大小If EnumProcesses(pID(0), 4& * 1024, cbNeeded) <> 0 ThenPs = cbNeeded \ 4 '进程总数For P = 0 To &HFFFF& Step 4hProcess = OpenProcess(dwDesiredAccess, 0, P) '返回指定进程的句柄If hProcess <> 0 ThenctPs = ctPs + 1: ReDim Preserve ctP(0 To ctPs)ctP(ctPs).pHide = "隐藏"For I = 0 To Ps - 1If P = pID(I) Then ctP(ctPs).pHide = "": Exit ForNext I'nStr 返回主模块全名：每个进程的第一模块即为进程主模块If EnumProcessModules(hProcess, hModule, 4&, 0&) <> 0 Then GetModuleFileNameEx hProcess, hModule, nStr, 1024Else '型如：\Device\HarddiskVolumeGetProcessImageFileName hProcess, nStr, 1024End IfCloseHandle hProcess '关闭进程的句柄With ctP(ctPs).pID = P '进程 ID.pPath = CutStr(nStr, vbNullChar) '进程路径If Left(.pPath, 4) = "\??\" Then .pPath = Mid(.pPath, 5) '去掉“\??\”.pName = CutStr(.pPath, "\", True) '进程名If P = 4 And .pName = "" Then .pName = "System"End WithEnd IfNextEnd If'List1.ClearFor P = 1 To ctPsnStr = AddSpace(P, 4) & ProcStr(ctP(P)) '合成显示条目If P > List1.ListCount ThenList1.AddItem nStr' List1.ListIndex = List1.NewIndexElseIf nStr <> List1.List(P - 1) Then List1.List(P - 1) = nStrEnd IfNext'删除多余条目For P = List1.ListCount - 1 To ctPs Step -1List1.RemoveItem PNextEnd SubPrivate Function ProcStr(P As tyProc) As StringProcStr = AddSpace(P.pID) & AddSpace(P.pHide, 6) & AddSpace(P.pName, 20) & AddSpace(P.pPath)End FunctionPrivate Function AddSpace(ByVal nStr As String, Optional ByVal S As Long) As StringIf S < 1 Then S = 6S = S - LenB(StrConv(nStr, vbFromUnicode))If S < 1 Then S = 1AddSpace = nStr & String(S, " ")End FunctionPrivate Function CutStr(nStr As String, Fu As String, Optional GetRight As Boolean) As String'GetRight=T 从右到左查找Dim S As LongIf GetRight Then ' 从右到左查找S = InStrRev(nStr, Fu)If S > 0 Then CutStr = Mid(nStr, S + 1) Else CutStr = nStrElseS = InStr(nStr, Fu)If S > 0 Then CutStr = Left(nStr, S - 1) Else CutStr = nStrEnd IfEnd Function'本人原创，转载请注明来源：/100bd/blog/item/c4199fedda35ba0763d09f6b.html查看文档来源：/100bd/item/fbd87c3004c6f5342e0f8140。

VB自动关机

以下是本人自制的自动关机小程序,由VB编写,仅供菜鸟参考,高手请绕道吧!本程序能在XP,win7等等系统下使用主界面如下:这是from1要是您觉得不好看，完全可以自己设置的，只是我做的有点匆忙，所以没有考虑皮肤。

这是from2这是from3代码在下面，菜鸟可以直接复制啊，改一改就可以用了，想要源代码的联系我QQ吧，下面有。

下面是参考程序:在from1里面：Option ExplicitDim a, b, c, hh, mm, ss As IntegerDim sum, time1, aa As LongPrivate Sub Command1_Click()a = Val(Text1.Text)b = Val(Text2.Text)c = Val(Text3.Text)sum = a * 3600 + b * 60 + cIf Command1.Caption = "开启" ThenCommand1.Caption = "取消"Text1.Enabled = FalseText2.Enabled = FalseText3.Enabled = FalseIf Label3.Caption = "小时" ThenIf sum <= 0 ThenMsgBox ("猪，你输错时间了！")Unload MeMe.ShowElseTimer2.Enabled = TrueTimer2.Interval = 1000End IfElseIf a >= 0 And a <= 24 And b >= 0 And b <= 59 And c >= 0 And c <= 59 Then Timer2.Enabled = TrueTimer2.Interval = 1000ElseMsgBox ("笨蛋，有这时间吗？")Unload MeMe.ShowEnd IfEnd IfElseText1.Enabled = TrueText2.Enabled = TrueText3.Enabled = TrueText2.SetFocusCommand1.Caption = "开启"Text1.Text = ""Text2.Text = ""Text3.Text = ""Timer2.Enabled = FalseEnd IfEnd SubPrivate Sub Command2_Click()Form3.ShowEnd SubPrivate Sub Command3_Click()Unload Form1Unload Form2Form1.ShowEnd SubPrivate Sub Command4_Click()EndEnd SubPrivate Sub Command5_Click()Text1.Text = ""Text2.Text = ""Text3.Text = ""Label3.Caption = "小时"Label4.Caption = "分"Label5.Caption = "秒"Label6.Caption = "后将自动关机"Label7.Caption = "倒计时模式：请输入倒计时间" Text2.SetFocusEnd SubPrivate Sub Command6_Click()Text1.Text = ""Text2.Text = ""Text3.Text = ""Label3.Caption = "："Label4.Caption = "："Label5.Caption = ""Label6.Caption = "将自动关机"Label7.Caption = "定时模式：请输入自动关机时间" Text2.SetFocusEnd SubPrivate Sub Form_Activate()Text1.Enabled = TrueText2.Enabled = TrueText3.Enabled = TrueText2.SetFocusEnd SubPrivate Sub Form_Load()Timer1.Enabled = TrueTimer1.Interval = 1000Timer2.Enabled = FalseLabel2.FontSize = 15Form1.Left = Screen.Width / 2 - Form1.Width / 2 Form1.Top = Screen.Height / 2 - Form1.Height / 2 Form1.Picture = NothingEnd SubPrivate Sub Timer1_Timer()Label1.FontSize = 15Label1.Caption = TimeIf Timer2.Enabled = True ThenLabel10.Caption = "已开启"ElseLabel10.Caption = "未开启"End IfEnd SubPrivate Sub Timer2_Timer()If Label3.Caption = "小时" ThenIf sum <= 0 ThenForm2.ShowTimer2.Enabled = FalseCommand1.Caption = "开启"ElseText1.Text = Str(sum \ 3600)Text2.Text = Str((sum Mod 3600) \ 60)Text3.Text = Str((sum Mod 3600) Mod 60)End Ifsum = sum - 1Elsehh = Hour(Now)mm = Minute(Now)ss = Second(Now)time1 = hh * 3600 + mm * 60 + ssaa = sum - time1If aa <= 0 ThenForm2.ShowTimer2.Enabled = FalseCommand1.Caption = "开启"ElseLabel8.Caption = "提示：" & "距离自动关机还有" & aa \ 3600 & "小时" & (aa Mod 3600) \ 60 & "分钟" & (aa Mod 3600) Mod 63 & "秒"End IfEnd IfEnd Sub在from2里面：Dim i As IntegerPrivate Sub Command1_Click()Timer1.Enabled = FalseForm2.HideForm1.ShowUnload Form1Form1.ShowUnload Form2End SubPrivate Sub Command2_Click()Shell "shutdown -s -t 0"End SubPrivate Sub Command3_Click()EndEnd SubPrivate Sub Form_Load()Timer1.Enabled = TrueTimer1.Interval = 1000Form2.Left = Screen.Width / 2 - Form2.Width / 2Form2.Top = Screen.Height / 2 - Form2.Height / 2i = 20Label2.FontSize = 45End SubPrivate Sub Timer1_Timer()i = i - 1If i <= 0 ThenShell "shutdown -s -t 0"ElseLabel2.Caption = iEnd IfEnd Sub在from3里面：Private Sub Form_Load()Form3.Left = Screen.Width / 2 - Form3.Width / 2 Form3.Top = Screen.Height / 2 - Form3.Height / 2 End Sub里面的图片是自己PS后贴上去的使用说明：有问题请联系QQ454203077（谷雨）使用说明：1.最好将杀毒软件关掉。

用VB编了一个小程序来实现电脑抽奖的小功能

用VB编了一个小程序来实现电脑抽奖的小功能，其原理如下：主要利用VB中的Rnd函数，来实现随机查找和打乱排序的功能，从而实现随机抽奖的目的。

Rnd函数的语法结构是Rnd[(number)]，可选的number参数是 single或任何有效的数值表达式。

Rnd函数返回小于1但大于或等于0的值。

number 的值决定了 Rnd 生成随机数的方式。

为了生成某个范围内的随机整数，可使用以下公式：Int((upperbound － lowerbound ＋ 1) × Rnd ＋ lowerbound)这里，upperbound 是随机数范围的上限，而 lowerbound 则是随机数范围的下限。

另外，程序中还使用了INI文件，Windows INI文件,可解释为Windows初始化文件。

它是一种专门用来保存应用程序初始化信息和运行环境信息的文本文件。

ini文件是一种文本文件,它可以通过Notepad等文本编辑器进行编辑。

ini文件具有特定的格式。

一个INI 文件是由若干个段(section)组成的,每个段中包含若干关键字(key)及相应的值(value)。

创建应用程序自己的INI文件,通过INI文件保存应用程序的一些运行环境信息,然后在程序中读取INI文件中的设置信息并据以处理。

一旦程序的运行环境需要变更,则可以通过直接修改INI文件，或在程序中提供专门的界面间接地修改INI文件来保证程序的可用性。

源程序及注释如下：'窗体源程序Option ExplicitDim m_strNameArray() As MyNameDim m_bIsStart As BooleanDim m_nNameIndex As IntegerDim MAX_INDEX As IntegerDim m_nSelectNum As Integer'被选定数Dim nScrollStep As IntegerDim nScrollWidth As IntegerDim bScrollState As BooleanDim nEnableSecond As IntegerDim m_strTitle As StringDim m_strAppTitle As StringDim m_strScrollTitleLeft As StringDim m_strScrollTitleRight As StringPrivate Sub Command_Start_Stop_Click()If m_bIsStart = True Then'按停止钮m_bIsStart = FalseCommand_Start_Stop.Caption =“开始"Label_FlashName.Visible = TrueTimer_FlashName.Enabled = TrueTimer_ScrollName.Enabled = FalseLabel_FlashName =m_strNameArray（m_nNameIndex).strName ＋“中奖了！"m_strNameArray(m_nNameIndex).bIsSelect = Truem_nSelectNum = m_nSelectNum ＋ 1Dim Temp As MyNameTemp =m_strNameArray(MAX_INDEX)m_str Name Array(MAX－INDEX) = m_strNameArray(m_nNameIndex) m_strNameArray(m_nNameIndex) =TempMAX_INDEX = MAX_INDEX － 1If MAX_INDEX = 0 ThenMsgBox “非常感谢您使用本软件"End IfElse '按开始钮m_bIsStart = TrueCommand_Start_Stop.Caption = “停止" Command_Start_Stop.Enabled = False Timer_ScrollName.Enabled = TrueTimer_FlashName.Enabled = FalseLabel_FlashName.Caption = “"End IfEnd SubPrivate Sub Form_Load()Form_Bouns.ScaleMode = 3m_nNameIndex = 0m_bIsStart = FalseTimer_ScrollName.Enabled = TrueTimer_ScrollTitle.Enabled = True Label_FlashName.Visible = FalseLabel_ScrollName.Caption = “" nEnableSecond = 0'定义起始秒数ReDimNameArray'获得文本中的名字和打乱名字顺序nScrollStep = 5 '设定滚动字的步长nScrollWidth = Label_Congruation.Left'设定title的移动宽度bScrollState = False'设定缺省的开始滚动方向为向左m_nSelectNum = 0'初始化被选定数为0Init'初始化本程序的界面End SubPrivate Sub Timer_FlashName_Timer() '闪动中奖者姓名If Label_FlashName.Visible = True ThenLabel_FlashName.Visible = FalseElseLabel_FlashName.Visible = TrueEnd IfEnd SubPrivate Sub Timer_ScrollName_Timer() '滚动出现名字If m_bIsStart = True ThenIf m_nNameIndex >= MAX_INDEX Thenm_nNameIndex = 0End Ifm_nNameIndex =m_nNameIndex ＋ 1If m_strNameArray(m_nNameIndex).bIsSelect = True Then If m_nNameIndex <MAX－INDEX Thenm_nNameIndex =m_nNameIndex ＋ 1Elsem_nNameIndex = 0End IfEnd IfLabel_ScrollName.Caption = m_strNameArray(m_nNameIndex).strName'End IfEnd IfEnd SubPrivate Sub Timer_ScrollTitle_Timer() '滚动“恭喜发财"字样If bScrollState = False Then '向左滚nScrollStep = 10Label_Congruation.Caption = m_strScrollTitleLeftIf nScrollWidth > 0 ThennScrollWidth =nScrollWidth － nScrollStepElsebScrollState = TrueEnd IfElse '向右滚nScrollStep = －10Label_Congruation.Caption =m_strScrollTitleRightIf nScrollWidth < Form_Bouns.ScaleWidth － Label_Congruation.Width Then nScrollWidth =nScrollWidth － nScrollStepElsebScrollState = FalseEnd IfEnd IfLabel_Congruation.Left = nScrollWidth'以下为8秒钟内使“停止"按钮有效If nEnableSecond <= 49 ThenIf m_bIsStart = True ThennEnableSecond =nEnableSecond ＋ 1End IfElseIf m_bIsStart = True ThenCommand_Start_Stop.Enabled = TruenEnableSecond = 0End IfEnd IfEnd Sub'动态定义数组Private Sub ReDimNameArray()Dim strMaxIndex As StringDim nIndex As IntegerDim bIsBegin As BooleanbIsBegin = FalsenIndex = 0Open App.Path ＋“\name.txt" For Input As ＃1 '读文件Do Until EOF(1)If bIsBegin = False ThenLine Input ＃1, strMaxIndexnMaxIndex = Val(strMaxIndex)MAX_INDEX = nMaxIndex － 1ReDim m_strNameArray(0 To nMaxIndex － 1)bIsBegin = TrueElseLine Input ＃1, m_strNameArray(nIndex).strNamem_strNameArray(nIndex).bIsSelect = FalsenIndex = nIndex ＋ 1End IfLoop'以下为打乱人员顺序10次Dim i As IntegerDim j As IntegerDim Temp As StringFor j = 0 To 10For i = 0 To nMaxIndex － 1nRandomNum = ((nMaxIndex － 1) × Rnd) '利用Rnd函数Temp = m_strNameArray(i).strNamem_strNameArray(i).strName = m_strNameArray(nRandomNum).strNamem_strNameArray(nRandomNum).strName = TempNext iNext jEnd SubPrivate Sub Init() '读取INI文件Dim X As LongDim lpFileNameDim Temp As String × 50lpFileName = App.Path ＋“\Sortition.ini"X = GetPrivateProfileString(“SYSTEM",“AppTitle",“抽奖程序", Temp, Len(Temp), lpFileName)m_strAppTitle = Trim(Temp)Temp =“"X = GetPrivateProfileString(“SYSTEM", "Title", "欢迎使用抽奖程序", Temp, Len(Temp), lpFileName)m_strTitle = Trim(Temp)Temp = “"X = GetPrivateProfileString(“SYSTEM",“ScrollTitleRight", “恭喜发财!!!", Temp, Len(Temp), lpFileName) m_strScrollTitleRight = Trim(Temp)X = GetPrivateProfileString(“SYSTEM",“ScrollTitleLeft", “龙年大发!!!", Temp, Len(Temp), lpFileName)m_strScrollTitleLeft = Trim(Temp)Form_Bouns.Caption = m_strAppTitleLabel_CompanyTitle.Caption = m_strTitleEnd Sub模块源程序：'用于读取ini文件的API函数Declare Function GetPrivateProfileString Lib “kernel32" Alias “GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As LongPublic Type MyNamestrName As StringbIsSelect As BooleanEnd Type由于程序利用的windows ini文件保存一些标题信息，因而可以方便的修改使用环境,及标题内容。

VB编写各种趣味小程序(附代码)

VB编写各种趣味小程序（附代码）一、鸟巢绘制二、加密三、解密四、蝴蝶飞舞五、文本编辑六、统计七、小球跳动八、计算器（彩票摇奖）九、学生信息录入十、矩阵转置十一、带有进度条的倒计时程序十二、加减乘除随机数题十三、计算器十四、抽奖一、鸟巢绘制Private Sub Form_Click()ClsDim r, xi, yi, xj, yj, x0, y0, aif As Singler = Form10.ScaleHeight / 2x0 = Form10.ScaleWidth / 2y0 = Form10.ScaleHeight / 2n = 16aif = 3.14159 * 2 / nFor i = 1 To nxi = r * Cos(i * aif) + x0yi = r * Sin(i * aif) + y0For j = i To nxj = r * Cos(j * aif) + x0yj = r * Sin(j * aif) + y0Line (xi, yi)-(xj, yj), QBColor(i - 1)PSet (xi, yi)Print i - 1Next jNext iEnd SubPrivate Sub Form_Load()Print "要求：";Print "1.将圆周等分成16份；"Print "2.每个等分点要标记成0-16的数字；" Print "3.按样本图的图案画图。

"End Sub附图：二、加密Function code(ByVal s$, ByVal key%) Dim c As String * 1, iAsc%code = ""For i = 1 To Len(s)c = Mid$(s, i, 1)Select Case cCase "A" To "Z"iAsc = Asc(c) + keyIf iAsc > Asc("Z") Then iAsc = iAsc - 26 code = code + Chr(iAsc)Case "a" To "z"iAsc = Asc(c) + keyIf iAsc > Asc("z") Then iAsc = iAsc - 26 code = code + Chr(iAsc)Case Elsecode = code + cEnd SelectNext iEnd FunctionPrivate Sub close_Click()Form11.HideForm1.ShowEnd SubPrivate Sub Jiami_Click()Text2 = code(Text1, 2)End SubPrivate Sub open_Click()CommonDialog1.Action = 1Text1.Text = ""Open CommonDialog1.FileName For Input As #1Dim counter As IntegerDim workarea(25000) As StringProgressBar1.min = LBound(workarea)ProgressBar1.max = UBound(workarea)ProgressBar1.Visible = TrueProgressBar1.Value = ProgressBar1.minFor counter = LBound(workarea) To UBound(workarea) workarea(counter) = "initial value " & counter ProgressBar1.Value = counterNext counterDo While Not EOF(1)Line Input #1, inputdataText1.Text = Text1.Text + inputdata + vbCrLfLoopClose #1End SubPrivate Sub save_Click()CommonDialog1.FileName = "a1.txt"CommonDialog1.DefaultExt = "txt"CommonDialog1.Action = 2Open CommonDialog1.FileName For Output As #1Print #1, Text2.TextClose #1End Sub三、解密Function UnCode(ByVal s$, ByVal key%)Dim c As String * 1, iAsc%UnCode = ""For i = 1 To Len(s)c = Mid$(s, i, 1)Select Case cCase "A" To "Z"iAsc = Asc("c") - keyIf iAsc < Asc("A") Then iAsc = iAsc + 26UnCode = UnCode + Chr(iAsc)Case "a" To "z"iAsc = Asc(c) - keyIf iAsc < Asc("a") Then iAsc = iAsc + 26UnCode = UnCode + Chr(iAsc)Case ElseUnCode = UnCode + cEnd SelectNext iEnd FunctionPrivate Sub close_Click()Form2.HideForm1.ShowEnd SubPrivate Sub Jiemi_Click()Text2 = UnCode(Text1, 2)End SubPrivate Sub open_Click()CommonDialog1.Action = 1Text1.Text = ""Open CommonDialog1.FileName For Input As #1Dim counter As IntegerDim workarea(25000) As StringProgressBar1.min = LBound(workarea) ProgressBar1.max = UBound(workarea) ProgressBar1.Visible = TrueProgressBar1.Value = ProgressBar1.minFor counter = LBound(workarea) To UBound(workarea) workarea(counter) = "initial value " & counter ProgressBar1.Value = counterNext counterDo While Not EOF(1)Line Input #1, inputdataText1.Text = Text1.Text + inputdata + vbCrLfLoopClose #1End SubPrivate Sub save_Click()CommonDialog1.FileName = "a.txt" CommonDialog1.DefaultExt = "txt" CommonDialog1.Action = 2Open CommonDialog1.FileName For Output As #1 Print #1, Text2.TextClose #1End Sub四、蝴蝶飞舞Private Sub Form_Load()Print "蝴蝶飞出窗体后重新定位到左下方再向右上方飞" End SubPrivate Sub Timer1_Timer()Static PickBmp As IntegerIf PickBmp = 0 ThenImage1.Picture = Image2.PicturePickBmp = 1ElseImage1.Picture = Image3.PicturePickBmp = 0End IfCall mymoveEnd SubSub mymove()Image1.Move Image1.Left + 40, Image1.Top - 25If Image1.Top <= 0 ThenImage1.Left = 0Image1.Top = 2325End IfEnd Sub图：五、文本编辑Private Sub Copy_Click()Clipboard.ClearClipboard.SetText RichTextBox1.SelTextEnd SubPrivate Sub Cut_Click()Clipboard.ClearClipboard.SetText RichTextBox1.SelTextRichTextBox1.SelText = ""End SubPrivate Sub Exit_Click()Form3.HideForm1.ShowEnd SubPrivate Sub Font_Click()CommonDialog1.Flags = cdlCFBoth Or cdlCFEffects CommonDialog1.Action = 4RichTextBox1.FontName = CommonDialog1.FontName RichTextBox1.FontSize = CommonDialog1.FontSize RichTextBox1.FontBold = CommonDialog1.FontBold RichTextBox1.FontItalic = CommonDialog1.FontItalic RichTextBox1.FontStrikethru = CommonDialog1.FontStrikethru RichTextBox1.FontUnderline = CommonDialog1.FontUnderline RichTextBox1.ForeColor = CommonDialog1.ColorEnd SubPrivate Sub Form_Load()Print "注："Print "1.'打开'对话框的初始文件夹应是所要打开文件所在的" Print "文件夹，将提供的xz.txt文件打开；"Print "2.要实现将选定的内容格式化，必须在工具箱中添加" Print "RichTextBox控件（Microsoft Rich Textbox Comtrol 6.0）" Print "并在帮助菜单中查阅其字体设置的相关属性。

VB小程序VB代码：将图片保存或转变为JPG格式

VB小程序VB代码：将图片保存或转变为JPG格式当前位置： > VB小程序1-99 > 将图片保存或转变为 JPG 格式12. 将图片保存或转变为JPG格式本人原创，转载请注明出处：/100bd/blog/item/18d7448addbb9519c9fc7a1a.html'函数 SavePicToFile 把图象保存为 JPG、TIFF、PNG、GIF、BMP 格式。

成功返回空字符串，失败返回错误信息。

'需要在窗体放置控件：Command1，Picture1，Text1' '以下代码在 VB6 调试通过。

Private Type GUIDData1 As LongData2 As IntegerData3 As IntegerData4(0 To 7) As ByteEnd TypePrivate Type GdiplusStartupInputGdiplusVersion As LongDebugEventCallback As LongSuppressBackgroundThread As LongSuppressExternalCodecs As LongEnd TypePrivate Type EncoderParameternGUID As GUIDNumberOfValues As LongType As LongValue As LongEnd TypePrivate Type EncoderParametersCount As LongParameter As EncoderParameterEnd TypeEnum PicTypep_BMPp_JPGp_GIFp_PNGp_TIFFEnd EnumPrivate Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputb uf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As LongPrivate Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Lon g) As LongPrivate Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByV al hbm As Long, ByVal hPal As Long, BITMAP As Long) As LongPrivate Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Lo ng) As LongPrivate Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As LongPrivate Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id A s GUID) As LongPrivate Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveM emory" (Dest As Any, Src As Any, ByVal cb As Long) As LongPublic Function SavePicToFile(ByVal nPic As StdPicture, ByVal FileName As String, _Optional ByVal nType As PicType = p_JPG, Optional ByVal Quality As Byte = 80, _Optional ByVal TIFF_ColorDepth As Long = 24, Optional ByVal TIFF_Compression As Lo ng = 6) As String'功能：把图象保存为 BMP、JPG、GIF、PNG、TIFF 格式。

VB小程序代码实例

VB小程序代码实例VB小程序是一种基于Visual Basic语言开辟的应用程序，它可以在Windows 操作系统上运行。

本文将为您提供一个VB小程序代码实例，匡助您了解如何编写和运行一个简单的VB小程序。

代码实例如下：```vbImports SystemPublic Class HelloWorldPublic Shared Sub Main()Console.WriteLine("Hello, World!")Console.ReadLine()End SubEnd Class```上述代码是一个经典的“Hello, World!”程序，它会在控制台输出一条问候语，并等待用户按下回车键。

下面是代码解释：- `Imports System`：这个语句告诉编译器我们将使用System命名空间中的类和方法。

- `Public Class HelloWorld`：这是一个公共类的声明，类名为HelloWorld。

- `Public Shared Sub Main()`：这是程序的入口点，它是一个公共静态方法，程序从这里开始执行。

- `Console.WriteLine("Hello, World!")`：这行代码会在控制台输出一条问候语。

- `Console.ReadLine()`：这行代码会等待用户按下回车键，以便程序暂停执行。

您可以将上述代码复制到一个文本编辑器中，并将文件保存为`.vb`扩展名。

然后，使用VB编译器将其编译为可执行文件，并在Windows操作系统上运行。

这个简单的VB小程序只是一个入门示例，您可以根据自己的需求和兴趣编写更复杂的VB小程序。

VB语言具有丰富的特性和功能，可以用于开辟各种类型的应用程序，包括图形用户界面（GUI）应用程序、数据库应用程序、Web应用程序等。

希翼这个VB小程序代码实例能够匡助您入门VB编程，并为您今后的学习和开辟提供一些参考。

初学者API入门事例,VB锁屏小程序源码,及窗体布局!

自己编写的一个VB锁屏小程序里面涉及到的内容有：（主要的）API 窗体置顶（setwindowpos）获得活动窗体句柄（GetForegroundWindow）查找指定窗体句柄（findwindow）还有个窗体透明化的几个API，注释里面有标记下面是全部代码及窗体布局及运行效果：'窗口透明化申明语句，函数定义Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate 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 = &H80000Private Const GWL_EXSTYLE = (-20)Private Const LWA_ALPHA = &H2Private Const LWA_COLORKEY = &H1'消息（msgbog）函数声明Private Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long, ByVal wlange As Long, ByVal dwTimeout As Long) As Long'窗体前置API函数申明Private Declare Function GetForegroundWindow Lib "user32" () As LongPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate 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)Private num As Long '定义一变量来保存第一次输入的密码Private n As Long '定义一变量来记录密码输入格式规范（全数字密码），且按钮Cmd1按下的次数'定义一授权密码Private Const sc = 492158181密码部分编写代码Private Sub cmd1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)If IsNumeric(Text1.Text) Thenn = n + 1If n = 1 Thennum = Val(Text1.Text)Cmd2.Enabled = FalseText1.Text = ""cmd1.Caption = "请输入解锁密码"Form1.ShowForm2.ShowEnd IfIf Val(n) > 1 And Val(Text1.Text) = num ThenEndEnd IfIf n > 1 And Val(Text1.Text) <> num ThenMessageBoxTimeout Me.hWnd, "亲出错了，请想想再输入，.", "出错了", 48, 0, 2000Text1.Text = ""End IfElseMessageBoxTimeout Me.hWnd, "请输入全数字密码，.", "出错了", 48, 0, 2000Text1.Text = ""End IfEnd SubPrivate Sub Cmd2_Click()EndEnd Sub'软件授权密码编写Private Sub Form_Load()q = InputBox("请输入程序授权密码", "锁屏小程序", 0)If q <> sc Then EndForm2.Show '窗体2激活'窗体Dim th As Longth = GetWindowLong(hWnd, GWL_EXSTYLE)th = th Or WS_EX_LAYEREDSetWindowLong hWnd, GWL_EXSTYLE, thSetLayeredWindowAttributes hWnd, vbBlue, 230, LWA_COLORKEY Or LWA_ALPHA Form1.Width = Screen.WidthForm1.Height = Screen.HeightForm1.Top = 0Form1.Left = 0Form1.BackColor = vbBlueForm1.ForeColor = vbRed'文本框设置Text1.BackColor = RGB(65, 210, 79)Text1.ForeColor = vbRed'按钮（cmd1）设置cmd1.BackColor = RGB(65, 210, 79)'按钮Cmd2设置Cmd2.BackColor = RGB(65, 210, 79)'标签（lb1）设置lb1.BackColor = RGB(133, 87, 179)lb1.ForeColor = vbRed'框架设置Frm1.BackColor = RGB(133, 87, 179)Frm1.Top = Screen.Height / 4'lb2设置Lb2.BackColor = RGB(133, 87, 179)Lb2.ForeColor = vbRedTimer4.Enabled = False'img1的设置img1.Width = Form1.Widthimg1.Height = Form1.HeightEnd SubPrivate Sub Frm1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Timer7.Enabled = TrueEnd SubPrivate Sub Text1_Change()Timer7.Enabled = TrueEnd SubPrivate Sub Timer2_Timer()Dim h1, h2 As Longh1 = FindWindow(vbNullString, "锁屏小程序")h2 = GetForegroundWindow()If h1 <> h2 ThenCall SetWindowPos(h1, -1, 0, 0, 0, 0, 3) End IfEnd SubPrivate Sub Timer3_Timer()Frm1.Left = Frm1.Left - 30If Frm1.Left < 0 ThenTimer4.Enabled = True:Timer3.Enabled = FalseEnd IfEnd SubPrivate Sub Timer4_Timer()Frm1.Left = Frm1.Left + 30If Frm1.Left >= Form1.Width - Frm1.Width Then Timer4.Enabled = FalseTimer3.Enabled = TrueEnd IfEnd SubPrivate Sub Timer7_Timer() Timer8.Enabled = True Timer3.Enabled = False Timer4.Enabled = False Timer7.Enabled = False End SubPrivate Sub Timer8_Timer() Timer3.Enabled = True Timer4.Enabled = False Timer8.Enabled = False End Sub。