تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
ارجو المساعدة في تحويل اكواد
#1
ارجو من الاخوة الكرام ان يساعدوني في تحويل اكواد الفيجول 6 الى الدت نت
وانشاء الله لن اكثر عليكم لانه ليس بالكبير
وشكرا
الرد }}}
تم الشكر بواسطة:
#2
اتمنى وضع الاكواد
الْلَّهُم صَلِّ وَسَلِم وَبَارِك عَلَى سَيِّدِنَا مُحَمَّد
الرد }}}
تم الشكر بواسطة: Ahmed_Mansoor , Ahmed_Mansoor
#3
(19-11-16, 01:21 AM)LoveVb كتب : اتمنى وضع الاكواد

شكرا لك على الرد السريع وهذا اول كود
كود :
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_THICKFRAME = &H40000
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
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 Type NOTIFYICONDATA
      cbSize As Long
      hWnd As Long
      uId As Long
      uFlags As Long
      uCallBackMessage As Long
      hIcon As Long
      szTip As String * 64
     End Type

     'constants required by Shell_NotifyIcon API call:
     Private Const NIM_ADD = &H0
     Private Const NIM_MODIFY = &H1
     Private Const NIM_DELETE = &H2
     Private Const NIF_MESSAGE = &H1
     Private Const NIF_ICON = &H2
     Private Const NIF_TIP = &H4
     Private Const WM_MOUSEMOVE = &H200
     Private Const WM_LBUTTONDOWN = &H201     'Button down
     Private Const WM_LBUTTONUP = &H202       'Button up
     Private Const WM_LBUTTONDBLCLK = &H203   'Double-click
     Private Const WM_RBUTTONDOWN = &H204     'Button down
     Private Const WM_RBUTTONUP = &H205       'Button up
     Private Const WM_RBUTTONDBLCLK = &H206   'Double-click

     Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
     Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

     Private nid As NOTIFYICONDATA
     Private Const ERROR_SUCCESS As Long = 0
Private Const BINDF_GETNEWESTVERSION As Long = &H10
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Dim onbtt(4) As Boolean
Dim btx1(4) As Long
Dim btx2(4) As Long
Dim bty1(4) As Long
Dim bty2(4) As Long
Dim bcx1(4) As Long
Dim bcx2(4) As Long
Dim bcy1(4) As Long
Dim bcy2(4) As Long
Dim strtwidth As Long
Dim strtheight As Long
Dim strtad As Boolean
Dim AdLinkURL  As String
Dim AdIMGURL  As String
Dim exrq As Boolean
Dim chlst As String
Dim autourl As String
Dim origurl As String
Dim stdate As String
Dim truedate As String
Dim wndst As Integer
Dim QualOp As Integer
Dim fresult As String
'Dim ChannelList(34) As Channel
Public Sub ShowResultinVBApplication(strResultfromJavascript As String)
fresult = strResultfromJavascript
End Sub
Private Function GetbyetSource(sUrl As String, pData As String, cData As String) As String
On Error GoTo ErrorHandler
Dim abdata() As Byte
Dim txtcode As String
abdata = LoadResData(107, "CUSTOM")
txtcode = StrConv(abdata, vbUnicode)
reslt2 = GetSourceCode(sUrl, "", "")
reslt1 = Split(reslt2, "<script>")
reslt = Split(reslt1(1), "document.cookie")
txtcode = txtcode + reslt(0)
ScriptControl1.language = "JavaScript"
ScriptControl1.Reset
ScriptControl1.timeout = NoTimeout
ScriptControl1.AddObject "Any text you want", Me, True
ScriptControl1.AddCode txtcode
fresult = ""
ScriptControl1.Run "GetCookie", ""
While fresult = ""
Wend
GetbyetSource = GetSourceCode(sUrl, pData, fresult)
   Exit Function
ErrorHandler:
   Dim E As ErrObject: Set E = err
End Function
Private Function BuutonPaint(bnum As Integer, abov As Integer)
If abov = 0 Then
MainForm.PaintPicture Image1.Picture, btx1(bnum), bty1(bnum), btx2(bnum) - btx1(bnum), bty2(bnum) - bty1(bnum), bcx1(bnum) / strtwidth * Image1.Width, bcy1(bnum) / strtheight * Image1.Height, (bcx2(bnum) - bcx1(bnum)) / strtwidth * Image1.Width, (bcy2(bnum) - bcy1(bnum)) / strtheight * Image1.Height
ElseIf abov = 1 Then
MainForm.PaintPicture Image2.Picture, btx1(bnum), bty1(bnum), btx2(bnum) - btx1(bnum), bty2(bnum) - bty1(bnum), bcx1(bnum) / strtwidth * Image1.Width, bcy1(bnum) / strtheight * Image1.Height, (bcx2(bnum) - bcx1(bnum)) / strtwidth * Image1.Width, (bcy2(bnum) - bcy1(bnum)) / strtheight * Image1.Height
ElseIf abov = 2 Then
MainForm.PaintPicture Image3.Picture, btx1(bnum), bty1(bnum), btx2(bnum) - btx1(bnum), bty2(bnum) - bty1(bnum), bcx1(bnum) / strtwidth * Image1.Width, bcy1(bnum) / strtheight * Image1.Height, (bcx2(bnum) - bcx1(bnum)) / strtwidth * Image1.Width, (bcy2(bnum) - bcy1(bnum)) / strtheight * Image1.Height
End If
End Function
Private Function DownloadFile(sSourceUrl As String, sLocalFile As String) As Boolean
DownloadFile = URLDownloadToFile(0&, sSourceUrl, sLocalFile, BINDF_GETNEWESTVERSION, 0&) = ERROR_SUCCESS
End Function
Private Function Hex2String(nStr As String) As String
For i = 1 To Len(nStr) / 2
Hex2String = Hex2String + Chr(Val("&H" + Mid(nStr, i * 2 - 1, 2)))
Next
End Function
Private Function String2Hex(nStr As String) As String
For i = 1 To Len(nStr)
String2Hex = String2Hex + Hex(Asc(Mid(nStr, i, 1)))
Next
End Function
Private Function AppPath() As String
AppPath = App.Path
If Right(AppPath, 1) <> "\" Then
AppPath = AppPath + "\"
End If
End Function
Public Function GetChannelList() As String
GetChannelList = Replace(DecryptS(chlst), "|||||", vbNewLine)
End Function
Public Function UpdateChannelList(nChlist As String) As String
chlst = nChlist
SendUpdate
End Function
Private Function GetSourceCode(sUrl As String, pData As String, cData As String) As String
Dim Http As WinHttp.WinHttpRequest
Dim httpsndtxt As String
Dim ftcstr() As String
Dim dlong As Long
Dim colng As Long
dlong = Len(pData)
colng = Len(cData)
httpsndtxt = ""
On Error GoTo ErrorHandler
   ftcstr = Split(sUrl, "/")
   Set Http = New WinHttp.WinHttpRequest
If dlong = 0 Then
   Http.open "GET", sUrl, False
Else
   Http.open "POST", sUrl, False
