虚拟主机教程

'这是我写的一个自动创建FTP的程序，发出来供大家学习和使用，在线开通原理一样。
'无非就是要使asp有操作注册表权限，那就要将站点以admin身份运行，才能创建shell，这又是十分危险。

Dim ftpname,ftppass,webroot,disksize
 
ftpname="testftp3"
ftppass="abc123"
webroot="D:\wwwroot\test"
disksize= 512 * 1048576 '512MB

Set WshShell = CreateObject("wscript.Shell")
U1="HKEY_LOCAL_MACHINE\SOFTWARE\Cat Soft\Serv-U\Domains\1\UserList\"
U2="HKEY_LOCAL_MACHINE\SOFTWARE\Cat Soft\Serv-U\Domains\1\UserSettings\"
 
WshShell.RegWrite U1 & ftpname,"1|0"
WshShell.RegWrite U2 & ftpname & "\" ,Default
 
WshShell.RegWrite U2 & ftpname & "\Access1",  webroot&"|RWAMLCDP"
WshShell.RegWrite U2 & ftpname & "\DiskQuota",  "1|"&disksize&"|0"
WshShell.RegWrite U2 & ftpname & "\ChangePassword", "1"
WshShell.RegWrite U2 & ftpname & "\HomeDir",  webroot
WshShell.RegWrite U2 & ftpname & "\Password",  makeftpass(ftppass)
WshShell.RegWrite U2 & ftpname & "\RelPaths",  "1"
WshShell.RegWrite U2 & ftpname & "\SpeedLimitDown", "512000"
WshShell.RegWrite U2 & ftpname & "\SpeedLimitUp", "512000"
WshShell.RegWrite U2 & ftpname & "\TimeOut",  "600"
Set WshShell=nothing
WScript.Echo "OK"
 
Function makeftpass(byval pwd)
 Dim rt
 rt= Chr(97+Int(Rnd * 26))
 rt=rt & Chr(97+Int(Rnd * 26))
 makeftpass= UCase(md5(rt&pwd,32))
 makeftpass= rt&makeftpass
End Function
 
Function md5(byval strng,byval tp)
 Dim http,url
 url="http://www.suntw.com/demo/cmd5.asp?str=" & strng & "&t=" & tp
 Set http=CreateObject("MSXML2.XMLHTTP")
 http.open "GET",url,False
 http.send
 If http.status=200 Then md5=http.responseText
 Set http=Nothing
End Function

Private Sub Form_Load()
    Me.AutoRedraw = tre
    EnumWindows AddressOf EnumWindowsProc, ByVal 0&
End Sub
 
'上面是窗体中的代码，下面是模块中的代码，窗体上添个list控件  
Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
 
Public Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Boolean
    Dim sSave As String, Ret As Long
    Ret = GetWindowTextLength(hwnd)
    sSave = Space(Ret)
    GetWindowText hwnd, sSave, Ret + 1  '得到标题
    
    Form1.List1.AddItem Str$(hwnd) + " " + sSave
    EnumWindowsProc = True
End Function

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
 
Private Type POINTAPI
   x As Long
   y As Long
End Type
 
Private Sub Timer1_Timer()
   Dim hWnd As Long
   Dim NowPOINT As POINTAPI
   GetCursorPos NowPOINT    '将鼠标所在坐标赋给 nowpoint
   hWnd = WindowFromPoint(NowPOINT.x, NowPOINT.y) '获取 在指定坐标窗口的句柄
   Label1.Caption = hWnd
End Sub

'我只要个简单的功能，比如运行ipconfig能把回显读取到，网上找了没效果，要么就是大篇大篇的调用
'下面这个函数能实现，需要 WScript.Shell 组件(WSHom.ocx)和cmd.exe的支持，如果你禁用了那就没法了
'调用  msgbox dosprint("ipconfig")
Function dosprint(strCommand)
    Dim objShell As Object
    Set objShell = CreateObject("WScript.Shell")
    Set objWshScriptExec = objShell.Exec("c:\windows\system32\cmd.exe /c " & strCommand)
    Set objStdOut = objWshScriptExec.StdOut
    dosprint = objStdOut.ReadAll
    Set objShell = Nothing
End Function

'从文件导入策略到证书存储。跟上ipsec文件即可。
retCode = Shell("c:\WINDOWS\netsh.exe ipsec static importpolicy ""C:\myfire.ipsec""", vbHide)
'更改现存策略和相关信息。也就是说启用某个策略，填名字。
retCode = Shell("c:\WINDOWS\netsh.exe ipsec static set policy name=""myfire"" assign=y", vbHide)
'最后可以用这个来刷新组策略，理论上不用刷的，即时生效 
retCode = Shell("gpupdate.exe /force",vbHide)

Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
 
Private Sub Command1_Click()
mciSendString "play F:\KuGou\假如.mp3 from 0", vbNullString, 0, 0 '开始播放，后面的from 0 表示从哪个位置开始
'mciSendString "close F:\KuGou\假如.mp3", vbNullString, 0, 0   '关闭，同样还有暂停pause，停止stop
End Sub

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
 
Private Sub Command1_Click()
    Const SND_ASYNC = &H1&
    Const SND_LOOP = &H8&
    Const SND_MEMORY = &H4&
    Const SND_NODEFAULT = &H2&
    Const SND_NOSTOP = &H10&
    Const SND_SYNC = &H0&
    Dim bArr() As Byte, rc As Long
    bArr = LoadResData(101, "WAV")  '这两个参数是在引用文件属性中设置的，只是个标识
    rc = sndPlaySound(bArr(0), SND_MEMORY Or SND_ASYNC)  '这儿一定要设成从内存中和异步了
End Sub

'首先是声明，这些必不可少的，我已经精简了
Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwhandle As Long, ByVal dwlen As Long, lpData As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal Source As Long, ByVal length As Long)
Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
Private Type VS_FIXEDFILEINFO
   dwSignature As Long
   dwStrucVersionl As Integer     ' e.g. = &h0000 = 0
   dwStrucVersionh As Integer     ' e.g. = &h0042 = .42
   dwFileVersionMSl As Integer    ' e.g. = &h0003 = 3
   dwFileVersionMSh As Integer    ' e.g. = &h0075 = .75
   dwFileVersionLSl As Integer    ' e.g. = &h0000 = 0
   dwFileVersionLSh As Integer    ' e.g. = &h0031 = .31
End Type
'然后调用这个函数就行了，比如 msgbox readFileVersion("c:\windows\notepad.exe")
Function readFileVersion(ByVal fullfilename As String) As String
   Dim retCode As Long, sBuffer() As Byte
   Dim lBufferLen As Long, lVerPointer As Long, udtVerBuffer As VS_FIXEDFILEINFO
   Dim lVerbufferLen As Long
   '检查文件需要多大的缓冲区
   lBufferLen = GetFileVersionInfoSize(fullfilename, 0&)
   If lBufferLen < 1 Then
      readFileVersion = ""
      Exit Function
   End If
   ReDim sBuffer(lBufferLen)
   '读取文件版本信息
   retCode = GetFileVersionInfo(fullfilename, 0&, lBufferLen, sBuffer(0))
   retCode = VerQueryValue(sBuffer(0), "\", lVerPointer, lVerbufferLen)
   MoveMemory udtVerBuffer, lVerPointer, Len(udtVerBuffer)
   readFileVersion = Format$(udtVerBuffer.dwFileVersionMSh) & "." & Format$(udtVerBuffer.dwFileVersionMSl) & "." & Format$(udtVerBuffer.dwFileVersionLSh) & "." & Format$(udtVerBuffer.dwFileVersionLSl)
End Function