المشاركات : 576
المواضيع 116
الإنتساب : Feb 2014
السمعة :
28
الشكر: 388
تم شكره 438 مرات في 204 مشاركات
ارجو من الاخوة الكرام ان يساعدوني في تحويل اكواد الفيجول 6 الى الدت نت
وانشاء الله لن اكثر عليكم لانه ليس بالكبير
وشكرا
المشاركات : 204
المواضيع 14
الإنتساب : Jun 2015
السمعة :
10
الشكر: 250
تم شكره 222 مرات في 132 مشاركات
اتمنى وضع الاكواد
الْلَّهُم صَلِّ وَسَلِم وَبَارِك عَلَى سَيِّدِنَا مُحَمَّد
المشاركات : 576
المواضيع 116
الإنتساب : Feb 2014
السمعة :
28
الشكر: 388
تم شكره 438 مرات في 204 مشاركات
(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
المشاركات : 204
المواضيع 14
الإنتساب : Jun 2015
السمعة :
10
الشكر: 250
تم شكره 222 مرات في 132 مشاركات
19-11-16, 01:36 AM
(آخر تعديل لهذه المشاركة : 19-11-16, 01:37 AM {2} بواسطة LoveVb.)
للاسف ليس لي خبره بالفيجوال بيسك 6
انتضر باقي الاعضاء
*ملاحظة : عند استفسارك عن كود ضعه في الموضوع واي شخص يعرف الجواب يجيبك
بالتوفيق
الْلَّهُم صَلِّ وَسَلِم وَبَارِك عَلَى سَيِّدِنَا مُحَمَّد
المشاركات : 576
المواضيع 116
الإنتساب : Feb 2014
السمعة :
28
الشكر: 388
تم شكره 438 مرات في 204 مشاركات
(19-11-16, 01:36 AM)LoveVb كتب : للاسف ليس لي خبره بالفيجوال بيسك 6
انتضر باقي الاعضاء
*ملاحظة : عند استفسارك عن كود ضعه في الموضوع واي شخص يعرف الجواب يجيبك
بالتوفيق
الف تحية وتقدير لك اخي الكريم lovevb
واتمنى من الاخوة الكرام المساعدة
المشاركات : 1,379
المواضيع 83
الإنتساب : Sep 2012
السمعة :
217
الشكر: 10451
تم شكره 17812 مرات في 844 مشاركات
انس الامر برمته
ركب الدوت نت وخذ الفكرة من البرنامج الاول وطبقها على الدوت نت
ستجد صعوبة في البداية ولكن بعد فترة بسيطة ستجد ان تعاملك مع الدوت نت ابسط مليون مرة من الفيجوال 6
النسخ التي تحوي معالجات تحويل هي 205 و 2008
فقط وليس لكل الاكواد
اليوم نحن نرى نسخة 2017
فلا تتعب نفسك بتحويل الاكواد ومحاولة اصلاح اخطاء التحويل
والامر يعود لك
سبحان الله والحمدلله ولا إله إلا الله والله أكبر
اللهم اغْفِرْ لِلمؤمنين والمؤمنات والمسلمين والمسلمات الأحياء منهم والأموات
المشاركات : 576
المواضيع 116
الإنتساب : Feb 2014
السمعة :
28
الشكر: 388
تم شكره 438 مرات في 204 مشاركات
19-11-16, 04:14 AM
(آخر تعديل لهذه المشاركة : 19-11-16, 04:16 AM {2} بواسطة bidaya.)
(19-11-16, 03:09 AM)أبو عمر كتب : انس الامر برمته
ركب الدوت نت وخذ الفكرة من البرنامج الاول وطبقها على الدوت نت
ستجد صعوبة في البداية ولكن بعد فترة بسيطة ستجد ان تعاملك مع الدوت نت ابسط مليون مرة من الفيجوال 6
النسخ التي تحوي معالجات تحويل هي 205 و 2008
فقط وليس لكل الاكواد
اليوم نحن نرى نسخة 2017
فلا تتعب نفسك بتحويل الاكواد ومحاولة اصلاح اخطاء التحويل
والامر يعود لك
شكرا لك اخي ابو عمر على النصيحة القيمة لكن لدى برنامج مفتوح المصدر معمول بالفيجول 6 به خاصية بحثت عن اكوادها وطرحت الاسؤلة في هذا المنتدى الغالي ولم اجدها لذا لجأة الى فكرة التحويل
المشاركات : 662
المواضيع 39
الإنتساب : Feb 2014
السمعة :
195
الشكر: 1474
تم شكره 1740 مرات في 622 مشاركات
اظن اقتراح الاخ ابو عمر افضل لك
و بكل الاحوال هذا تحويل و لا ادري ان كان يعمل معك او حتى اذا كان يعطي النتيجة المطلوبة
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 Integer, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal 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 Integer, ByVal nIndex As Integer, ByVal dwNewLong As Integer) As Integer Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Integer, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Integer, ByVal 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 Integer, ByRef 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 String, ByVal pData As String, ByVal cData As String) As String GetbyetSource = 0 Dim reslt2 As Object, reslt1() As String, reslt() As String, fresult 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(4) Then If AdLinkURL <> "" Then Me.WindowState = FormWindowState.Minimized 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(ByVal Button As Short, ByVal Shift As Short, ByVal x As Single, ByVal 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(ByVal Button As Short, ByVal Shift As Short, ByVal x As Single, ByVal y As Single) Dim Result As Integer Dim msg As Integer If Me_ds.ScaleMode = vbPixels Then msg = x Else msg = x / 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_DELETE, nid) 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_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 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 Short, ByVal Shift As Short, ByVal x As Single, ByVal 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(ByRef Cancel As Short) Dim msgbe As DialogResult, exrq As Boolean, wndst 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.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() 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.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) Application.Exit() End Sub
Private Sub mxz_Click() 'called when the user clicks the popup menu Restore command Shell_NotifyIcon(NIM_DELETE, nid) 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 warning: Caption 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(frefl, AppPath + "config.sys", OpenMode.Binary) FilePut(frefl, stfl) 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
اللهم لك الحمد كما ينبغي لجلال وجهك و عظيم سلطانك
في حل و ترحال
|