End If
   Http.setRequestHeader "Host", ftcstr(2)
   Http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 5.1; rv:43.0)Gecko/20100101 Firefox/43.0"
   Http.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
   Http.setRequestHeader "Accept-Language", "en-US,en;q=0.5"
   Http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   If colng <> 0 Then
   Http.setRequestHeader "Cookie", cData
   End If
   Http.setRequestHeader "Connection", "keep -alive"
   Http.setRequestHeader "Cache-Control", "max-age=0"
   If dlong <> 0 Then
   Http.setRequestHeader "Content-Length", LTrim(Str(dlong))
   httpsndtxt = pData
   End If
   Http.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300
   Http.send httpsndtxt
   GetSourceCode = Http.responseText
   Set Http = Nothing
   Exit Function
ErrorHandler:
   Dim E As ErrObject: Set E = err
End Function
Private Function BaseShuffle(sStr As String, ShuffleMap As String) As String
Dim mpmem() As String
mpmem = Split(ShuffleMap, ",")
For shfi = 1 To UBound(mpmem) + 1
BaseShuffle = BaseShuffle + Mid(sStr, mpmem(shfi - 1), 1)
Next
End Function
Private Function Shuffle(sStr As String) As String
Dim ccount As Long
Dim ispf As Long
ccount = Fix(Len(sStr) / 20)
For ispf = 1 To ccount
Shuffle = Shuffle + BaseShuffle(Mid(sStr, (ispf - 1) * 20 + 1, 20), "9,15,4,16,2,7,19,5,12,20,8,14,17,11,3,18,6,13,1,10")
Next
Shuffle = Shuffle + Mid(sStr, ccount * 20 + 1, Len(sStr) - ccount * 20)
End Function
Private Function DeShuffle(sStr As String) As String
ccount = Fix(Len(sStr) / 20)
For ispf = 1 To ccount
DeShuffle = DeShuffle + BaseShuffle(Mid(sStr, (ispf - 1) * 20 + 1, 20), "19,5,15,3,8,17,6,11,1,20,14,9,18,12,2,4,13,16,7,10")
Next
DeShuffle = DeShuffle + Mid(sStr, ccount * 20 + 1, Len(sStr) - ccount * 20)
End Function
Private Sub Command2_Click()
'Me.WindowState = vbMinimized
End Sub
Private Sub Form_Initialize()
InitCommonControls
End Sub
Private Sub Form_Click()
If onbtt(1) Then
wndst = Me.WindowState
Me.WindowState = vbMinimized
Me.Hide
DoEvents
PlayerForm.Show
Shell_NotifyIcon NIM_ADD, nid
ElseIf onbtt(2) Then
wndst = Me.WindowState
Configfrm.Show vbModal, Me
ElseIf onbtt(3) Then
Shell_NotifyIcon NIM_DELETE, nid
exrq = True
'Date = truedate
MsgBox "We hope you enjoyed your time. Thank you!.", vbInformation, "Thanks"
Unload Serverfrm
Unload ServerForm
Unload RadioServer
End
ElseIf onbtt(4) Then
If AdLinkURL <> "" Then
Me.WindowState = vbMinimized
ShellExecute 0, "open", AdLinkURL, 0, 0, 1
End If
End If
End Sub

Private Sub Form_DblClick()
If onbtt(1) Then
BuutonPaint 1, 2
ElseIf onbtt(2) Then
BuutonPaint 2, 2
ElseIf onbtt(3) Then
BuutonPaint 3, 2
End If
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
      If onbtt(1) Then
BuutonPaint 1, 2
ElseIf onbtt(2) Then
BuutonPaint 2, 2
ElseIf onbtt(3) Then
BuutonPaint 3, 2
End If
End Sub

     Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
     'this procedure receives the callbacks from the System Tray icon.
     Dim Result As Long
     Dim msg As Long
      'the value of X will vary depending upon the scalemode setting
      If Me.ScaleMode = vbPixels Then
       msg = x
      Else
       msg = x / Screen.TwipsPerPixelX
      End If
      Select Case msg
       Case WM_LBUTTONUP        '514 restore form window
       Shell_NotifyIcon NIM_DELETE, nid
        Result = SetForegroundWindow(Me.hWnd)
        Me.Show
       Case WM_LBUTTONDBLCLK    '515 restore form window
       Shell_NotifyIcon NIM_DELETE, nid
        Result = SetForegroundWindow(Me.hWnd)
        Me.Show
       Case WM_RBUTTONUP        '517 display popup menu
        Result = SetForegroundWindow(Me.hWnd)
       If Me.Visible = False Then
        Me.PopupMenu Me.mPopupSys
        End If
      End Select
If (x > btx1(1) And x < btx2(1) And y > bty1(1) And y < bty2(1)) Then
If onbtt(1) = False Then
onbtt(1) = True
BuutonPaint 1, 1

If onbtt(2) = True Then
onbtt(2) = False
BuutonPaint 2, 0
End If
If onbtt(3) = True Then
onbtt(3) = False
BuutonPaint 3, 0
End If
If onbtt(4) = True Then
onbtt(4) = False
End If

End If
ElseIf (x > btx1(2) And x < btx2(2) And y > bty1(2) And y < bty2(2)) Then
If onbtt(2) = False Then
onbtt(2) = True
BuutonPaint 2, 1

If onbtt(1) = True Then
onbtt(1) = False
BuutonPaint 1, 0
End If
If onbtt(3) = True Then
onbtt(3) = False
BuutonPaint 3, 0
End If
If onbtt(4) = True Then
onbtt(4) = False
End If

End If
ElseIf (x > btx1(3) And x < btx2(3) And y > bty1(3) And y < bty2(3)) Then
If onbtt(3) = False Then
onbtt(3) = True
BuutonPaint 3, 1

If onbtt(1) = True Then
onbtt(1) = False
BuutonPaint 1, 0
End If
If onbtt(2) = True Then
onbtt(2) = False
BuutonPaint 2, 0
End If
If onbtt(4) = True Then
onbtt(4) = False
End If

End If
ElseIf (x > btx1(4) And x < btx2(4) And y > bty1(4) And y < bty2(4)) Then

If onbtt(4) = False Then
onbtt(4) = True

If onbtt(1) = True Then
onbtt(1) = False
BuutonPaint 1, 0
End If
If onbtt(2) = True Then
onbtt(2) = False
BuutonPaint 2, 0
End If
If onbtt(3) = True Then
onbtt(3) = False
BuutonPaint 3, 0
End If

End If
Else
Dim iu As Integer
onbtt(4) = False
For iu = 1 To 3
If onbtt(iu) = True Then
onbtt(iu) = False
BuutonPaint iu, 0
End If
Next
End If
     End Sub

Private Sub Form_Load()
Dim abdata() As Byte
abdata = LoadResData(109, "CUSTOM")
chlst = StrConv(abdata, vbUnicode)
'MsgBox chlst

Top = (Screen.Height - Height) / 3
Left = (Screen.Width - Width) / 2

bcx1(1) = 435
bcx2(1) = 3500
bcy1(1) = 2925
bcy2(1) = 4620
bcx1(2) = 5160
bcx2(2) = 8535
bcy1(2) = 3495
bcy2(2) = 5265
bcx1(3) = 10125
bcx2(3) = 13200
bcy1(3) = 3075
bcy2(3) = 4695
bcx1(4) = 50
bcx2(4) = 13600
bcy1(4) = 5600
bcy2(4) = 7850

strtwidth = 13635
strtheight = 7905

Picture1.Picture = Image1.Picture

Timer20.Interval = 200



