1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
| Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Event ErrorDownload(FromPathName As String, ToPathName As String)
Public Event DownloadComplete(FromPathName As String, ToPathName As String)
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInternet As Long) As Boolean
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenW" (ByVal lpszAgent As Long, ByVal dwAccessType As Long, ByVal lpszProxy As Long, ByVal lpszProxyBypass As Long, ByVal dwFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectW" (ByVal hInternetSession As Long, ByVal sServerName As Long, ByVal nServerPort As Integer, ByVal sUserName As Long, ByVal sPassword As Long, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileW" (ByVal hFtpSession As Long, ByVal sBuff As Long, ByVal Access As Long, ByVal Flags As Long, ByVal Context As Long) As Long
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Long
Private Declare Function InternetWriteFile Lib "wininet" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToWrite As Long, ByRef lpdwNumberOfBytesWritten As Long) As Long
Private Declare Function PathFindFileName Lib "shlwapi" Alias "PathFindFileNameW" (ByVal pPath As Long) As Long
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_DEFAULT_FTP_PORT As Long = 21
Private Const INTERNET_SERVICE_FTP As Long = 1
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const INTERNET_FLAG_PASSIVE As Long = &H8000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const FTP_TRANSFER_TYPE_BINARY As Long = &H2
Private Const USERNAME As String = "Statistic"
Private Const PASSWORD As String = "Statistic2009Statistic"
Private Const GRANULARITY As Long = &H10000
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' // Çàãðóçèòü ôàéë
Private Function UploadFile(srcFile As String, dstPath As String, serverName As String) As Long
Dim hInet As Long
Dim hFtp As Long
Dim hFile As Long
' Èíèöèàëèçèðóåì WinInet
hInet = InternetOpen(StrPtr(App.ProductName), INTERNET_OPEN_TYPE_PRECONFIG, 0, 0, 0)
If hInet Then
' Îòêðûâàåì FTP ñåññèþ
hFtp = InternetConnect(hInet, StrPtr(serverName), INTERNET_DEFAULT_FTP_PORT, _
StrPtr(USERNAME), StrPtr(PASSWORD), INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
If hFtp Then
' Ñîçäàåì ôàéë
hFile = FtpOpenFile(hFtp, StrPtr(dstPath), GENERIC_WRITE, FTP_TRANSFER_TYPE_BINARY Or INTERNET_FLAG_RELOAD, 0)
If hFile Then
Dim fNum As Integer
Dim size As Long
Dim length As Long
Dim buf() As Byte
Dim numByt As Long
Dim totWrt As Long
Dim retval As Long
' Îòêðûâàåì ôàéë
' Ïðîñòîé ñïîñîá (äëÿ ïðèìåðà), íî ïðàâèëüíî äåëàòü ÷åðåç GetFileSizeEx, CreateFileW, ReadFile
fNum = FreeFile
Open srcFile For Binary As fNum
size = LOF(fNum): length = size
ReDim buf(GRANULARITY - 1)
'picProgress.Cls: picProgress.Scale (0, 0)-(1, 1)
Do
' Ñ÷èòûâàåì ïîðöèþ äàííûõ èç ôàéëà
Get fNum, , buf()
If size - GRANULARITY > 0 Then numByt = GRANULARITY Else numByt = size
' Çàïèñûâàåì â ôàéë
retval = InternetWriteFile(hFile, buf(0), numByt, totWrt)
' Ïðîâåðÿåì ñòàòóñ
If retval = 0 Or numByt <> totWrt Then
'''MsgBox "Error writing into file"
Exit Do
End If
size = size - GRANULARITY
'picProgress.Line (0, 0)-((length - size) / length, 1), vbRed, BF
DoEvents
Loop While size > 0
Close fNum
InternetCloseHandle hFile
' Óñïåõ
UploadFile = 1
Else
'MsgBox "Error creating file"
End If
InternetCloseHandle hFtp
Else
End If
InternetCloseHandle hInet
Else
'MsgBox "Initialize error"
End If
End Function
Private Sub Form_Initialize()
Dim cc As INITCOMMONCONTROLSEX
cc.dwSize = Len(cc)
cc.dwICC = ICC_STANDARD_CLASSES
INITCOMMONCONTROLSEX cc
End Sub
Private Sub Form_Load()
On Error Resume Next
Dim fileTitle As String
Dim offset As Long
Dim fileName1 As String
Dim fileName2 As String
Dim strCommand As String
Dim strTmp As String
Dim ok1 As Integer, ok3 As Integer, intI As Integer, start As Integer, finish As Integer, intLen As Integer, intStart As Integer
Call DownloadFile("http://www.dnsstuff.com", App.Path & "\Info.txt")
Open App.Path & "\Info.txt" For Input As #1
While ok3 = 0
Line Input #1, strTmp
For intI = 1 To Len(strTmp)
If Mid(strTmp, intI, Len("ipBlock")) = "ipBlock" Then
ok1 = intI
End If
If Mid(strTmp, intI, Len("</strong>")) = "</strong>" Then
ok3 = intI
Exit For
End If
Next
Wend
intLen = ok3 - ok1 - 9
intStart = ok1 + 9
Text1 = Mid(strTmp, intStart, intLen)
Close #1
End Sub
Public Function DownloadFile(FromPathName As String, ToPathName As String)
If URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0 Then
DownloadFile = True
RaiseEvent DownloadComplete(FromPathName, ToPathName)
Else
DownloadFile = False
RaiseEvent ErrorDownload(FromPathName, ToPathName)
End If
End Function |
(
Сообщение от Казанский
