标题: 利用Director无fms的在线录音 [打印本页] 作者: 五星上将 时间: 2014-11-23 21:05 标题: 利用Director无fms的在线录音 实现一个在线录音,没有采用[url=]flash[/url] [url=]media[/url] [url=]server[/url],主要通过activex加[url=]director[/url]实现
流程为 activex检测本地有客户端软件 有则运行没有则下载最新的客户端程序
程序包括 一个activex,一个录音程序，一个上传程序
开发工具选择vb6.0,director mx 10.0
第一步 activex
建立模块文件，主要是activex安全脚本
Option Explicit
Public Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" _
(ByValdwDesiredAccess As Long, _
ByValbInheritHandle As Long, _
ByValdwProcessId As Long) As Long
Public Declare Function WaitForSingleObject Lib _
"kernel32" (ByValhHandle As Long, _
ByValdwMilliseconds As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Const IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
Public Const IID_IPersistStorage = _
"{0000010A-0000-0000-C000-000000000046}"
Public Const IID_IPersistStream = _
"{00000109-0000-0000-C000-000000000046}"
Public Const IID_IPersistPropertyBag = _
"{37D84F60-42CB-11CE-8135-00AA004BB851}"
Public Const INTERFACESAFE_FOR_UNTRUSTED_CALLER = &H1
Public Const INTERFACESAFE_FOR_UNTRUSTED_DATA = &H2
Public Const E_NOINTERFACE = &H80004002
Public Const E_FAIL = &H80004005
Public Const MAX_GUIDLEN = 40
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal ByteLen As Long)
Public Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As _
Any, ByVal lpstrClsId As Long, ByVal cbMax As Integer) As Long
Public Type udtGUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public m_fSafeForScripting As Boolean
Public m_fSafeForInitializing As Boolean
Sub Main()
m_fSafeForScripting = True
m_fSafeForInitializing = True
End Sub
控件窗口程序
'3D辅助插件
Implements IObjectSafety
Dim m_download As String
Dim m_param As String
Dim m_flag As Boolean
Dim m_run As String
Dim m_defautDir As String
Dim m_title As String
Const m_download_def = "http://www.faydu.cn/DownLoad/BxRecord.rar"
Const m_param_def = ""
Const m_flag_def = False
Const m_run_def = "BxRecord.exe"
Const m_title_def = "3D播放器"
Const m_defautDir_def = "d:"
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 1024
End Type
Private Const TH32CS_SNAPHEAPLIST = &H1
Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPTHREAD = &H4
Private Const TH32CS_SNAPMODULE = &H8
Private Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Private Const TH32CS_INHERIT = &H80000000
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private WM_TASKBARCREATED As Long
Public Sub CloseWin(exename As String)
Dim pid As Long
pid = FindPro(exename)
MsgBox pid
Dim mProcID As Long
mProcID = OpenProcess(1&, -1&, pid)
TerminateProcess mProcID, 0&
End Sub
Public Sub OpenWin(exename As String)
Dim pid As Long
pid = FindPro(exename)
Dim mProcID As Long
mProcID = OpenProcess(1&, -1&, mProcID)
MsgBox mProcID
TerminateProcess mProcID, 0&
End Sub
Private Sub IObjectSafety_GetInterfaceSafetyOptions(ByVal riid As _
Long, pdwSupportedOptions As Long, pdwEnabledOptions As Long)
Dim Rc As Long
Dim rClsId As udtGUID
Dim IID As String
Dim bIID() As Byte
pdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or _
INTERFACESAFE_FOR_UNTRUSTED_DATA
If (riid <> 0) Then
CopyMemory rClsId, ByVal riid, Len(rClsId)
Select Case IID
Case IID_IDispatch
pdwEnabledOptions = IIf(m_fSafeForScripting, _
INTERFACESAFE_FOR_UNTRUSTED_CALLER, 0)
Exit Sub
Case IID_IPersistStorage, IID_IPersistStream, _
IID_IPersistPropertyBag
pdwEnabledOptions = IIf(m_fSafeForInitializing, _
INTERFACESAFE_FOR_UNTRUSTED_DATA, 0)
Exit Sub
Case Else
On Error Resume Next
Err.Raise E_NOINTERFACE
Exit Sub
End Select
End If
End Sub
Private Sub IObjectSafety_SetInterfaceSafetyOptions(ByVal riid As _
Long, ByVal dwOptionsSetMask As Long, ByVal dwEnabledOptions As Long)
Dim Rc As Long
Dim rClsId As udtGUID
Dim IID As String
Dim bIID() As Byte
If (riid <> 0) Then
CopyMemory rClsId, ByVal riid, Len(rClsId)
Select Case IID
Case IID_IDispatch
If ((dwEnabledOptions And dwOptionsSetMask) <> _
INTERFACESAFE_FOR_UNTRUSTED_CALLER) Then
Err.Raise E_FAIL
Exit Sub
Else
If Not m_fSafeForScripting Then
Err.Raise E_FAIL
End If
Exit Sub
End If
Case IID_IPersistStorage, IID_IPersistStream, _
IID_IPersistPropertyBag
If ((dwEnabledOptions And dwOptionsSetMask) <> _
INTERFACESAFE_FOR_UNTRUSTED_DATA) Then
Err.Raise E_FAIL
Exit Sub
Else
If Not m_fSafeForInitializing Then
'Err.Raise E_FAIL
End If
Exit Sub
End If
Case Else
'Err.Raise E_NOINTERFACE
Exit Sub
End Select
End If
End Sub
Function Getdir(strFileName As String) As String
Dim strTmp As String
Dim strByte As String
Dim temp As Integer
Dim i As Long
For i = 1 To Len(strFileName)
strByte = Mid(strFileName, i, 1)
If strByte = "\" Then
temp = i
End If
Next i
Getdir = Mid(strFileName, 1, temp)
End Function
Private Function GetExtName(strFileName As String) As String
Dim strTmp As String
Dim strByte As String
Dim i As Long
For i = Len(strFileName) To 1 Step -1
strByte = Mid(strFileName, i, 1)
If strByte <> "." Then
strTmp = strByte + strTmp
Else
Exit For
End If
Next i
GetExtName = strTmp
End Function
Private Function search(ByVal strPath As String, Optional strSearch As String = "") As Boolean
Dim strFileDir() As String
Dim strFile As String
Dim i As Long
Dim lDirCount As Long
On Error GoTo MyErr
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
Dim fist As String
fist = Dir("d:\BxRecord\", vbNormal)
If fist <> "" Then
If fist = "BxRecord.exe" Then
m_flag = True
List1.AddItem "d:\BxRecord\BxRecord.exe" '将文件全名保存至列表框List1中
search = True
Exit Function
End If
End If
strFile = Dir(strPath, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)
While strFile <> "" '搜索当前目录
DoEvents
If (GetAttr(strPath + strFile) And vbDirectory) = vbDirectory Then '如果找到的是目录
If strFile <> "." And strFile <> ".." Then '排除掉父目录(..)和当前目录(.)
lDirCount = lDirCount + 1 '将目录数增1
ReDim Preserve strFileDir(lDirCount) As String
strFileDir(lDirCount - 1) = strFile '用动态数组保存当前目录名
End If
Else
If strSearch = "" Then
ElseIf LCase(strFile) = LCase(strSearch) Then
m_flag = True
'满足搜索条件，则处理该文件
List1.AddItem strPath + strFile '将文件全名保存至列表框List1中
search = True
Exit Function
End If
End If
strFile = Dir
Wend
For i = 0 To lDirCount - 1
lbl.Caption = strPath + strFileDir(i)
If Not m_flag Then
Call search(strPath + strFileDir(i), strSearch) '递归搜索子目录
End If
Next
ReDim strFileDir(0) '将动态数组清空
search = False '搜索成功
Exit Function
MyErr:
search = False '搜索失败
End Function
Public Sub RunList(i As Integer)
If List1.ListCount >= i Then
makerun (i)
End If
End Sub
Public Sub ListFiles(filename As String)
If List1.ListCount >= 1 Then List1.Clear
m_flag = False
Dim strDrvLst As String
search m_defautDir_def, m_run_def
If List1.ListCount >= 1 Then
makerun (0)
Else
If MsgBox("下载该文件吗？", vbOKCancel, "菲度科技,为下次使用方便请保存在D盘目录下!") = vbOK Then
Dim lr As Long
lr = ShellExecute(0, "Open", m_download_def, "", "", vbNormalFocus)
If (lr < 0) Or (lr > 32) Then
Else
MsgBox "无法打开 ′" & m_download & "′,服务器出现问题", vbInformation
End If
End If
End If
End Sub
'定义下载连接属性
Public Property Let DownLoad(vnewvalue As String)
m_download = vnewvalue
End Property
Public Property Get DownLoad() As String
DownLoad = m_download
End Property
'定义执行文件名称
Public Property Let Exe(vnewvalue As String)
m_run = vnewvalue
End Property
Public Property Get Exe() As String
Exe = m_run
End Property
'定义3D程序所需参数
Public Property Let PlayUrl(vnewvalue As String)
m_param = vnewvalue
End Property
Public Property Get PlayUrl() As String
PlayUrl = m_param
End Property
'定义标志位,代表是否调用3D程序
Public Property Let Flag(vnewvalue As Boolean)
m_flag = vnewvalue
End Property
Public Property Get Flag() As Boolean
Flag = m_flag
End Property
'定义运行标题
Public Property Let Title(vnewvalue As String)
m_title = vnewvalue
End Property
Public Property Get Title() As String
Title = m_title
End Property
Public Property Let DefaultDir(vnewvalue As String)
m_defautDir = vnewvalue
End Property
Public Property Get DefaultDir() As String
m_defautDir = vnewvalue
End Property
Private Sub makerun(Idx As Integer)
Dim lr As Long
'lr = Shell(, vbNormalFocus)
lr = ShellExecute(0, "Open", List1.List(Idx), m_param, Getdir(List1.List(Idx)), vbNormalFocus)
m_flag = True
Dim hHandle As Long
Private Sub Command1_Click()
lbl.Caption = "正在检查您是否安装了客户端..."
m_flag = False
Call ListFiles(m_run)
End Sub
Public Function GetState() As Boolean
If Not m_flag Then
GetState = False
Exit Function
Else
If FindPro(m_run) = -1 Then
GetState = True
Exit Function
End If
End If
GetState = False
End Function
Public Function FindPro(jinchenming As String) As Integer
Dim my As PROCESSENTRY32
Dim l As Long
Dim l1 As Long
Dim mName As String
Dim i As Integer
l = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
If l Then
my.dwSize = 3000
If (Process32First(l, my)) Then
Do
i = InStr(1, my.szExeFile, Chr(0))
mName = LCase(Left(my.szExeFile, i - 1))
If mName = LCase(jinchenming) Then
pid = my.th32ProcessID
FindPro = my.th32ProcessID
Exit Function
End If
Loop Until (Process32Next(l, my) < 1)
End If
l1 = CloseHandle(l)
End If
FindPro = -1
End Function
Public Sub ListDriver(p As String)
End Sub
Private Sub Label1_Click()
lr = ShellExecute(0, "Open", m_download_def, "", "", vbNormalFocus)
If (lr < 0) Or (lr > 32) Then
Else
MsgBox "无法打开 ′" & m_download & "′,服务器出现问题", vbInformation
End If
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_download = PropBag.ReadProperty("DownLoad", m_download_def)
m_run = PropBag.ReadProperty("Exe", m_run_def)
m_flag = PropBag.ReadProperty("Flag", m_flag_def)
m_param = PropBag.ReadProperty("PlayUrl", m_param_def)
m_title = PropBag.ReadProperty("Title", m_title_def)
m_defautDir = PropBag.ReadProperty("DefaultDir", m_defautDir_def)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("DownLoad", m_download, m_download_def)
Call PropBag.WriteProperty("Exe", m_run, m_run_def)
Call PropBag.WriteProperty("Flag", m_flag, m_flag_def)
Call PropBag.WriteProperty("PlayUrl", m_param, m_param_def)
Call PropBag.WriteProperty("Title", m_title, m_title_def)
Call PropBag.WriteProperty("DefaultDir", m_defautDir, m_defautDir_def)
End Sub
这里要添加对接口IObjectSafety的实现，打包后进行数字签名（不叙述了） 作者: 五星上将 时间: 2014-11-23 21:06
这里也可以通过其他的方式实现,但是director实现快速写
moviescript
global gRecorderFile,record
global startPage,upLoadPage,waitKey
on startmovie
--初始显示也面
startPage="http://127.0.0.1/Record/Start.asp"
--播放显示也面
upLoadPage="http://127.0.0.1/Record/Play.asp"
waitKey="none"
end if
on changeIco
if record then
startRecord
else
if soundbusy(1) then sound close(1)
axStopRecording()
end if
end if
end
on startRecord me
gRecorderFile=the moviepath & "SuoNet.wav"
if(baFileExists(gRecorderFile)) then
baDeleteFile(gRecorderFile)
end if
err = axOpenRecorder(0)
return axRecordSoundToFile("record",gRecorderFile)
end
[attach]1984[/attach]
如图所示
第一正
global record,loadKey
global startPage,upLoadPage,waitKey
on beginsprite
record=false
loadKey=0
member("info").text="您现在可以点击下列第一个按钮开始录音"
cursor(280)
end
on exitFrame me
case (loadKey) of
0:
Navigate(sprite 9, startPage )
set loadKey=1
1:
if (record) then
axServiceRecording()
end if
"waitUpload":
keyread= bareadRegString( "Software\Microsoft\", "serverName" , "", "HKEY_LOCAL_MACHINE")
if keyread<>"" then
Navigate(sprite 9, upLoadPage&"?Playfile="&keyread )
set loadKey=1
member("info").text="保存完成!"
bawriteRegString( "Software\Microsoft\", "serverName" , "", "HKEY_LOCAL_MACHINE")
end if
end case
go to the frame
end
按牛代码依次为:
录音:
global record,startPage
on mouseUp me
Navigate(sprite 9, startPage )
if soundbusy(1) then sound close(1)
record=true
changeIco
member("info").text="正在录音...."
end
停止:
global record
on mouseUp me
record=false
changeIco
member("info").text="录音完毕！"
end
播放:
global gRecorderFile
on mouseUp me
if soundbusy(1) then sound close(1)
if gRecorderFile<>void then
if baFileExists(gRecorderFile) then
axDeleteSound("mysound")
axLoadSoundIntoRAM("mysound", gRecorderFile)
sound playfile 1,gRecorderFile
end if
end if
member("info").text="正在播放..."
end
上穿
global upLoadPage,gRecorderFile,waitKey,loadKey
on mouseUp me
if gRecorderFile=void then
alert("对不起你的机器没有录音文件")
else
if(baFileExists(gRecorderFile)) then
bawriteRegString( "Software\Microsoft\", "CurrentFile" , gRecorderFile, "HKEY_LOCAL_MACHINE")
--
member("info").text="保存文件..."
open the moviepath & "upload.exe"
set loadKey="waitUpload"
else
alert("对不起,"&gRecorderFile&"不存在！无法上传")
end if
end if
end
这里有两个插件的使用
AudioXtra.x32
budapi.x32
以及一个上穿程序upload.exe作者: 五星上将 时间: 2014-11-23 21:07
这里就是个vb实现的ftp程序
添加一个模块
Option Explicit
Public Declare Function FtpGetFile Lib "WinInet" Alias "FtpGetFileA" _
(ByVal hFtpSessions As Long, ByVal lpszRemoteFile As String, ByVal _
lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal _
dwLocalFlagAndAttributes As Long, ByVal dwInternetFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function InternetOpen Lib "WinInet" Alias "InternetOpenA" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName _
As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Public Declare Function InternetConnect Lib "WinInet" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal lpszServerName As String, ByVal nServerPort _
As Integer, ByVal lpszUsername As String, ByVal lpszPassword As String, ByVal _
dwService As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare Function InternetCloseHandle Lib "WinInet" _
Alias "InternetCloseHandleA" (ByVal hInet As Long) As Long
Public Declare Function InternetGetLastResponseInfo Lib "WinInet" _
Alias "InternetGetLastResponseInfoA" (ByRef lpdwError As Long, _
ByVal lpszBuffer As String, ByRef lpdwBufferLength As Long) As Boolean
Public Declare Function FtpPutFile Lib "WinInet" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile _
As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Public Declare Function GetLastError Lib "kernel32" () As Long
Public Declare Function FtpGetCurrentDirectory Lib "WinInet" Alias _
"FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectoty _
As String, ByRef lpdwCurrentDirectory As Long) As Long
Public Declare Function FtpSetCurrentDirectory Lib "WinInet" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory _
As String) As Boolean
Public ftpvr As Integer
Public firRun As Boolean
--以上是ft[的api
以下一个读取注册表模块
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, source As Any, ByVal numBytes As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" _
(ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
'//注册表 API 函数声明
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, lpType As Long, lpData As Any, _
lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpbData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
ByVal lpClass As String, ByVal dwOptions As Long, _
ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, _
phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, _
lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal ipValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
lpValue As Byte, ByVal cbData As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
(ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, _
ByVal lpReserved As Long, lpcSubKeys As Long, _
lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, _
lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, _
lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValueInt Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegEnumValueStr Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegEnumValueByte Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
lpData As Byte, lpcbData As Long) As Long
'//注册表结构
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'//注册表访问权
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = &H3F
'//打开/建立选项
Const REG_OPTION_NON_VOLATILE = 0&
Const REG_OPTION_VOLATILE = &H1
'//Key 创建/打开
Const REG_CREATED_NEW_KEY = &H1
Const REG_OPENED_EXISTING_KEY = &H2
'//预定义存取类型
Const STANDARD_RIGHTS_ALL = &H1F0000
Const SPECIFIC_RIGHTS_ALL = &HFFFF
'//严格代码定义
Const ERROR_SUCCESS = 0&
Const ERROR_ACCESS_DENIED = 5
Const ERROR_NO_MORE_ITEMS = 259
Const ERROR_MORE_DATA = 234 '// 错误
'//注册表值类型列举
Private Enum RegDataTypeEnum
' REG_NONE = (0) '// No value type
REG_SZ = (1) '// Unicode nul terminated string
REG_EXPAND_SZ = (2) '// Unicode nul terminated string w/enviornment var
REG_BINARY = (3) '// Free form binary
REG_DWORD = (4) '// 32-bit number
REG_DWORD_LITTLE_ENDIAN = (4) '// 32-bit number (same as REG_DWORD)
REG_DWORD_BIG_ENDIAN = (5) '// 32-bit number
' REG_LINK = (6) '// Symbolic Link (unicode)
REG_MULTI_SZ = (7) '// Multiple, null-delimited, double-null-terminated Unicode strings
' REG_RESOURCE_LIST = (8) '// Resource list in the resource map
' REG_FULL_RESOURCE_DESCRIPTOR = (9) '// Resource list in the hardware description
' REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum
'//注册表基本键值列表
Public Enum RootKeyEnum
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA_WIN2K_ONLY = &H80000004 '//仅Win2k
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
'// for specifying the type of data to save
Public Enum RegValueTypes
eInteger = vbInteger
eLong = vbLong
eString = vbString
eByteArray = vbArray + vbByte
End Enum
'//保存时指定类型
Public Enum RegFlags
IsExpandableString = 1
IsMultiString = 2
'IsBigEndian = 3 '// 无指针同样不要设置大Endian值
End Enum
Private Const ERR_NONE = 0
Function SetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, ByVal Value As Variant, valueType As RegValueTypes, _
Optional Flag As RegFlags = 0) As Boolean
Dim handle As Long
Dim lngValue As Long
Dim strValue As String
Dim binValue() As Byte
Dim length As Long
Dim retVal As Long
Dim SecAttr As SECURITY_ATTRIBUTES '//键的安全设置
'//设置新键值的名称和默认安全设置
SecAttr.nLength = Len(SecAttr) '//结构大小
SecAttr.lpSecurityDescriptor = 0 '//默认安全权限
SecAttr.bInheritHandle = True '//设置的默认值
'// 打开或创建键
'If RegOpenKeyEx(hKey, KeyName, 0, KEY_ALL_ACCESS, handle) Then Exit Function
retVal = RegCreateKeyEx(hKey, KeyName, 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, SecAttr, handle, retVal)
If retVal Then Exit Function
'//3种数据类型
Select Case VarType(Value)
Case vbByte, vbInteger, vbLong '// 若是字节, Integer值或Long值...
lngValue = Value
retVal = RegSetValueExLong(handle, ValueName, 0, REG_DWORD, lngValue, Len(lngValue))
Case vbString '// 字符串, 扩展环境字符串或多段字符串...
strValue = Value
Select Case Flag
Case IsExpandableString
retVal = RegSetValueEx(handle, ValueName, 0, REG_EXPAND_SZ, ByVal strValue, 255)
Case IsMultiString
retVal = RegSetValueEx(handle, ValueName, 0, REG_MULTI_SZ, ByVal strValue, 255)
Case Else '// 正常 REG_SZ 字符串
retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, 255)
End Select
Case Else '// 如果其它类型
RegCloseKey handle
'Err.Raise 1001, , "不支持的值类型"
End Select
'// 返回关闭结果
RegCloseKey handle
'// 返回写入成功结果
SetRegistryValue = (retVal = 0)
End Function
Function GetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
Const KEY_READ = &H20019
'// 若resBinary 太小则重读
If retVal = ERROR_MORE_DATA Then
'// resBinary放大,且重新读取
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If
'// 返回相应值类型
Select Case valueType
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
'// REG_DWORD 和 REG_DWORD_LITTLE_ENDIAN 相同
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_DWORD_BIG_ENDIAN
'// Big Endian's 用在非-Windows环境, 如Unix系统, 本地计算机远程访问
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = SwapEndian(resLong)
Case REG_SZ, REG_EXPAND_SZ
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
If valueType = REG_EXPAND_SZ Then
'// 查询对应的环境变量
GetRegistryValue = ExpandEnvStr(resString)
Else
GetRegistryValue = resString
End If
Case REG_MULTI_SZ
'// 复制时需指定2个空格符
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else ' 包含 REG_BINARY
'// resBinary 调整
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
End Select
'// 关闭
RegCloseKey handle
End Function
Public Function DeleteRegistryValueOrKey(ByVal hKey As RootKeyEnum, RegKeyName As String, _
ValueName As String) As Boolean
'//删除注册表值和键,如果成功返回True
Dim lRetval As Long '//打开和输出注册表键的返回值
Dim lRegHWND As Long '//打开注册表键的句柄
Dim sREGSZData As String '//把获取值放入缓冲区
Dim lSLength As Long '//缓冲区大小. 改变缓冲区大小要在调用之后
Option Explicit
Dim hInterSi As Long
Dim hInter As Long
Dim sendFileName As String
Dim fileext As String
Dim sendflag As Boolean
Const uploadpath = "/htdocs/vidio/Upload/" '这里为你的文件上传目录
Sub send2Server(seversidename As String)
Dim buff1 As String
Dim buff2 As String
buff1 = Space$(64): buff2 = Space$(128)
hInter = InternetOpen("faydu.cn", 4, vbNullString, vbNullString, 0)
hInterSi = InternetConnect(hInter, Trim("ftp的ip地址"), 21, Trim("用户名"), Trim("密码"), 1, 0, 0)
Dim i As Boolean
i = FtpSetCurrentDirectory(hInterSi, uploadpath)
If i Then
FtpGetCurrentDirectory hInterSi, buff1, Len(buff1)
FtpPutFile hInterSi, sendFileName, seversidename, 1, 0
Label2.Caption = "上传完毕"
Call SetRegistryValue(HKEY_LOCAL_MACHINE, "SoftWare\Microsoft\", "serverName", "Upload/" & seversidename, eString)
End
Else
Label2.Caption = "连接服务器失败"
End If
End Sub
Function mskeFile() As String
Dim y, m, d, h, min, s
y = Year(Now)
m = Month(Now)
d = Day(Now)
h = Hour(Now)
min = Minute(Now)
s = Second(Now)
mskeFile = y & m & m & d & h & min & s
End Function
Function getReccordfile() As String
Dim va As Variant
va = GetRegistryValue(HKEY_LOCAL_MACHINE, "SoftWare\Microsoft\", "CurrentFile")
If Not IsEmpty(va) Then
If CStr(va) <> "" Then
sendFileName = CStr(va)
End If
Else
sendFileName = ""
End If
getReccordfile = sendFileName
End Function
Function ext(filename As String) As String
Dim i As Integer
Dim temp As Integer
i = InStr(1, filename, "\")
temp = i
While i <> 0
temp = i
i = InStr(i + 1, filename, "\")
Wend
Dim filerealName As String
filerealName = Mid(filename, temp + 1, Len(filename) - temp)
Dim dotpos As Integer
dotpos = InStr(1, filerealName, ".")
ext = Mid(filerealName, dotpos + 1, Len(filerealName) - dotpos)
End Function
Private Sub Form_Load()
sendflag = False
sendFileName = getReccordfile
If sendFileName <> "" Then
Me.Timer1.Enabled = True
sendflag = True
End If
End Sub
Private Sub Timer1_Timer()
If sendflag Then
sendflag = False
fileext = ext(sendFileName)
If Trim(fileext) = "wav" Then
Dim servername As String
servername = mskeFile & "." & fileext
send2Server (servername)
End If
End If
End Sub作者: gxj000 时间: 2014-11-23 21:52
谢谢楼主提供分享！！作者: yipingzi 时间: 2015-1-21 11:40
逛一逛，看一看。