SetTopMostWindow Me.hWnd, True
'Dim hMenu   As Long
'Dim lStyle As Long

   'disable MAXIMIZE button
   'lStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
   'lStyle = lStyle And Not WS_MAXIMIZEBOX
   'Call SetWindowLong(Me.hWnd, GWL_STYLE, lStyle)

Me.Hide
      Me.Refresh
      With nid
       .cbSize = Len(nid)
       .hWnd = Me.hWnd
       .uId = vbNull
       .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
       .uCallBackMessage = WM_MOUSEMOVE
       .hIcon = Me.Icon
       .szTip = Caption & vbNullChar
      End With
      'Shell_NotifyIcon NIM_ADD, nid
stdate = NewDate
truedate = NewDate

Serverfrm.Visible = False
ServerForm.Visible = False
ServerForm.StartServer 43155, "", 0
RadioServer.Visible = False
RadioServer.StartServer 43156, "", 0
'origurl = "http://Destroyerv1.mooo.com"
origurl = conURL + "fastupdate.php"
Dim stfl As String
Dim frefl As Long
frefl = FreeFile
Open AppPath + "config.sys" For Binary As frefl
stfl = String(LOF(frefl), " ")
Get frefl, , stfl
Close frefl
'MsgBox Hex2String(DeShuffle(stfl))
If stfl <> "" Then
stfl = Hex2String(DeShuffle(stfl))
stfll = Split(stfl, "|")
stdate = stfll(0)
'Date = stdate
If stfll(1) = "" Then
autourl = origurl
Else
autourl = stfll(1)
End If
If UBound(stfll) < 2 Then
QualOp = 0
SaveConfig
Else
QualOp = Val(stfll(2))
End If
Else
autourl = origurl
QualOp = 0
SaveConfig
End If
'Timer1.Interval = 500
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If onbtt(1) Then
BuutonPaint 1, 1
ElseIf onbtt(2) Then
BuutonPaint 2, 1
ElseIf onbtt(3) Then
BuutonPaint 3, 1
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
msgbe = MsgBox("All Channels Will Be Closed. Click 'No' to Mninmize", vbYesNo, "Are you Sure?")
If msgbe = vbYes Then
exrq = True
'Date = truedate
Shell_NotifyIcon NIM_DELETE, nid
Unload Serverfrm
Unload ServerForm
Unload RadioServer
MsgBox "We hope you enjoyed your time. Thank you!.", vbInformation, "Thanks"
End
Else
If exrq = False Then
Cancel = 1
wndst = Me.WindowState
Me.WindowState = vbMinimized
Me.Hide
Me.WindowState = wndst
Shell_NotifyIcon NIM_ADD, nid
End If
End If
End Sub
Private Sub Timer1_Timer()
Timer1.Interval = 0
Caption = "The Destroyer --> Connecting to the server. Please Wait ."
Timer2.Interval = 300
On Error GoTo extt
Dim gtxt As String
Dim gtxtex() As String
Dim gtxtexx() As String
gtxt = GetbyetSource(autourl, "", "")
DoEvents
gtxt = Replace(gtxt, "</span>", "")
gtxt = Replace(gtxt, "<wbr />", "")
gtxt = Replace(gtxt, "<span class=""word_break"">", "")
gtxt = Replace(gtxt, "<span>", "")
gtxtex = Split(gtxt, "fcestarttag123456789")
gtxtexx = Split(gtxtex(1), "fceendtag123456789")
gtxt = gtxtexx(0)
gtxt = Hex2String(gtxt)
gtxt = Replace(gtxt, "|", vbNewLine)
chlst = Shuffle(gtxt)
gtxt = gtxtexx(1)
gtxt = Hex2String(gtxt)
prgopt = Split(gtxt, "|")
If prgopt(0) = "2" Then
Shell_NotifyIcon NIM_DELETE, nid
exrq = True
'Date = truedate
MsgBox prgopt(1), vbInformation, "Closed"
Unload Serverfrm
Unload ServerForm
Unload RadioServer
End
End If
If prgopt(2) <> "" And prgopt(3) <> "" Then
AdLinkURL = prgopt(2)
AdIMGURL = prgopt(3)
Timer30.Interval = 200
Else
Caption = "The Destroyer --> Successfully Connected "
End If
Timer2.Interval = 0

Exit Sub
extt:
'chlst = ""
Caption = "The Destroyer --> Error: Can't Connect to the Server"
MsgBox "Error: Can't Connect to the Server" + vbNewLine + "Just exit and retry" + vbNewLine + "You Can add the Channel List Manually in the player", vbCritical, "Error"
Timer2.Interval = 0

End Sub

Private Sub Timer20_Timer()
MainForm.PaintPicture Image1.Picture, 0, 0, (Me.ScaleWidth), (Me.ScaleHeight), 0, 0, Image1.Width, Image1.Height
BuutonPaint 1, 0
BuutonPaint 2, 0
BuutonPaint 3, 0
Timer20.Interval = 0
End Sub

Private Sub Timer30_Timer()
Caption = "The Destroyer --> Loading the advertisement. Please Wait .."
On Error Resume Next
Timer30.Interval = 0
Dim dnst As Boolean
dnst = DownloadFile(AdIMGURL, "c:\tmp00")

If dnst = True Then
Image4.Picture = LoadPicture("c:\tmp00")
Kill "c:\tmp00"
Picture1.PaintPicture Image4.Picture, 90, 7660, 19035, 3060, 0, 0, Image4.Width, Image4.Height
Image1.Picture = Picture1.Image
MainForm.PaintPicture Image1.Picture, 0, 0, (Me.ScaleWidth), (Me.ScaleHeight), 0, 0, Image1.Width, Image1.Height
End If
Caption = "The Destroyer --> Successfully Connected "
End Sub

     Private Sub xit_Click()
      'called when user clicks the popup menu Exit command
      Shell_NotifyIcon NIM_DELETE, nid
      End
     End Sub

     Private Sub mxz_Click()
      'called when the user clicks the popup menu Restore command
     Shell_NotifyIcon NIM_DELETE, nid
      Dim Result As Long
      Me.WindowState = vbNormal
      Result = SetForegroundWindow(Me.hWnd)
      Me.Show
     
     End Sub

   Private Sub Form_Resize()
     
For i = 1 To 4
btx1(i) = bcx1(i) / strtwidth * (Me.ScaleWidth)
btx2(i) = bcx2(i) / strtwidth * (Me.ScaleWidth)
bty1(i) = bcy1(i) / strtheight * (Me.ScaleHeight)
bty2(i) = bcy2(i) / strtheight * (Me.ScaleHeight)
Next

MainForm.PaintPicture Image1.Picture, 0, 0, (Me.ScaleWidth), (Me.ScaleHeight), 0, 0, Image1.Width, Image1.Height
Timer20.Interval = 200
     End Sub
