哪位高手帮忙把下面vb代码转为delphi的?谢谢啊(200分)

  • 主题发起人 主题发起人 huxhang
  • 开始时间 开始时间
H

huxhang

Unregistered / Unconfirmed
GUEST, unregistred user!
' 程序一:从网页上精确提取数据
'
' 为运行本程序,应在“菜单->工程->部件”中添加“Microsoft Internet Controls”
' 并在“菜单->工程->引用”中添加“Microsoft HTML Object Library”
'
' 为了简洁,程序仅下载九只个股的基本信息
Option Explicit
Private Const Form_ID = 1
Dim Code(9) As String
Dim Current As Long
Private Sub Form_Load()
Form1.MousePointer = 11
' 以下是个股代码
' 为了程序简洁,这里仅使用九只代码。
' 而在真实环境中,应从数据文件中读入全部个股代码。
Code(0) = "600001": Code(1) = "600002": Code(2) = "600003"
Code(3) = "600005": Code(4) = "600006": Code(5) = "600007"
Code(6) = "600008": Code(7) = "600009": Code(8) = "600010"
Current = 0
WebBrowser1.Navigate "www.stockstar.com.cn" ' 起始网址
End Sub
Private Sub WebBrowser1_DocumentComplete(ByValpDisp As Object, URL As Variant)
Dim i, k
Text2 = WebBrowser1.LocationURL ' 显示当前网址
' 判断当前网页是否全部调入完毕
If Not (pDisp Is WebBrowser1.Object) then
Exit Sub
On Error Resume Next
Select Case Text2
Case "http://www.stockstar.com.cn/home.htm" ' 当进入主页面时执行以下程序
For i = 0 To WebBrowser1.Document.Forms(Form_ID).length - 1
' 找到代码输入框后填入个股代码
If WebBrowser1.Document.Forms(Form_ID)(i).Name = "code" then
_
WebBrowser1.Document.Forms(Form_ID)(i).Value = Code(Current)
' 在下拉式列表中进行选择
If WebBrowser1.Document.Forms(Form_ID)(i).Name = "target" then
For k = 0 To WebBrowser1.Document.Forms(Form_ID)(i).length - 1
If WebBrowser1.Document.Forms(Form_ID)(i).Options(k).Text _
= "个股资料" then
WebBrowser1.Document.Forms(Form_ID)(i).Options(k).Selected = True
Exit For
End If
Next k
End If
' 点击按钮
If WebBrowser1.Document.Forms(Form_ID)(i).Value = " 查询 " then
_
WebBrowser1.Document.Forms(Form_ID)(i).Click
Next
Case else
' 当进入数据页面时执行以下程序
For i = 0 To WebBrowser1.Document.All.length - 1
If WebBrowser1.Document.All(i).tagName = "PRE" then
' 精确提取数据
Text1 = Text1 + Code(Current) + vbCrLf + _
WebBrowser1.Document.All(i).innerText + vbCrLf
Exit For
End If
Next
' 数据存盘
Open "C:/Data2.Txt" For Append As #1
Print #1, Text1: Text1 = "": Close #1
' 换下一只股票
Current = Current + 1
If Current >= 9 then
' 上网任务完成后,应在此调用自动挂断过程。
Form1.MousePointer = 0: MsgBox "Finished!": End
End If
' 回退到主页面,查询下一只股票的信息
WebBrowser1.GoBack
End Select
End Sub

