- Код: Выделить всё
Option Explicit
Private Const FLAG_ICC_FORCE_CONNECTION = &H1
Private Const PICSEARCH = "http://www.picsearch.ru"
Public W As Long, H As Long
' APIs
Private Declare Function LocalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
' Constants
Private Const CP_UTF8 As Long = 65001
Private Const LMEM_ZEROINIT As Long = &H40
' Для создания каталогов
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
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Public Sub Main()
If Not App.PrevInstance Then
Call GetFileInternet("Wallpaper")
End If
End
End Sub
Private Sub GetFileInternet(ByVal Themes As String)
Dim URL As String, FileName As String, Picture As String, Html As String, Wallpaper As String, C As String
Dim N As Long, I As Long, hWind As Long
Dim A() As String, B() As String
On Error GoTo Quit
Randomize Timer
Call LogOut("==========================================================")
Wallpaper = "Error"
Call LogOut(1)
W = Screen.Width / Screen.TwipsPerPixelX
Call LogOut(2)
H = Screen.Height / Screen.TwipsPerPixelY
Call LogOut(3)
'Поиск рисунков
FileName = App.Path & "\PicSearch.htm"
Call LogOut(4)
URL = PICSEARCH & "/search.cgi?q=" & Themes & "&anim=no&color=both&size=wallpaper"
Start:
Call LogOut(5)
If InternetCheckConnection(PICSEARCH, FLAG_ICC_FORCE_CONNECTION, 0&) = 0 Then Err.Raise 2, , "Connection to " & PICSEARCH & " failed!"
Call LogOut(6)
If Not DownloadFile(URL, FileName) Then GoTo Start
Call LogOut(7)
Open FileName For Input As #1
Call LogOut(8)
Html = Input(LOF(1), #1)
Call LogOut(9)
Close #1
Call LogOut(10)
A = Split(Html, "gbar")
Call LogOut(11)
A(1) = UTF8ToWin(A(1), Len(A(1)))
Call LogOut(12)
A = Split(A(1), vbLf)
Call LogOut(13)
N = Val(Replace(Mid$(Left$(A(2), Len(A(2)) - 8), 21), " ", ""))
Call LogOut(14)
Сhoice:
If InternetCheckConnection(PICSEARCH, FLAG_ICC_FORCE_CONNECTION, 0&) = 0 Then Err.Raise 2, , "Connection to " & PICSEARCH & " failed!"
Call LogOut(15)
'Выбор рисунка
I = Int(Rnd * N) + 1
Call LogOut(16)
URL = PICSEARCH & "/search.cgi?q=" & Themes & "&start=" & I & "&anim=no&size=wallpaper"
Call LogOut(17)
If Not DownloadFile(URL, FileName) Then GoTo Сhoice
Call LogOut(18)
Open FileName For Input As #1
Call LogOut(19)
Html = Input(LOF(1), #1)
Call LogOut(20)
Close #1
Call LogOut(21)
A = Split(Html, "<tr><td align=center valign=middle height=138>")
Call LogOut(22)
A = Split(A(1), vbLf)
Call LogOut(23)
If InStr(A(5), W & " x " & H) = 0 Then GoTo Сhoice
Call LogOut(24)
'Загрузка эскиза
B = Split(A(2), Chr(34))
Call LogOut(25)
URL = B(1)
Call LogOut(26)
If Not DownloadFile(URL, App.Path & "\PicSearch.jpg") Then GoTo Сhoice
Call LogOut(27)
'Загрузка информационной страницы
B = Split(A(1), Chr(34))
Call LogOut(28)
URL = PICSEARCH & B(1)
Call LogOut(29)
If Not DownloadFile(URL, FileName) Then GoTo Сhoice
Call LogOut(30)
Open FileName For Input As #1
Call LogOut(31)
Html = Input(LOF(1), #1)
Call LogOut(32)
Close #1
Call LogOut(33)
A = Split(Html, "frameset")
Call LogOut(34)
A = Split(A(1), vbLf)
Call LogOut(35)
'Извлечение ссылки
B = Split(A(1), Chr(34))
Call LogOut(36)
URL = PICSEARCH & "/" & B(1)
Call LogOut(37)
If Not DownloadFile(URL, FileName) Then GoTo Сhoice
Call LogOut(38)
Open FileName For Input As #1
Call LogOut(39)
Html = Input(LOF(1), #1)
Call LogOut(40)
Close #1
Call LogOut(41)
A = Split(Html, "<td nowrap>")
Call LogOut(42)
A = Split(A(5), vbLf)
Call LogOut(43)
'Загрузка картинки
B = Split(A(1), Chr(34))
Call LogOut(44)
URL = B(1)
Call LogOut(45)
FileName = App.Path & "\" & GetFileName(URL)
Call LogOut(46)
If Len(Dir(FileName)) > 0 Then GoTo Сhoice
Call LogOut(47)
If Not DownloadFile(URL, FileName) Then GoTo Сhoice
Call LogOut(48)
Wallpaper = FileName
Quit:
Call LogOut(Wallpaper)
Call MsgBox(Wallpaper, vbInformation + vbOKOnly)
End Sub
Private Function GetFileName(ByVal Link As String) As String
Dim I As Integer
I = InStrRev(Link, "/")
GetFileName = Mid(Link, I + 1)
End Function
Private Function DownloadFile(ByVal FromPathName As String, ByVal ToPathName As String) As Boolean
DownloadFile = IIf(URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0, True, False)
End Function
Public Function LogOut(Text As Variant)
Open App.Path & "\Debug.log" For Append As #2
Print #2, Now & vbTab & Text
Close #2
End Function
'--------------------------------------------------------------------------------
' Проект : OfflineClient
' Процедура : UTF8ToWin
' Описание : Перевод UTF8 строки в WIN кодировку
' Кем создан : SNE
' Дата-Время : 09.11.2004-11:56:58
'
' Параметры : inString - Строка в utf8 кодировке
' lMaxSize - Максимальный размер строки
'--------------------------------------------------------------------------------
Public Function UTF8ToWin(ByRef inString As String, _
ByVal lMaxSize As Long) As String
Dim hMemLock1 As Long, hMemLock2 As Long
Dim iStrSize As Long
hMemLock1 = LocalAlloc(LMEM_ZEROINIT, lMaxSize)
hMemLock2 = LocalAlloc(LMEM_ZEROINIT, lMaxSize)
iStrSize = MultiByteToWideChar(CP_UTF8, 0&, inString, &HFFFF, hMemLock1, lMaxSize)
iStrSize = WideCharToMultiByte(0&, 0&, hMemLock1, &HFFFF, hMemLock2, iStrSize, 0&, 0&)
If Len(iStrSize) Then
UTF8ToWin = String$(iStrSize, 0&)
Call CopyMemory(ByVal UTF8ToWin, ByVal hMemLock2, iStrSize)
End If
Call LocalFree(hMemLock1)
Call LocalFree(hMemLock2)
End Function
PS. это вырезка из программы, поэтому код слегка не причесаный