Private Sub Timer2_Timer()
Caption = Caption + "."
End Sub
Public Function GetDate() As String
GetDate = stdate
End Function
Public Function SetDate(gDate)
stdate = gDate
'Date = gDate
SaveConfig
End Function
Public Function GetAutoURL() As String
GetAutoURL = autourl
End Function
Public Function GetDefaultURL() As String
GetDefaultURL = origurl
End Function
Public Function GetURLIF() As String
If origurl = autourl Then
GetURLIF = ""
Else
GetURLIF = autourl
End If
End Function
Public Function SetAutoURL(aUrl)
autourl = aUrl
SaveConfig
End Function
Public Function SetQualityOP(QuOp As Integer)
QualOp = QuOp
SaveConfig
End Function
Public Function GetQualityOP() As Integer
GetQualityOP = QualOp
End Function
Public Function SaveConfig()
On Error Resume Next
Dim frefl As Long
Dim stfl As String
If autourl = origurl Then
stfl = Shuffle(String2Hex(stdate + "||" + LTrim(Str(QualOp))))
Else
stfl = Shuffle(String2Hex(stdate + "|" + autourl + "|" + LTrim(Str(QualOp))))
End If
frefl = FreeFile
Kill AppPath + "config.sys"
Open AppPath + "config.sys" For Binary As frefl
Put frefl, , stfl
Close frefl
End Function
Public Function SendUpdate() As Boolean
On Error GoTo Err_Proc
Dim x As Integer
For x = 0 To Forms.Count - 1
If Forms(x).Name = "PlayerForm" Then
Forms(x).ListInit
End If
Next
Exit Function
Err_Proc:
MsgBox err.description
End Function
Public Function GetWindowState() As Integer
GetWindowState = wndst
End Function
Private Function NewDate() As String
Dim dayd As Long
Dim mond As Long
Dim yerd As Long
Dim dayds As String
Dim monds As String
Dim yerds As String
dayd = Day(Date)
mond = Month(Date)
yerd = Year(Date)
dayds = LTrim(Str(dayd))
monds = LTrim(Str(mond))
yerds = LTrim(Str(yerd))
If Len(dayds) = 1 Then dayds = "0" + dayds
If Len(monds) = 1 Then monds = "0" + monds
If Len(yerds) = 2 Then yerds = "20" + yerds
NewDate = dayds + "/" + monds + "/" + yerds
End Function
الرد }}}
تم الشكر بواسطة:
#4
للاسف ليس لي خبره  بالفيجوال بيسك 6
انتضر باقي الاعضاء
*ملاحظة : عند استفسارك عن كود ضعه في الموضوع واي شخص يعرف الجواب يجيبك
بالتوفيق
الْلَّهُم صَلِّ وَسَلِم وَبَارِك عَلَى سَيِّدِنَا مُحَمَّد
الرد }}}
تم الشكر بواسطة: Ahmed_Mansoor , Amir_Alzubidy , ابو ليلى , ابو ليلى
#5
(19-11-16, 01:36 AM)LoveVb كتب : للاسف ليس لي خبره  بالفيجوال بيسك 6
انتضر باقي الاعضاء
*ملاحظة : عند استفسارك عن كود ضعه في الموضوع واي شخص يعرف الجواب يجيبك
بالتوفيق

الف تحية وتقدير لك اخي الكريم lovevb
واتمنى من الاخوة الكرام المساعدة
الرد }}}
تم الشكر بواسطة: LoveVb
#6
انس الامر برمته
ركب الدوت نت وخذ الفكرة من البرنامج الاول وطبقها على الدوت نت
ستجد صعوبة في البداية ولكن بعد فترة بسيطة ستجد ان تعاملك مع الدوت نت ابسط مليون مرة من الفيجوال 6
النسخ التي تحوي معالجات تحويل هي 205 و 2008
فقط وليس لكل الاكواد
اليوم نحن نرى نسخة 2017
فلا تتعب نفسك بتحويل الاكواد ومحاولة اصلاح اخطاء التحويل
والامر يعود لك
سبحان الله والحمدلله ولا إله إلا الله والله أكبر
 اللهم اغْفِرْ لِلمؤمنين والمؤمنات والمسلمين والمسلمات الأحياء منهم والأموات
الرد }}}
تم الشكر بواسطة: Amir_Alzubidy , ابو ليلى , Ahmed_Mansoor
#7
(19-11-16, 03:09 AM)أبو عمر كتب : انس الامر برمته
ركب الدوت نت وخذ الفكرة من البرنامج الاول وطبقها على الدوت نت
ستجد صعوبة في البداية ولكن بعد فترة بسيطة ستجد ان تعاملك مع الدوت نت ابسط مليون مرة من الفيجوال 6
النسخ التي تحوي معالجات تحويل هي 205 و 2008
فقط وليس لكل الاكواد  
اليوم نحن نرى نسخة 2017
فلا تتعب نفسك بتحويل الاكواد ومحاولة اصلاح اخطاء التحويل
والامر يعود لك

شكرا لك اخي ابو عمر على النصيحة القيمة لكن لدى برنامج مفتوح المصدر  معمول بالفيجول 6 به خاصية بحثت عن اكوادها وطرحت الاسؤلة في هذا المنتدى الغالي ولم اجدها لذا لجأة الى فكرة التحويل
الرد }}}
تم الشكر بواسطة:
#8
اظن اقتراح الاخ ابو عمر افضل لك 
و بكل الاحوال هذا تحويل و لا ادري ان كان يعمل معك او حتى اذا كان يعطي النتيجة المطلوبة
PHP كود :
ImportsSystem
Imports System
.Windows.Forms
Imports System
.Windows.Forms.Screen
Imports System
.Text
Imports System
.Runtime.InteropServices
Imports Microsoft
.VisualBasic
Imports Microsoft
.VisualBasic.Compatibility.VB6


    Private 
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As IntegerByVal lpOperation As StringByVal lpFile As StringByVal lpParameters As StringByVal lpDirectory As StringByVal nShowCmd As Integer) As Integer
    Private 
Const GWL_STYLE As Short = (-16)
 
   Private Const WS_MAXIMIZEBOX As Integer = &H10000
    Private 
Const WS_THICKFRAME As Integer = &H40000
    Private 
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As IntegerByVal nIndex As IntegerByVal dwNewLong As Integer) As Integer
    Private 
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As IntegerByVal nIndex As Integer) As Integer
    Private 
Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As IntegerByVal szURL As StringByVal szFileName As StringByVal dwReserved As IntegerByVal lpfnCB As Integer) As Integer

    Structure NOTIFYICONDATA
        Dim cbSize 
As Integer
        Dim hWnd 
As Integer
        Dim uId 
As Integer
        Dim uFlags 
As Integer
        Dim uCallBackMessage 
As Integer
        Dim hIcon 
As Integer
        Dim szTip 
As StringBuilder
    
        Public Sub 
New(ByVal unusedParam As Integer)
 
           szTip = New StringBuilder(Space(64), 64)
 
       End Sub
    End Structure

    Private 
Const NIM_ADD As Short = &H0
    Private 
Const NIM_MODIFY As Short = &H1
    Private 
Const NIM_DELETE As Short = &H2
    Private 
Const NIF_MESSAGE As Short = &H1
    Private 
Const NIF_ICON As Short = &H2
    Private 
Const NIF_TIP As Short = &H4
    Private 
Const WM_MOUSEMOVE As Short = &H200
    Private 
Const WM_LBUTTONDOWN As Short = &H201 'Button down
    Private Const WM_LBUTTONUP As Short = &H202 '
Button up
    Private 
Const WM_LBUTTONDBLCLK As Short = &H203 'Double-click
    Private Const WM_RBUTTONDOWN As Short = &H204 '
Button down
    Private 
Const WM_RBUTTONUP As Short = &H205 'Button up
    Private Const WM_RBUTTONDBLCLK As Short = &H206 '
