خوشبختانه سورس کد پیدا شد!!
امیدوارم این کد ها به دردتون بخوره:
Imports System.Runtime.InteropServices 'APIs
Imports System.Text ' StringBuilder
کد زیر در بخش general
Dim restarttime As Integer = 0
Dim numb As String = ""
Dim Hours, Minutes, Seconds As Integer
Dim IsStop As Boolean = False
Private Declare Sub mouse_event Lib "user32.dll" (ByVal dwFlags As Integer, ByVal dx As Integer, ByVal dy As Integer, ByVal cButtons As Integer, ByVal dwExtraInfo As IntPtr)
'Retrieves a handle to the foreground window
<DllImport("user32.dll")> _
Private Shared Function GetForegroundWindow() As Integer
End Function
'Copies the text of the specified window's title bar (if it has one) into a buffer
<DllImport("user32.dll")> _
Private Shared Function GetWindowText(hWnd As Integer, text As StringBuilder, count As Integer) As Integer
End Function
Public Declare Function WindowFromPoint Lib "user32" (ByVal pt As Point) As IntPtr
'This function changes the size, position, and z-order of a child, pop-up, or top-level window.
<DllImport("user32.dll")> _
Public Shared Function SetWindowPos(hWnd As IntPtr, hWndInsertAfter As IntPtr, X As Integer, Y As Integer, cx As Integer, cy As Integer, _
uFlags As UInteger) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
Shared ReadOnly HWND_TOPMOST As New IntPtr(-1) 'Places the window above all non-topmost windows
Shared ReadOnly HWND_TOP As New IntPtr(0) ' Places the window at the top of the Z order.
Const SWP_NOSIZE As UInt32 = &H1 'Retains current size
Const SWP_NOMOVE As UInt32 = &H2 ' Retains the current position
Const TOPMOST_FLAGS As UInt32 = SWP_NOMOVE Or SWP_NOSIZE
Public Sub New()
' This call is required by the designer.
InitializeComponent()
SetWindowPos(Me.Handle, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS) ' Add any initialization after the InitializeComponent() call.
End Sub
Private Sub PerformMouseClick(ByVal LClick_RClick_DClick As String, ByVal xCoord As Integer, ByVal yCoord As Integer)
Const MOUSEEVENTF_LEFTDOWN As Integer = 2
Const MOUSEEVENTF_LEFTUP As Integer = 4
Const MOUSEEVENTF_RIGHTDOWN As Integer = 6
Const MOUSEEVENTF_RIGHTUP As Integer = 8
If LClick_RClick_DClick = "RClick" Then
mouse_event(MOUSEEVENTF_RIGHTDOWN, xCoord, yCoord, 0, IntPtr.Zero)
mouse_event(MOUSEEVENTF_RIGHTUP, xCoord, yCoord, 0, IntPtr.Zero)
ElseIf LClick_RClick_DClick = "LClick" Then
mouse_event(MOUSEEVENTF_LEFTDOWN, xCoord, yCoord, 0, IntPtr.Zero)
mouse_event(MOUSEEVENTF_LEFTUP, xCoord, yCoord, 0, IntPtr.Zero)
ElseIf LClick_RClick_DClick = "DClick" Then
mouse_event(MOUSEEVENTF_LEFTDOWN, xCoord, yCoord, 0, IntPtr.Zero)
mouse_event(MOUSEEVENTF_LEFTUP, xCoord, yCoord, 0, IntPtr.Zero)
mouse_event(MOUSEEVENTF_LEFTDOWN, xCoord, yCoord, 0, IntPtr.Zero)
mouse_event(MOUSEEVENTF_LEFTUP, xCoord, yCoord, 0, IntPtr.Zero)
End If
End Sub
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
Timer1.Enabled = False
Try
Label1.Text = "در حال اجرا و آماده سازی وایبر"
Shell("C:\Users\MedadRangi_PC\AppData\Local\Viber\Viber.e xe", AppWinStyle.MaximizedFocus)
Timer2.Enabled = True
Catch ex As Exception
Application.DoEvents()
Label1.Text = "مشکل در اجرای وایبر، مسیر وارد شده صحیح نمی باشد"
Timer2.Enabled = False
End Try
End Sub
Private Sub setMousePos(x As String, y As String)
Dim allwidth As Integer = Screen.PrimaryScreen.Bounds.Width
Dim allheight As Integer = Screen.PrimaryScreen.Bounds.Height
Dim newleft As Integer = (allwidth / 100) * x
Dim newtop As Integer = (allheight / 100) * y
Windows.Forms.Cursor.Position = New Point(newleft, newtop)
End Sub
Private Sub Timer2_Tick(sender As Object, e As EventArgs) Handles Timer2.Tick
On Error Resume Next
Dim newBank As String = ""
Timer2.Enabled = False
Application.DoEvents()
Dim s_s As String = Second(TimeOfDay)
Dim s_m As String = Minute(TimeOfDay)
Dim s_h As String = Hour(TimeOfDay)
Dim n_s As String = Second(TimeOfDay)
Dim n_m As String = Minute(TimeOfDay)
Dim n_h As String = Hour(TimeOfDay)
Dim starttime As String = s_h & s_m & s_s
Dim nowtime As String
hhhr:
Application.DoEvents()
'-------------انتظار برای اجرای وایبر
Const intCharCount As Integer = 256 'Number Of Characters For String Buffer
Dim intWindowHandle As Integer = 0 'Window Handle
Dim strWindowText As New StringBuilder(intCharCount) 'Set Up String Builder To Hold Text From GWT API
intWindowHandle = GetForegroundWindow() 'get Current Active Window
If GetWindowText(intWindowHandle, strWindowText, intCharCount) > 0 Then 'If It Has A Caption
If strWindowText.ToString().Substring(0, 5) <> "Viber" Then
GoTo hhhr
End If
End If
Threading.Thread.Sleep(7000)
'-------------ایجاد حلقه برای شماره های ثبت شده
For q = 0 To ListBox1.Items.Count - 1
'---------لغو ارسال ها
If IsStop = True Then
GoTo endPoint
End If
My.Computer.Keyboard.SendKeys("~")
Application.DoEvents()
Threading.Thread.Sleep(50)
Application.DoEvents()
'---------کلیک روی دیالر
setMousePos(16.6, 10.1)
Threading.Thread.Sleep(1)
PerformMouseClick("LClick", 0, 0)
Application.DoEvents()
Threading.Thread.Sleep(1)
Application.DoEvents()
'---------کلیک روی فیلد شماره
setMousePos(12.5, 18.3)
Threading.Thread.Sleep(1)
PerformMouseClick("LClick", 0, 0)
Threading.Thread.Sleep(100)
Application.DoEvents()
'---------پاکسازی شماره وارد شده
For i = 0 To 20
My.Computer.Keyboard.SendKeys("{BACKSPACE}", True)
Application.DoEvents()
Next
For i = 0 To 20
My.Computer.Keyboard.SendKeys("{DELETE}", True)
Application.DoEvents()
Next
'---------وارد کردن پیش شماره
Threading.Thread.Sleep(10)
My.Computer.Keyboard.SendKeys("{+}", True)
Threading.Thread.Sleep(10)
Application.DoEvents()
My.Computer.Keyboard.SendKeys("9", True)
Threading.Thread.Sleep(10)
Application.DoEvents()
My.Computer.Keyboard.SendKeys("8", True)
Application.DoEvents()
Threading.Thread.Sleep(500)
Application.DoEvents()
'---------وارد کردن شماره
PerformMouseClick("LClick", 0, 0)
Application.DoEvents()
numb = ListBox1.Items(q)
For n = 0 To numb.Length - 1
My.Computer.Keyboard.SendKeys(numb.Substring(n, 1))
Application.DoEvents()
Threading.Thread.Sleep(5)
Next
Application.DoEvents()
Threading.Thread.Sleep(400)
'---------کلیک روی شروع چت
setMousePos(12.5, 58.88)
Application.DoEvents()
PerformMouseClick("LClick", 0, 0)
Threading.Thread.Sleep(1)
Application.DoEvents()
'---------رفع خطای احتمالی
My.Computer.Keyboard.SendKeys("~", True)
'---------بررسی وجود شماره در وایبر
setMousePos(80.2, 91.11)
Application.DoEvents()
Threading.Thread.Sleep(1)
Dim bounds As Rectangle
Dim screenshot As System.Drawing.Bitmap
Dim graph As Graphics
bounds = Screen.PrimaryScreen.Bounds
screenshot = New System.Drawing.Bitmap(bounds.Width, bounds.Height, System.Drawing.Imaging.PixelFormat.Format32bppArgb )
graph = Graphics.FromImage(screenshot)
graph.CopyFromScreen(bounds.X, bounds.Y, 0, 0, bounds.Size, CopyPixelOperation.SourceCopy)
Dim allwidth As Integer = Screen.PrimaryScreen.Bounds.Width
Dim allheight As Integer = Screen.PrimaryScreen.Bounds.Height
Dim newleft As Integer = MousePosition.X
Dim newtop As Integer = MousePosition.Y
Dim pixelColor As Color = screenshot.GetPixel(newleft, newtop)
Dim s As String
s = pixelColor.R & "," & pixelColor.G & "," & pixelColor.B
If s <> "157,106,198" Then
GoTo notfnd
End If
'---------ارسال متن تبلیغاتی
If TextBox2.Text <> "" Then
setMousePos(48.61, 91.11)
Threading.Thread.Sleep(10)
PerformMouseClick("LClick", 0, 0)
Threading.Thread.Sleep(100)
Application.DoEvents()
PerformMouseClick("LClick", 0, 0)
My.Computer.Keyboard.SendKeys(TextBox2.Text, True)
Threading.Thread.Sleep(1)
Application.DoEvents()
My.Computer.Keyboard.SendKeys("~", True)
Threading.Thread.Sleep(1)
Application.DoEvents()
My.Computer.Keyboard.SendKeys("~", True)
End If
'---------------ارسال تصویر تبلیغاتیrur
If TextBox3.Text <> "" Then
setMousePos(39.23, 91.11)
My.Computer.Keyboard.SendKeys("~", True)
Threading.Thread.Sleep(1000)
PerformMouseClick("LClick", 0, 0)
Application.DoEvents()
Threading.Thread.Sleep(3000)
My.Computer.Keyboard.SendKeys(TextBox3.Text, True)
Threading.Thread.Sleep(300)
Application.DoEvents()
My.Computer.Keyboard.SendKeys("~", True)
End If
endPoint:
'--------------گزارش عملیات
Application.DoEvents()
Label4.Text = Label4.Text + 1
'-------------رفع خطای احتمالی
Threading.Thread.Sleep(100)
Application.DoEvents()
My.Computer.Keyboard.SendKeys("~")
'---------------ویرایش بانک جدید
If newBank.Length <> 0 Then
newBank &= ","
End If
newBank &= ListBox1.Items(q)
'---------------تکرار حلقه
notfnd:
ProgressBar1.Value += 1
Label6.Text += 1
n_s = Second(TimeOfDay)
n_m = Minute(TimeOfDay)
n_h = Hour(TimeOfDay)
nowtime = n_h & n_m & n_s
Seconds = Integer.Parse(nowtime - starttime)
Hours = Seconds / 3600
Seconds = Seconds Mod 3600
Minutes = Seconds / 60
Seconds = Seconds Mod 60
Label8.Text = Hours.ToString.PadLeft(2, "0"c) & ":" & Minutes.ToString.PadLeft(2, "0"c) & ":" & Seconds.ToString.PadLeft(2, "0"c)
Threading.Thread.Sleep(1000)
Next
'---------------پایان ارسال ها
Application.DoEvents()
Threading.Thread.Sleep(3000)
'---------------بستن وایبر
For Each yout As Process In Process.GetProcessesByName("viber")
yout.Kill()
Next
Dim savenbank As String = Application.StartupPath & "\banks\bank" & Date.Now.Year & "-" & Date.Now.Month & "-" & Date.Now.Day & " , " & Hour(TimeOfDay) & "-" & Minute(TimeOfDay) & "-" & Second(TimeOfDay) & ".mrdf"
My.Computer.FileSystem.WriteAllText(savenbank, newBank, False)
'---------------ری استارت کردن برنامه
Application.Restart()
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
If TextBox1.Text = "" Then
MsgBox("لطفا بانک اطلاعاتی را انتخاب کنید")
Exit Sub
End If
If TextBox2.Text = "" And TextBox3.Text = "" Then
MsgBox("شما باید حد اقل یک متن یا یک تصویر وارد کنید")
Exit Sub
End If
Label1.Text = "در حال آماده سازی داده ها..."
Label4.Text = 0
ProgressBar1.Maximum = Label3.Text
Timer1.Enabled = True
Try
Dim a As Process = Process.GetProcessesByName("viber").FirstOrDefault
a.Kill()
Catch ex As Exception
End Try
If My.Computer.FileSystem.FileExists(TextBox1.Text) = False Then
MsgBox("بانک اطلاعاتی حذف شده است")
Timer1.Enabled = False
Exit Sub
End If
Dim nmbrs As String = My.Computer.FileSystem.ReadAllText(TextBox1.Text)
nmbrs = nmbrs.Replace(vbCrLf, ",")
Dim numbers() As String
numbers = nmbrs.Split(",")
Dim newnmbr As String
For Each s As String In numbers
newnmbr = s
If newnmbr.Substring(0, 1) = "0" Then
newnmbr = newnmbr.Substring(1)
End If
newnmbr = newnmbr.Replace("+98", "")
ListBox1.Items.Add(newnmbr)
Next
End Sub
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim u As New OpenFileDialog
u.Filter = "Medad Rangi Database File|*.mrdf"
If u.ShowDialog = Windows.Forms.DialogResult.OK Then
TextBox1.Text = u.FileName
Dim fu As String = My.Computer.FileSystem.ReadAllText(TextBox1.Text)
Dim ku() As String = fu.Split(",")
Label3.Text = ku.Count
End If
End Sub
Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click
Dim u As New OpenFileDialog
u.Filter = "All Image files|*.bmp;*.jpg;*.gif;*.png"
If u.ShowDialog = Windows.Forms.DialogResult.OK Then
Dim newUrl As String = Application.StartupPath & "\images\image" & Int(Rnd() * 99) & Second(TimeOfDay) & Hour(TimeOfDay) & Hour(TimeOfDay) & My.Computer.FileSystem.GetFileInfo(u.FileName).Ext ension
TextBox3.Text = newUrl
FileCopy(u.FileName, newUrl)
End If
End Sub
Private Sub Button4_Click(sender As Object, e As EventArgs) Handles Button4.Click
IsStop = True
End Sub
Private Sub لغوارسالهاToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles لغوارسالهاToolStripMenuItem.Click
IsStop = True
End Sub
امیدوارم به دردتون بخوره و کپی نشه!