///=======================================================
' 程序二:将网页上的二维表导入数据库
'
' 为运行本程序,应在“菜单->工程->部件”中添加“Microsoft Internet Controls”
' 并在“菜单->工程->引用”中添加“Microsoft HTML Object Library”
'
Option Explicit
Dim Page As Long
Private Sub Form_Load()
Form1.MousePointer = 11
WebBrowser1.Navigate "www.stockstar.com.cn" ' 起始网址
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Dim Table1 As HTMLTable, Tables As IHTMLElementCollection
Dim Row As HTMLTableRow, Cell As HTMLTableCell
Dim i, j, tmp
Text2 = WebBrowser1.LocationURL ' 显示当前网址
' 判断当前网页是否全部调入完毕
If Not (pDisp Is WebBrowser1.Object) then
Exit Sub
On Error Resume Next
Select Case Text2
Case "http://www.stockstar.com.cn/home.htm" ' 当进入主页面时执行以下程序
' 用户注册登录
For i = 0 To WebBrowser1.Document.Forms(0).length - 1
' 找到 CheckBox 后,将其值改为 False,以防止用户名及密码被存储
If WebBrowser1.Document.Forms(0)(i).Name = "checkSavePW" then
_
WebBrowser1.Document.Forms(0)(i).Checked = False
If WebBrowser1.Document.Forms(0)(i).Name = "userId" then
_
WebBrowser1.Document.Forms(0)(i).Value = "kompass_china"
If WebBrowser1.Document.Forms(0)(i).Name = "passwd" then
_
WebBrowser1.Document.Forms(0)(i).Value = "kompass1"
' 此处是按名字访问按钮(上例中是按值访问按钮)
If WebBrowser1.Document.Forms(0)(i).Name = "continue" then
_
WebBrowser1.Document.Forms(0)(i).Click
Next
Case "http://my.stockstar.com/scripts/mystockstar.dll?login"
' 当用户登录完成后,准备打开表格的第一页
WebBrowser1.Navigate "http://finance.stockstar.com/scripts/finance.dll?" + _
"showstkdfpm&
begin
=0&ret=1&index=2&concode=01"
Page = 1
Case else
' 当进入数据页面(表格的第一页至最后一页)时执行以下程序
Set Tables = WebBrowser1.Document.getElementsByTagName("Table")
For Each Table1 In Tables
If Left(Table1.innerText, 2) = "名次" then
' 找到需要的Table
' 将表格转换成“.csv”格式
For i = 1 To Table1.rows.length - 1
Set Row = Table1.rows(i)
j = 0
For Each Cell In Row.cells
Text1 = Text1 + Trim(Row.cells(j).innerText) + ","
j = j + 1
Next
Text1 = Left(Text1, Len(Text1) - 1) + vbCrLf
Next
' 数据存盘
Open "C:/Data.csv" For Append As #1
Print #1, Left(Text1, Len(Text1) - 2): Text1 = "": Close #1
Exit For
End If
Next
' 准备打开下一页
Page = Page + 1
tmp = "http://finance.stockstar.com/scripts/finance.dll?showstkdfpm&ret=" + _
Trim(Str(Page)) + "&index=2&concode=01"
If Page <= 54 then
' 判断是否浏览结束
WebBrowser1.Navigate tmp
else
' 上网任务完成后,应在此调用自动挂断过程。
Form1.MousePointer = 0
MsgBox "Finished!!": End
End If
End Select
End Sub