Double-click

    Private 
Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Integer) As Integer
    Private 
Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As IntegerByRef pnid As NOTIFYICONDATA) As Boolean

    Private nid 
As New NOTIFYICONDATA(0)
 
   Private Const ERROR_SUCCESS As Integer 0
    Private 
Const BINDF_GETNEWESTVERSION As Integer = &H10
    Private 
Const INTERNET_FLAG_RELOAD As Integer = &H80000000
    Dim onbtt
(4) As Boolean
    Dim btx1
(4) As Integer
    Dim btx2
(4) As Integer
    Dim bty1
(4) As Integer
    Dim bty2
(4) As Integer
    Dim bcx1
(4) As Integer
    Dim bcx2
(4) As Integer
    Dim bcy1
(4) As Integer
    Dim bcy2
(4) As Integer
    Dim strtwidth 
As Integer
    Dim strtheight 
As Integer
    Dim strtad 
As Boolean
    Dim AdLinkURL 
As String
    Dim AdIMGURL 
As String
    Dim exrq 
As Boolean
    Dim chlst 
As String
    Dim autourl 
As String
    Dim origurl 
As String
    Dim stdate 
As String
    Dim truedate 
As String
    Dim wndst 
As Short
    Dim QualOp 
As Short
    Dim fresult 
As String

    
        Public Sub ShowResultinVBApplication
(ByVal strResultfromJavascript As String)
 
       Dim fresult As String
        fresult 
strResultfromJavascript
    End Sub


    Private 
Function GetbyetSource(ByVal sUrl As StringByVal pData As StringByVal cData As String) As String
        GetbyetSource 
0
        Dim reslt2 
As Objectreslt1() As Stringreslt() As Stringfresult As String  ' - "AutoDim"

        Try
            Dim abdata() As Byte
            Dim txtcode As String
            abdata = LoadResData(107, "CUSTOM")
            txtcode = Encoding.Default.GetString(abdata)
            reslt2 = GetSourceCode(sUrl, "", "")
            reslt1 = Split(Convert.ToString(reslt2), "<script>")
            reslt = Split(reslt1(1), "document.cookie")
            txtcode += reslt(0)
            ScriptControl1.language = "JavaScript"
            ScriptControl1.Reset()
            ScriptControl1.timeout = NoTimeout
            ScriptControl1.AddObject("Any text you want", Me, True)
            ScriptControl1.AddCode(txtcode)
            fresult = ""
            ScriptControl1.Run("GetCookie", "")
            While fresult = ""
            End While
            GetbyetSource = GetSourceCode(sUrl, pData, fresult)
            Exit Function
        Catch
            Dim E As ErrObject : E = err
        End Try
    End Function

    Private Function BuutonPaint(ByVal bnum As Short, ByVal abov As Short) As Object
        BuutonPaint = 0
        If abov = 0 Then
            MainForm.PaintPicture(Image1.Picture, btx1(bnum), bty1(bnum), btx2(bnum) - btx1(bnum), bty2(bnum) - bty1(bnum), bcx1(bnum) / strtwidth * Image1.Width, bcy1(bnum) / strtheight * Image1.Height, (bcx2(bnum) - bcx1(bnum)) / strtwidth * Image1.Width, (bcy2(bnum) - bcy1(bnum)) / strtheight * Image1.Height)
        ElseIf abov = 1 Then
            MainForm.PaintPicture(Image2.Picture, btx1(bnum), bty1(bnum), btx2(bnum) - btx1(bnum), bty2(bnum) - bty1(bnum), bcx1(bnum) / strtwidth * Image1.Width, bcy1(bnum) / strtheight * Image1.Height, (bcx2(bnum) - bcx1(bnum)) / strtwidth * Image1.Width, (bcy2(bnum) - bcy1(bnum)) / strtheight * Image1.Height)
        ElseIf abov = 2 Then
            MainForm.PaintPicture(Image3.Picture, btx1(bnum), bty1(bnum), btx2(bnum) - btx1(bnum), bty2(bnum) - bty1(bnum), bcx1(bnum) / strtwidth * Image1.Width, bcy1(bnum) / strtheight * Image1.Height, (bcx2(bnum) - bcx1(bnum)) / strtwidth * Image1.Width, (bcy2(bnum) - bcy1(bnum)) / strtheight * Image1.Height)
        End If
    End Function

    Private Function DownloadFile(ByVal sSourceUrl As String, ByVal sLocalFile As String) As Boolean
        DownloadFile = False
        DownloadFile = URLDownloadToFile(0, sSourceUrl, sLocalFile, BINDF_GETNEWESTVERSION, 0) = ERROR_SUCCESS
    End Function

    Private Function Hex2String(ByVal nStr As String) As String
        Hex2String = 0
        Dim i As Double

        For i = 1 To Len(nStr) / 2
            Hex2String += Convert.ToString(Chr(Val("&H" + Mid(nStr, i * 2 - 1, 2))))
        Next
    End Function

    
        Private Function String2Hex(ByVal nStr As String) As String
        Dim i As Integer

        For i = 1 To Len(nStr)
            String2Hex += Hex(Asc(Mid(nStr, i, 1)))
        Next

    End Function

    Private Function AppPath() As String
        AppPath = 0
        If Strings.Right(AppPath, 1) <> "\" Then
            AppPath += "\"
        End If
    End Function

    Public Function GetChannelList() As String
        GetChannelList = 0
        GetChannelList = Replace(DecryptS(chlst), "|||||", vbNewLine)
    End Function

    Public Function UpdateChannelList(ByVal nChlist As String) As String
        UpdateChannelList = 0
        Dim chlst As String

        chlst = nChlist
        SendUpdate()
    End Function

    Private Function GetSourceCode(ByVal sUrl As String, ByVal pData As String, ByVal cData As String) As String
        GetSourceCode = 0
        Dim Http As WinHttp.WinHttpRequest
        Dim httpsndtxt As String
        Dim ftcstr() As String
        Dim dlong As Integer
        Dim colng As Integer
        dlong = Len(pData)
        colng = Len(cData)
        httpsndtxt = ""
        Try
            ftcstr = Split(sUrl, "/")
            Http = New WinHttp.WinHttpRequest
            If dlong = 0 Then
                Http.open("GET", sUrl, False)
            Else
                Http.open("POST", sUrl, False)
            End If
            Http.setRequestHeader("Host", ftcstr(2))
            Http.setRequestHeader("User-Agent", "Mozilla/5.0 WINDOWS NT 5.1; rv:43.0)Gecko/20100101 Firefox/43.0")
            Http.setRequestHeader("Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8")
            Http.setRequestHeader("Accept-Language", "en-US,en;q=0.5")
            Http.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
            If colng <> 0 Then
                Http.setRequestHeader("Cookie", cData)
            End If
            Http.setRequestHeader("Connection", "keep -alive")
            Http.setRequestHeader("Cache-Control", "max-age=0")
            If dlong <> 0 Then
                Http.setRequestHeader("Content-Length", LTrim(Str(dlong)))
                httpsndtxt = pData
            End If
            Http.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300
            Http.send(httpsndtxt)
            GetSourceCode = Http.responseText
            Http = Nothing
            Exit Function
        Catch
            Dim E As ErrObject : E = err
        End Try
    End Function

    Private Function BaseShuffle(ByVal sStr As String, ByVal ShuffleMap As String) As String
        BaseShuffle = 0
        Dim shfi As Integer

        Dim mpmem() As String
        mpmem = Split(ShuffleMap, ",")
        For shfi = 1 To UBound(mpmem) + 1
            BaseShuffle += Mid(sStr, mpmem(shfi - 1), 1)
        Next
    End Function


    Private Function Shuffle(ByVal sStr As String) As String
        Shuffle = 0
        Dim ccount As Integer
        Dim ispf As Integer
        ccount = Fix(Len(sStr) / 20)
        For ispf = 1 To ccount
            Shuffle += BaseShuffle(Mid(sStr, (ispf - 1) * 20 + 1, 20), "9,15,4,16,2,7,19,5,12,20,8,14,17,11,3,18,6,13,1,10")
        Next
        Shuffle += Mid(sStr, ccount * 20 + 1, Len(sStr) - ccount * 20)
    End Function


    Private Function DeShuffle(ByVal sStr As String) As String
        DeShuffle = 0
        Dim ccount As Integer, ispf As Integer

        ccount = Fix(Len(sStr) / 20)
        For ispf = 1 To ccount
            DeShuffle += BaseShuffle(Mid(sStr, (ispf - 1) * 20 + 1, 20), "19,5,15,3,8,17,6,11,1,20,14,9,18,12,2,4,13,16,7,10")
        Next
        DeShuffle += Mid(sStr, ccount * 20 + 1, Len(sStr) - ccount * 20)
    End Function

    
    
    Private Sub Form_Initialize()
        InitCommonControls()
    End Sub

    Private Sub Form_Click()
        Dim wndst As Object, exrq As Boolean

        If onbtt(1) Then
            wndst = Me.WindowState
            Me.WindowState = FormWindowState.Minimized
            Me.Hide()
            Application.DoEvents()
            PlayerForm.Show()
            Shell_NotifyIcon(NIM_ADD, nid)
        ElseIf onbtt(2) Then
            wndst = Me.WindowState
            Configfrm.Show(FormShowConstants.Modal, Me)
        ElseIf onbtt(3) Then
            Shell_NotifyIcon(NIM_DELETE, nid)
            exrq = True
            '
