dün yazdığım programın kaynak kodunu sizinle paylaşayım dedim. Kod'un içerisinde gördüğünüz gibi kontroller olduğu gibi yazılmıştır. Programda iki dil seçeneği mevcut yanlız bu erotik içerikli resimleri indiriyor sadece örnek teşkil etmesi için gönderdim Kod: Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" As Long Dim klasoryeri As String Dim ing As Boolean Private Sub Combo1_Click If Combo1. ListIndex <> 0 Then ing = True Else ing = False nesneleriyaz End Sub Sub nesneleriyaz If ing = False Then formy = "Webcam Resimleri 38.000 Adet" resimgosterchk = "Göster/Gizle" klasorcmd = "Klasör seç" kapatcmd = "Kapat" simdicmd = "Indirmeye Başla" klasorlbl = "Indirilecek resimlerin kopyalanacağı yeri seçiniz..." dillbl = "Dil Seçimi" dizinlbl = "Dizin" resimlbl = "Resim No." resimglbl = "Şu an inen resim..." uyari = "Bu program orjinal boyutu 64kb'dir. Sorunsuz kullanmak için buna dikkat edin." Else formy = "Webcam Pictures Count 38.000" resimgosterchk = "Visible/Hide" klasorcmd = "Folder Select" kapatcmd = "Close" simdicmd = "Download Now" klasorlbl = "Downloading pictures path copy folder select" dillbl = "Lang. Select" dizinlbl = "Index" resimlbl = "Picture No." resimglbl = "Now downloading picture..." uyari = "This application orjinal 64kb. Safe use orjinal link download." End If Me. Caption = formy Label1. Caption = klasorlbl Label2. Caption = dillbl Label3. Caption = dizinlbl Label5. Caption = resimlbl Label7. Caption = resimglbl Label9. Caption = uyari Command1. Caption = klasorcmd Command2. Caption = kapatcmd Command3. Caption = simdicmd Check1. Caption = resimgosterchk End Sub Private Sub Command1_Click klasoryeri = BrowseForFolder If klasoryeri = "" Then klasoryeri = "C:\" Text1. Text = klasoryeri Command3. SetFocus End Sub Private Sub Command2_Click End End Sub Private Sub Command3_Click On Error GoTo hata Dim degisen, sabitsayi1, sabitsayi2 As Integer Dim site1, sabit1, sabit2 As String If Len(Text1. Text) < 4 Then If ing = False Then mesaj = MsgBox("Seçtiğiniz yer root olamaz. Lütfen bir klasör seçiniz." & vbCrLf & "Örneğin " & Text1. Text & "resimler", vbCritical, "Webcam resim indirme") Else mesaj = MsgBox("Select not root. Please select folder." & vbCrLf & "Example " & Text1. Text & "pictures", vbCritical, "Webcam picture download") End If Exit Sub End If If ing = False Then mesaj = MsgBox("Bu işlem çok uzun sürecektir. Toplam 38.000 resim ortalama 16kb tüm resimlerin ortalama boyutu 600mb 4mbit internet hızıyla yaklaşık yarım saat sürmektedir. Bu süre içinde bilgisayarı kullanmayınız.", vbInformation, "Webcam resim indirme") Else mesaj = MsgBox("This operation very long. Total 38.000 picture par 16kb all pictures par size 600mb 4mbit internet speed same half an hour continue. Do not computer use", vbInformation, "Webcam picture download") End If Command3. Enabled = False sabit1 = "0001" sabit2 = "1800" degisen = 21 sabitsayi1 = Val(sabit1) sabitsayi2 = Val(sabit2) For f = sabitsayi1 To sabitsayi2 For fik = 1 To degisen If fik <= 9 Then fiko = "0" & fik Else fiko = fik If f <= 9 Then fi = "000" & f If f <= 99 And f >= 10 Then fi = "00" & f If f <= 999 And f >= 100 Then fi = "0" & f Label4. Caption = fi Label6. Caption = fiko If sabitsayi1 <= 200 Then ilki$ = "0001": sonu$ = "0200" If sabitsayi1 <= 400 And sabitsayi1 >= 200 Then ilki$ = "0201": sonu$ = "0400" If sabitsayi1 <= 600 And sabitsayi1 >= 400 Then ilki$ = "0401": sonu$ = "0600" If sabitsayi1 <= 800 And sabitsayi1 >= 600 Then ilki$ = "0601": sonu$ = "0800" If sabitsayi1 <= 1000 And sabitsayi1 >= 800 Then ilki$ = "0801": sonu$ = "1000" If sabitsayi1 <= 1200 And sabitsayi1 >= 1000 Then ilki$ = "1001": sonu$ = "1200" If sabitsayi1 <= 1400 And sabitsayi1 >= 1200 Then ilki$ = "1201": sonu$ = "1400" If sabitsayi1 <= 1600 And sabitsayi1 >= 1400 Then ilki$ = "1401": sonu$ = "1600" If sabitsayi1 <= 1800 And sabitsayi1 >= 1600 Then ilki$ = "1601": sonu$ = "1800" site1 = "http://www.1000teencamvideos.com/content/amateur/1000tcvidsfp/" & ilki$ & "-" & sonu$ & "/" & fi & "/medium/00" & fiko & ". thumb. jpg" dosyaadi = fi & "_" & Format & "_" & StripPath(site1) DownloadFile "http://www.1000teencamvideos.com/content/amateur/1000tcvidsfp/" & ilki$ & "-" & sonu$ & "/" & fi & "/medium/00" & fiko & ". thumb. jpg", klasoryeri & "\" & dosyaadi kontrolet = Dir If kontrolet <> "" Then If Check1. Value = 1 Then Image1. Visible = True Image1. Picture = LoadPicture Else Image1. Visible = False End If End If DoEvents Next DoEvents Next If ing = False Then bitti = MsgBox Else bitti = MsgBox ", vbInformation, "Webcam Pictures") End If End hata: MsgBox "bug report: " & Err. Description & " mailto:fikret2009@lavabit.com" End End Sub Public Function DownloadFile As Boolean Dim lngRetVal As Long lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0) If lngRetVal = 0 Then DownloadFile = True End Function Function StripPath As String Dim x%, ct% StripPath$ = t x% = InStr Do While x% ct% = x% x% = InStr(ct% + 1, t, "/") Loop If ct% > 0 Then StripPath$ = Mid$(t, ct% + 1) End Function Private Sub Form_Load Combo1. AddItem "Türkçe" Combo1. AddItem "English" Combo1. ListIndex = 0 mesajigoster = MsgBox(Space(30) & "Yetişkin içerikli Program" & vbCrLf & "Bu program +18 içerik içermektedir. Tüm yasal sorumluluk indirene aittir." & vbCrLf & Space(5) & "Bu içeriği yinede görmek istiyorsanız çıkan mesaja 'Evet' tıklayın." & vbCrLf & vbCrLf & Space(30) & "!!! Adult Application!!!" & vbCrLf & Space(20) & "+18 only if not see 'Yes' button click", vbYesNo, "Webcam Resimleri 38.000 Adet - Webcam Pictures Count 38.000") If mesajigoster = vbNo Then End End Sub Private Sub Form_Resize If Me. Height <> 5430 Then Me. Height = 5430 If Me. Width <> 4740 Then Me. Width = 4740 End Sub module yazılacak olan 'Created By Mustafa KOÇER(musti0532) Public Declare Sub CoTaskMemFree Lib "ole32. dll" Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Public Declare Function SHBrowseForFolder Lib "shell32" As Long Public Declare Function SHGetPathFromIDList Lib "shell32" As Long Public Const BIF_RETURNONLYFSDIRS = 1 Public Const MAX_PATH = 260 Public Type BrowseInfo hwndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Public Function BrowseForFolder As String Dim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String Dim udtBI As BrowseInfo With udtBI. hwndOwner = hwndOwner. lpszTitle = lstrcat . ulFlags = BIF_RETURNONLYFSDIRS End With lpIDList = SHBrowseForFolder If lpIDList Then sPath = String$(MAX_PATH, 0) lResult = SHGetPathFromIDList Call CoTaskMemFree iNull = InStr If iNull Then sPath = Left$(sPath, iNull - 1) End If End If BrowseForFolder = sPath End Function yorumlarınızı bekliyorum... -

Bu apiyi hiç duymamıştım Normalde inet ile indirtirim ben dosya ayrıntısıyla birlikte ama bu da güzelmiş dostum eline sağlık