//======================================================
' 程序三:自动拨号、自动挂断以及自动处理中途掉线
'
Option Explicit
' 有关 wininet 的全局定义
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2
Private Const INTERNET_CONNECTION_MODEM = 1
Private Declare Function InternetAutodial Lib "wininet.dll" _
(ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetAutodialHangup Lib _
"wininet.dll" (ByVal dwReserved As Long) As Long
Private Declare Function InternetGetConnectedState Lib _
"wininet.dll" (ByRef lpdwFlags As Long, ByVal _
dwReserved As Long) As Long
' 有关“窗口查找”的全局定义
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_SHOW = 5
' 有关 RAS 的全局定义
Private Const RASCS_DONE = &amp;H2000&amp;
Private Const RAS_MaxEntryName = 256
Private Const RAS_MaxDeviceType = 16
Private Const RAS_MaxDeviceName = 128
Private Type RASCONN
dwSize As Long
hRasConn As Long
szEntryName(RAS_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) As Byte
End Type
Private Type RASCONNSTATUS
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) As Byte
End Type
Private Ras_Buf(255) As RASCONN
Private Ras_Status As RASCONNSTATUS
Private lpcb As Long
Private lpcConnections As Long
Private Declare Function RasEnumConnections Lib _
"rasapi32.dll" Alias "RasEnumConnectionsA" (lprasconn _
As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib _
"rasapi32.dll" Alias "RasGetConnectStatusA" (ByVal _
hRasConn As Long, lpRASCONNSTATUS As Any) As Long
Private Declare Function RasHangUp Lib "rasapi32.dll" _
Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
' 有关“注册表”的全局定义
Private Const HKEY_LOCAL_MACHINE = &amp;H80000002
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias _
"RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String, phkResult 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 RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Dim ret As Long
'自动拨号
Private Sub wininet拨号测试_Click()
If InternetAutodial(INTERNET_AUTODIAL_FORCE_UNATTENDED, 0) _
then
MsgBox "已连接(wininet法)"
End Sub
Private Sub rnaui拨号测试_Click()
ret = Shell("rundll32.exe rnaui.dll,RnaDial " + Text1, 1):do
Events
SendKeys "{enter}", True:do
Events
End Sub
'检查是否断线
Private Sub wininet方法_Click() ' wininet法检查是否断线
If InternetGetConnectedState(INTERNET_CONNECTION_MODEM, 0) then
MsgBox "在线."
else
MsgBox "当前未连接。"
End If
End Sub
Private Sub 查找窗口法_Click() ' 查找窗口法检查是否断线
ret = FindWindow("#32770", "重新连接")
If ret <> 0 then
Call ShowWindow(ret, SW_SHOW)
SendKeys "{enter}", True: Exit Sub
End If
ret = FindWindow("#32770", "连接到 The95963")
If ret <> 0 then
MsgBox "在线."
else
MsgBox "当前未连接。"
End If
End Sub
Private Sub RAS方法_Click() ' RAS方法检查是否断线
Ras_Buf(0).dwSize = Len(Ras_Buf(0)) + 1
lpcb = 256 * Ras_Buf(0).dwSize
ret = RasEnumConnections(Ras_Buf(0), lpcb, lpcConnections)
If ret then
MsgBox "出错!": Exit Sub
End If
Ras_Status.dwSize = Len(Ras_Status) + 2
ret = RasGetConnectStatus(Ras_Buf(0).hRasConn, Ras_Status)
If ret = 0 And Ras_Status.RasConnState = RASCS_DONE then
MsgBox "在线."
else
MsgBox "当前未连接。"
End If
End Sub
Private Sub 注册表法_Click() ' 注册表法检查是否断线
Dim SubKey As String, ValueName As String
Dim Data As Long, Result As Long
SubKey = "System/CurrentControlSet/Services/RemoteAccess"
ret = RegOpenKey(HKEY_LOCAL_MACHINE, SubKey, Result)
If ret = 0&amp;
then
ValueName = "Remote Connection"
ret = RegQueryValueEx(Result, ValueName, 0&amp;, 0&amp;, ByVal Data, 0&amp;)
ret = RegQueryValueEx(Result, ValueName, 0&amp;, 0&amp;, Data, Len(Data))
If ret = 0&amp;
And Data <> 0 then
MsgBox "在线!"
else
MsgBox "当前未连接。"
End If
RegCloseKey (Result)
End If
End Sub
'自动挂断
Private Sub wininet法_Click() ' wininet法自动挂断
If InternetAutodialHangup(0) then
MsgBox "已挂断(wininet法)"
End Sub
Private Sub 窗口查找法_Click() ' 窗口查找法自动挂断
ret = FindWindow("#32770", "连接到 The95963")
If ret <> 0 then
Call ShowWindow(ret, SW_SHOW)
SendKeys "%c", True
MsgBox "已挂断(窗口查找法)"
End If
End Sub
Private Sub RAS法_Click() ' RAS法自动挂断
Ras_Buf(0).dwSize = Len(Ras_Buf(0)) + 1
lpcb = 256 * Ras_Buf(0).dwSize
ret = RasEnumConnections(Ras_Buf(0), lpcb, lpcConnections)
If ret then
MsgBox "出错!": Exit Sub
End If
Ras_Status.dwSize = Len(Ras_Status) + 2
ret = RasGetConnectStatus(Ras_Buf(0).hRasConn, Ras_Status)
If ret = 0 And Ras_Status.RasConnState = RASCS_DONE then
If RasHangUp(Ras_Buf(0).hRasConn) = 0 then
_
MsgBox "已挂断(RAS法)"
End If
End Sub​
 
谢谢不值钱。请给RMB。
 
比较明显是商用的啊.......
DFW成了免费劳工集中营了?
 
賺錢的東西,就要花錢請人
 
大哥,这代码也不少啊 !
这么多让人给你弄,好像不现实哦
哥们给你个建议,你可以自己弄些,不明白的地方再发上来
这样大伙也有兴趣,时间也短!
 
后退
顶部