Date truedate
            MsgBox
("We hope you enjoyed your time. Thank you!."MsgBoxStyle.Information"Thanks")
 
           UnloadControl(Serverfrm)
 
           UnloadControl(ServerForm)
 
           UnloadControl(RadioServer)
 
           Application.Exit()
 
       ElseIf onbtt(4Then
            If AdLinkURL 
<> "" Then
                Me
.WindowState FormWindowState.Minimized
                ShellExecute
(0"open"AdLinkURL001)
 
           End If
 
       End If
 
   End Sub

    Private Sub Form_DblClick
()
 
       If onbtt(1Then
            BuutonPaint
(12)
 
       ElseIf onbtt(2Then
            BuutonPaint
(22)
 
       ElseIf onbtt(3Then
            BuutonPaint
(32)
 
       End If
 
   End Sub

    Private Sub Form_MouseDown
(ByVal Button As ShortByVal Shift As ShortByVal x As SingleByVal y As Single)
 
       If onbtt(1Then
            BuutonPaint
(12)
 
       ElseIf onbtt(2Then
            BuutonPaint
(22)
 
       ElseIf onbtt(3Then
            BuutonPaint
(32)
 
       End If
 
   End Sub

        Private Sub Form_MouseMove
(ByVal Button As ShortByVal Shift As ShortByVal x As SingleByVal y As Single)
 
       Dim Result As Integer
        Dim msg 
As Integer
        If Me_ds
.ScaleMode vbPixels Then
            msg 
x
        Else
            msg 
VB6.TwipsPerPixelX
        End 
If
 
       Select Case msg
            Case WM_LBUTTONUP
                
'514 restore form window
                Shell_NotifyIcon(NIM_DELETE, nid)
                Result = SetForegroundWindow(Me.hWnd)
                ShowModeless(Me)
            Case WM_LBUTTONDBLCLK
                '
515 restore form window
                Shell_NotifyIcon
(NIM_DELETEnid)
 
               Result SetForegroundWindow(Me.hWnd)
 
               ShowModeless(Me)
 
           Case WM_RBUTTONUP
                
'517 display popup menu
                Result = SetForegroundWindow(Me.hWnd)
                If Me.Visible = False Then
                    ShowPopupMenu(Me.mPopupSys, Me, e.Location)
                End If
        End Select
        If (x > btx1(1) And x < btx2(1) And y > bty1(1) And y < bty2(1)) Then
            If onbtt(1) = False Then
                onbtt(1) = True
                BuutonPaint(1, 1)

                If onbtt(2) = True Then
                    onbtt(2) = False
                    BuutonPaint(2, 0)
                End If
                If onbtt(3) = True Then
                    onbtt(3) = False
                    BuutonPaint(3, 0)
                End If
                If onbtt(4) = True Then
                    onbtt(4) = False
                End If

            End If
        ElseIf (x > btx1(2) And x < btx2(2) And y > bty1(2) And y < bty2(2)) Then
            If onbtt(2) = False Then
                onbtt(2) = True
                BuutonPaint(2, 1)

                If onbtt(1) = True Then
                    onbtt(1) = False
                    BuutonPaint(1, 0)
                End If
                If onbtt(3) = True Then
                    onbtt(3) = False
                    BuutonPaint(3, 0)
                End If
                If onbtt(4) = True Then
                    onbtt(4) = False
                End If

            End If
        ElseIf (x > btx1(3) And x < btx2(3) And y > bty1(3) And y < bty2(3)) Then
            If onbtt(3) = False Then
                onbtt(3) = True
                BuutonPaint(3, 1)

                If onbtt(1) = True Then
                    onbtt(1) = False
                    BuutonPaint(1, 0)
                End If
                If onbtt(2) = True Then
                    onbtt(2) = False
                    BuutonPaint(2, 0)
                End If
                If onbtt(4) = True Then
                    onbtt(4) = False
                End If

            End If
        ElseIf (x > btx1(4) And x < btx2(4) And y > bty1(4) And y < bty2(4)) Then

            If onbtt(4) = False Then
                onbtt(4) = True

                If onbtt(1) = True Then
                    onbtt(1) = False
                    BuutonPaint(1, 0)
                End If
                If onbtt(2) = True Then
                    onbtt(2) = False
                    BuutonPaint(2, 0)
                End If
                If onbtt(3) = True Then
                    onbtt(3) = False
                    BuutonPaint(3, 0)
                End If

            End If
        Else
            Dim iu As Short
            onbtt(4) = False
            For iu = 1 To 3
                If onbtt(iu) = True Then
                    onbtt(iu) = False
                    BuutonPaint(iu, 0)
                End If
            Next
        End If
    End Sub

        Private Sub Form_Load()
        Dim chlst As String, Top As Double, Left As Double, strtwidth As Short, strtheight As Short
        Dim stdate As String, truedate As Object, origurl As String, stfll() As String, autourl As String
        Dim QualOp As Double    ' 
"AutoDim"

 
       Dim abdata() As Byte
        abdata 
LoadResData(109"CUSTOM")
 
       chlst Encoding.Default.GetString(abdata)
 
       'MsgBox chlst

        Top = (PrimaryScreen.Bounds.Height - Height) / 3
        Left = (PrimaryScreen.Bounds.Width - Width) / 2

        bcx1(1) = 435
        bcx2(1) = 3500
        bcy1(1) = 2925
        bcy2(1) = 4620
        bcx1(2) = 5160
        bcx2(2) = 8535
        bcy1(2) = 3495
        bcy2(2) = 5265
        bcx1(3) = 10125
        bcx2(3) = 13200
        bcy1(3) = 3075
        bcy2(3) = 4695
        bcx1(4) = 50
        bcx2(4) = 13600
        bcy1(4) = 5600
        bcy2(4) = 7850

        strtwidth = 13635
        strtheight = 7905

        Picture1.Picture = Image1.Picture

        Timer20.Interval = 200



        SetTopMostWindow(Me.hWnd, True)
        '
Dim hMenu   As Long
        
'Dim lStyle As Long

        '
disable MAXIMIZE button
        
'lStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
        '
lStyle lStyle And Not WS_MAXIMIZEBOX
        
'Call SetWindowLong(Me.hWnd, GWL_STYLE, lStyle)

        Me.Hide()
        Me.Refresh()
        With nid
            .cbSize = Len(nid)
            .hWnd = Me.hWnd
            .uId = IntPtr.Zero
            .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
            .uCallBackMessage = WM_MOUSEMOVE
            .hIcon = Me.Icon
            .szTip = Caption & vbNullChar
        End With
        '
Shell_NotifyIcon NIM_ADDnid
        stdate 
NewDate
        truedate 
NewDate

        Serverfrm
.Visible False
        ServerForm
.Visible False
        ServerForm
.StartServer(43155""0)
 
       RadioServer.Visible False
        RadioServer
.StartServer(43156""0)
 
       'origurl = "http://Destroyerv1.mooo.com"
        origurl = conURL + "fastupdate.php"
        Dim stfl As String
        Dim frefl As Integer
        frefl = FreeFile()
        FileOpen(frefl, AppPath + "config.sys", OpenMode.Binary)
        stfl = StrDup(LOF(frefl), " ")
        FileGet(frefl, stfl)
        FileClose(frefl)
        '
MsgBox Hex2String(DeShuffle(stfl))
 
       If stfl <> "" Then
            stfl 
Hex2String(DeShuffle(stfl))
 
           stfll Split(stfl"|")
 
           stdate stfll(0)
 
           'Date = stdate
            If stfll(1) = "" Then
                autourl = origurl
            Else
                autourl = stfll(1)
            End If
            If UBound(stfll) < 2 Then
                QualOp = 0
                SaveConfig()
            Else
                QualOp = ValFromObject(stfll(2))
            End If
        Else
            autourl = origurl
            QualOp = 0
            SaveConfig()
        End If
        '
Timer1.Interval 500
    End Sub

        Private Sub Form_MouseUp
(ByVal Button As ShortByVal Shift As ShortByVal x As SingleByVal y As Single)
 
       If onbtt(1Then
            BuutonPaint
(11)
 
       ElseIf onbtt(2Then
            BuutonPaint
(21)
 
       ElseIf onbtt(3Then
            BuutonPaint
(31)
 
       End If

 
   End Sub

    Private Sub Form_Unload
(ByRef Cancel As Short)
 
       Dim msgbe As DialogResultexrq As Booleanwndst As Object Nothing

        msgbe 
MsgBox("All Channels Will Be Closed. Click 'No' to Mninmize"MsgBoxStyle.YesNo"Are you Sure?")
 
       If msgbe DialogResult.Yes Then
            exrq 
True
            
'Date = truedate
            Shell_NotifyIcon(NIM_DELETE, nid)
            UnloadControl(Serverfrm)
            UnloadControl(ServerForm)
            UnloadControl(RadioServer)
            MsgBox("We hope you enjoyed your time. Thank you!.", MsgBoxStyle.Information, "Thanks")
            Application.Exit()
        Else
            If exrq = False Then
                Cancel = 1
                wndst = Me.WindowState
                Me.WindowState = FormWindowState.Minimized
                Me.Hide()
                Me.WindowState = wndst
                Shell_NotifyIcon(NIM_ADD, nid)
            End If
        End If
    End Sub

    Private Sub Timer1_Timer()
        Dim Caption As String, chlst As Object, prgopt() As String, exrq As Boolean, AdLinkURL As String
        Dim AdIMGURL As String  ' 
"AutoDim"

 
       Timer1.Interval 0
        Caption 
"The Destroyer --> Connecting to the server. Please Wait ."
 
       Timer2.Interval 300
        Try 
' On Error GoTo extt
            Dim gtxt As String
            Dim gtxtex() As String
            Dim gtxtexx() As String
            gtxt = GetbyetSource(autourl, "", "")
            Application.DoEvents()
            gtxt = Replace(gtxt, "</span>", "")
            gtxt = Replace(gtxt, "<wbr />", "")
            gtxt = Replace(gtxt, "<span class=""word_break"">", "")
            gtxt = Replace(gtxt, "<span>", "")
            gtxtex = Split(gtxt, "fcestarttag123456789")
            gtxtexx = Split(gtxtex(1), "fceendtag123456789")
            gtxt = gtxtexx(0)
            gtxt = Hex2String(gtxt)
            gtxt = Replace(gtxt, "|", vbNewLine)
            chlst = Shuffle(gtxt)
            gtxt = gtxtexx(1)
            gtxt = Hex2String(gtxt)
            prgopt = Split(gtxt, "|")
            If prgopt(0) = "2" Then
                Shell_NotifyIcon(NIM_DELETE, nid)
                exrq = True
                '
Date truedate
                MsgBox
(prgopt(1), MsgBoxStyle.Information"Closed")
 
               UnloadControl(Serverfrm)
 
               UnloadControl(ServerForm)
 
               UnloadControl(RadioServer)
 
               Application.Exit()
 
           End If
 
           If prgopt(2) <> "" And prgopt(3) <> "" Then
                AdLinkURL 
prgopt(2)
 
               AdIMGURL prgopt(3)
 
               Timer30.Interval 200
            Else
                Caption 
"The Destroyer --> Successfully Connected "
 
           End If
 
           Timer2.Interval 0

            Exit Sub
        Catch   
' extt:
            '
chlst ""
 
           Caption "The Destroyer --> Error: Can't Connect to the Server"
 
           MsgBox("Error: Can't Connect to the Server" vbNewLine "Just exit and retry" vbNewLine "You Can add the Channel List Manually in the player"MsgBoxStyle.Critical"Error")
 
           Timer2.Interval 0

        End 
Try
 
   End Sub

    Private Sub Timer20_Timer
()
 
       MainForm.PaintPicture(Image1.Picture00, (Me.ScaleWidth), (Me.ScaleHeight), 00Image1.WidthImage1.Height)
 
       BuutonPaint(10)
 
       BuutonPaint(20)
 
       BuutonPaint(30)
 
       Timer20.Interval 0
    End Sub

    
        Private Sub Timer30_Timer
()
 
       Dim Caption As String

        Caption 
"The Destroyer --> Loading the advertisement. Please Wait .."
 
       On Error Resume Next
        Timer30
.Interval 0
        Dim dnst 
As Boolean
        dnst 
DownloadFile(AdIMGURL"c:\tmp00")

 
       If dnst True Then
            Image4
.Picture LoadPicture("c:\tmp00")
 
           Kill("c:\tmp00")
 
           Picture1.PaintPicture(Image4.Picture90766019035306000Image4.WidthImage4.Height)
 
           Image1.Picture Picture1.Image
            MainForm
.PaintPicture(Image1.Picture00, (Me.ScaleWidth), (Me.ScaleHeight), 00Image1.WidthImage1.Height)
 
       End If
 
       Caption "The Destroyer --> Successfully Connected "
 
   End Sub

    Private Sub xit_Click
()
 
       'called when user clicks the popup menu Exit command
        Shell_NotifyIcon(NIM_DELETE, nid)
        Application.Exit()
    End Sub

    Private Sub mxz_Click()
        '
called when the user clicks the popup menu Restore command
        Shell_NotifyIcon
(NIM_DELETEnid)
 
       Dim Result As Integer
        Me
.WindowState FileAttribute.Normal
        Result 
SetForegroundWindow(Me.hWnd)
 
       ShowModeless(Me)

 
   End Sub

    Private Sub Form_Resize
()
 
       Dim i As Short  ' - "AutoDim"


        For i = 1 To 4
            btx1(i) = bcx1(i) / strtwidth * (Me_ds.ScaleWidth)
            btx2(i) = bcx2(i) / strtwidth * (Me_ds.ScaleWidth)
            bty1(i) = bcy1(i) / strtheight * (Me_ds.ScaleHeight)
            bty2(i) = bcy2(i) / strtheight * (Me_ds.ScaleHeight)
        Next

        MainForm.PaintPicture(Image1.Picture, 0, 0, (Me.ScaleWidth), (Me.ScaleHeight), 0, 0, Image1.Width, Image1.Height)
        Timer20.Interval = 200
    End Sub

    Private Sub Timer2_Timer()
        ' 
VBto upgrade warningCaption As Variant --> As String
        Dim Caption 
As String   ' - "AutoDim"

        Caption += "."
    End Sub

    Public Function GetDate() As String
        GetDate = 0
        GetDate = stdate
    End Function

    Public Function SetDate(ByVal gDate As Object) As Object
        SetDate = 0
        Dim stdate As Object    ' 
"AutoDim"

 
       stdate gDate
        
'Date = gDate
        SaveConfig()
    End Function

    Public Function GetAutoURL() As String
        GetAutoURL = 0
        GetAutoURL = autourl
    End Function

    Public Function GetDefaultURL() As String
        GetDefaultURL = 0
        GetDefaultURL = origurl
    End Function

    Public Function GetURLIF() As String
        GetURLIF = 0
        If origurl = autourl Then
            GetURLIF = ""
        Else
            GetURLIF = autourl
        End If
    End Function

    
        Public Function SetAutoURL(ByVal aUrl As Object) As Object
        SetAutoURL = 0
        Dim autourl As Object   ' 
"AutoDim"

 
       autourl aUrl
        SaveConfig
()
 
   End Function

 
   Public Function SetQualityOP(ByVal QuOp As Short) As Object
        SetQualityOP 
0
        
' VBto upgrade warning: QualOp As Variant --> As Short
        Dim QualOp As Short ' 
"AutoDim"

 
       QualOp QuOp
        SaveConfig
()
 
   End Function

 
   Public Function GetQualityOP() As Short
        GetQualityOP 
0
        GetQualityOP 
QualOp
    End 
Function

 
   Public Function SaveConfig() As Object
        SaveConfig 
0
        On Error Resume Next
        Dim frefl 
As Integer
        Dim stfl 
As String
        If autourl 
origurl Then
            stfl 
Shuffle(String2Hex(stdate "||" LTrim(Str(QualOp))))
 
       Else
            stfl 
Shuffle(String2Hex(stdate "|" autourl "|" LTrim(Str(QualOp))))
 
       End If
 
       frefl FreeFile()
 
       Kill(AppPath "config.sys")
 
       FileOpen(freflAppPath "config.sys"OpenMode.Binary)
 
       FilePut(freflstfl)
 
       FileClose(frefl)
 
   End Function

 
   Public Function SendUpdate() As Boolean
        SendUpdate 
False
        Try
            Dim x 
As Short
            For x 
0 To Application.OpenForms.Count 1
                If Application
.OpenForms(x).Name "PlayerForm" Then
                    Application
.OpenForms(x)ListInit
                End 
If
 
           Next
            Exit 
Function
 
       Catch
            MsgBox
(Err.Description)
 
       End Try
 
   End Function

 
   Public Function GetWindowState() As Short
        GetWindowState 
0
        GetWindowState 
wndst
    End 
Function

 
   Private Function NewDate() As String
        NewDate 
0
        Dim dayd 
As Integer
        Dim mond 
As Integer
        Dim yerd 
As Integer
        Dim dayds 
As String
        Dim monds 
As String
        Dim yerds 
As String
        dayd 
DateAndTime.Day(Today)
 
       mond Month(Today)
 
       yerd Year(Today)
 
       dayds LTrim(Str(dayd))
 
       monds LTrim(Str(mond))
 
       yerds LTrim(Str(yerd))
 
       If Len(dayds) = 1 Then dayds "0" dayds
        If Len
(monds) = 1 Then monds "0" monds
        If Len
(yerds) = 2 Then yerds "20" yerds
        NewDate 
dayds "/" monds "/" yerds
    End 
Function 
اللهم لك الحمد كما ينبغي لجلال وجهك و عظيم سلطانك
في حل و ترحال
الرد }}}
تم الشكر بواسطة: Amir_Alzubidy , Ahmed_Mansoor , ahmedabdelaliem


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
  مكتبة اكواد فيجول بيسك | Visual Basic Codes " derbaliammar 2 8,486 21-01-24, 07:10 AM
آخر رد: Whled2020
  تحويل القيمة السالبة إلى موجبة (القيمة المطلقة) صقر الجزيرة 9 7,358 28-11-22, 11:15 PM
آخر رد: salamandal
  تحويل برنامج تم تصميمه بلغة الفيجوال بيسك الى مايكروسوفت اكسيس shabrawy 3 857 07-09-22, 10:05 PM
آخر رد: Taha Okla
  [vb6.0] أريد المساعدة بشأن كود أو برنامج يرسل لـ whatsapp صعب الوصول 10 5,789 21-11-21, 05:43 PM
آخر رد: mona82
  [vb6.0] هاام الى جميع الاخوة في المنتدى ارجو المساعدة husam.aj87 2 1,402 03-03-21, 08:20 PM
آخر رد: Amir_Alzubidy
Wink [vb6.0] كيفيه تحويل الطباعة بي دي اف حامد محمد 6 3,429 18-04-19, 03:29 AM
آخر رد: حامد محمد
  [سؤال] المساعدة في تقريب الارقام عمور2016 5 3,308 30-01-19, 07:44 PM
آخر رد: sendbad100
  تحويل كود سي بلس بلس الى الفيجوال بيسك 6 samira20 2 2,721 08-09-18, 01:09 PM
آخر رد: samira20
  [vb6.0] أرجو المساعدة بتتمة المشروع سمير الجبالي 6 2,851 14-07-18, 11:28 PM
آخر رد: سمير الجبالي
Photo [سؤال] ارجو المساعدة تحويل الارقام في الاكتيف ريبورت حامد محمد 8 3,819 10-05-18, 04:44 AM
آخر رد: حامد محمد

التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم