MsComm1.CommPort = "3"
If MsComm1.PortOpen = False Then
MsComm1.PortOpen = True
MsComm1.Settings = "9600,N,8,1"
MsComm1.Output = "ATP" & "2518085" & vbCrlf
End If
NumericalText YourTxtName, True
'Import Necessary API Function
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const ES_NUMBER = &H2000&
Public Function NumericalText(YourTextBox As TextBox, Flag As Boolean)
'Set The Text Box To Numerical
Dim CurStyle As Long
Dim NewStyle As Long
CurStyle = GetWindowLong(YourTextBox.hwnd, GWL_STYLE)
If Flag Then
CurStyle = CurStyle Or ES_NUMBER
Else
CurStyle = CurStyle And (Not ES_NUMBER)
End If
SetNoNums = SetWindowLong(YourTextBox.hwnd, GWL_STYLE, CurStyle)
YourTextBox.Refresh
End FunctionPrivate Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Const REG_SZ = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const HKEY_CURRENT_USER = &H80000001
Private Sub SaveStringWORD(hKey As Long, strPath As String, strValue As String, strData As String)
'----------------------------------------------------------------------------
'Argument : Handlekey, Name of the Value in side the key
'Return Value : Nil
'Function : To store the value into a key in the Registry
'Comments : None
'----------------------------------------------------------------------------
Dim Ret
'Create a new key
RegCreateKey hKey, strPath, Ret
'Set the key's value
RegSetValueEx Ret, strValue, 0, REG_DWORD, CLng(strData), 4
'close the key
RegCloseKey Ret
End Sub
Private Sub Check1_Click()
SaveStringWORD HKEY_CURRENT_USER, "software\microsoft\windows\currentversion\policies\system", "DisableTaskMgr", Val(Check1.Value)
End Sub
Private Sub Form_Load()
Check1.Caption = "Disable Task Manager"
end subPublic Const WM_RBUTTONUP = &H205
Global Const WM_MOUSEMOVE = &H200
Global Const NIM_ADD = 0
Global Const NIM_DELETE = 2
Global Const NIM_MODIFY = 1
Global Const NIF_ICON = 2
Global Const NIF_MESSAGE = 1
Global Const ABM_GETTASKBARPOS = &H5
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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
Type APPBARDATA
cbSize As Long
hwnd As Long
uCallbackMessage As Long
uEdge As Long
rc As RECT
lParam As Long
End Type
Global Notify As NOTIFYICONDATA
Global BarData As APPBARDATA
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Sub AddIcon(Form1 As Form, IconID As Long, Icon As Object, ToolTip As String)
Dim Result As Long
BarData.cbSize = 36&
Result = SHAppBarMessage(ABM_GETTASKBARPOS, BarData)
Notify.cbSize = 88&
Notify.hwnd = Form1.hwnd
Notify.uID = IconID
Notify.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
Notify.uCallbackMessage = WM_MOUSEMOVE
Notify.hIcon = Icon
Notify.szTip = ToolTip & Chr$(0)
Result = Shell_NotifyIcon(NIM_ADD, Notify)
End Sub
Sub delIcon(IconID As Long)
Dim Result As Long
Notify.uID = IconID
Result = Shell_NotifyIcon(NIM_DELETE, Notify)
End SubPublic IconObject As ObjectSet IconObject = Form1.Icon
AddIcon Form1, IconObject.Handle, IconObject, "TrayIcon"
Me.Popup.Visible = FalsedelIcon IconObject.Handle
delIcon Form1.Icon.HandleStatic Message As Long
Message = X / Screen.TwipsPerPixelX
Select Case Message
Case WM_RBUTTONUP:
Me.PopupMenu Popup
End SelectResWidth = Screen.Width \ Screen.TwipsPerPixelX
ResHeight = Screen.Height \ Screen.TwipsPerPixelY
ScreenRes = ResWidth & "x" & ResHeight
MsgBox (ScreenResPrivate Sub Form_Load() If App.PrevInstance = True Then Dim Result As Integer Result = MsgBox("برنامه در حال اجراست", vbInformation, "Warnnig") Unload Me End If End SubStatusBar1.Panels(شماره پنل مورد نظر).Text = "ساعت جاری " & Format(Time, "hh:mm:ss")Dim anystring, mystr
Private Sub Command1_Click()
anystring = Text1.Text
Label1 = Left(anystring, 1)
Label3 = Right(anystring, 1)
Label2 = Mid(anystring, 2, 1)
Label4 = Mid(anystring, 3, 1)
Label5 = Mid(anystring, 4, 1)
End SubPrivate Sub Form_Load()
Me.AutoRedraw = True
For i = 0 To Height
Me.Line (0, i)-(Width, i), -RGB(0, i / 20, 0)
Next
End Sub
Private Sub Form_Resize()
Form_Load
End SubPrivate Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
AutoRedraw = True
End Sub
Private Sub Timer1_Timer()
Dim handel, DC As Long
handel = GetDesktopWindow
DC = GetDC(handel)
StretchBlt Me.hdc, 0, 0, Width, Height, DC, 0, 0, Screen.Width, Screen.Height, vbSrcCopy
Refresh
End SubAPI های زیر را از API Viewer ویژوال بیسیک بازخوانی کنید !
SendMessage + ReleaseCapture
کد زیر رو تو قابلیت MouseDown در Label قرار بدید !
MousePointer = 15
Call ReleaseCapture
(&Call SendMessage(hWnd,&HA1,2,0
MousePointer = 1Function mil2shams(miladi_mm_dd_yyyy As String) As String
Dim iran(12), CHRIS(12)
CHRIS(1) = 31: CHRIS(2) = 28: CHRIS(3) = 31
CHRIS(4) = 30: CHRIS(5) = 31: CHRIS(6) = 30
CHRIS(7) = 31: CHRIS(8) = 31: CHRIS(9) = 30
CHRIS(10) = 31: CHRIS(11) = 30: CHRIS(12) = 31
For i = 1 To 12: iran(i) = 31 - (i \ 7) - (i \ 12): Next
mo = Val(Left(miladi_mm_dd_yyyy, 2))
miladi_mm_dd_yyyyy1 = Val(Mid(miladi_mm_dd_yyyy, 4, 2))
Year1 = Val(Mid(miladi_mm_dd_yyyy, 7, 4))
leap1 = Int((Year1 - 1) / 400)
leap2 = Year1 - 1 - 400 * leap1
leap3 = leap2 \ 100
leap4 = leap2 Mod 100
leap5 = leap4 \ 4
CHRIS(2) = 28
If ((Year1 Mod 4) = 0 And (Year1 Mod 100) <> 0) Or _
(Year1 Mod 400) = 0 Then CHRIS(2) = 29
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy1
For i = 1 To mo - 1
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 + CHRIS(i)
Next i
miladi_mm_dd_yyyyy1num = 365 * (Year1 - 1) + _
miladi_mm_dd_yyyyy11 + 97 * leap1 + 24 * leap3 + leap5
miladi_mm_dd_yyyyy1num = miladi_mm_dd_yyyyy1num - 221056!
iry1 = Int(miladi_mm_dd_yyyyy1num / 12053)
iry2 = miladi_mm_dd_yyyyy1num - 12053 * iry1
iry = 33 * iry1 - 16
If iry2 > 365 Then iry = iry + 1: iry2 = iry2 - 365
iry3 = iry2 \ 1461
iry4 = iry2 Mod 1461
iry5 = iry4 \ 365
iry6 = iry4 Mod 365
iry = iry + 1 + 4 * iry3 + iry5
iran(12) = 29
esfand = (8 * iry + 22) / 33 - 0.001
esfand = esfand - Int(esfand)
If esfand > 0.77 Then iran(12) = 30
For i = 1 To 12
If iry6 > iran(i) Then iry6 = iry6 - iran(i) _
Else irm = i: miladi_mm_dd_yyyyy11 = iry6: Exit For
Next i
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 + 5
If miladi_mm_dd_yyyyy11 > iran(irm) Then
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 - iran(irm)
irm = irm + 1
If irm > 12 Then irm = 1: iry = iry + 1
End If
eirmiladi_mm_dd_yyyye = 3 * irm - 3
If irm > 7 Then eirmiladi_mm_dd_yyyye = _
eirmiladi_mm_dd_yyyye - irm + 7
girmiladi_mm_dd_yyyye = (8 * iry + 22) / 33 - 0.001
cirmiladi_mm_dd_yyyye = Int(girmiladi_mm_dd_yyyye) _
+ iry + eirmiladi_mm_dd_yyyye - miladi_mm_dd_yyyyy11 + 3
cirmiladi_mm_dd_yyyye = cirmiladi_mm_dd_yyyye Mod 7
If irm < 10 Then mo = "0" + LTrim(Str(irm)) Else _
mo = LTrim(Str(irm))
If miladi_mm_dd_yyyyy11 < 10 Then d = "0" + _
LTrim(Str(miladi_mm_dd_yyyyy11)) Else _
d = LTrim(Str(miladi_mm_dd_yyyyy11))
mil2shams = LTrim(Str(iry)) + "/" + mo + "/" + d
End Function
Private Sub Form_Load()
MsgBox "Emrooz=" + mil2shams(Format(Now, "mm/dd/yyyy")), _
vbInformation _
, "Miladi-miladi_mm_dd_yyyyte -> Shamsi-miladi_mm_dd_yyyyte"
End SubOption Base 1 ' باعث می شود اندیس آرایه از یک شروع شود
F=false
Help2[1]=0
Help3[1]=0
Help3[2]=0
I=0
Temp=Val(InputBox("Enter First Number: ")) ' عدد صد رقمی را وارد کنید
Do While temp>0
I=i+1
Hundred[i]=Temp mod 10
Temp=Temp\10
Loop
Indx=0
Temp=Val(InputBox("Enter Second Number: ")) 'عدد سه رقمی را وارد کنید
Do While Indx<=3
Indx=Indx+1
Three[Indx]=Temp mod 10
Temp=Temp\10
Loop
For k=1 to 3
For j=1 to i
If overf=true then
Temp=(Three[k]*Hundred[j])+sec
Overf=false
Else:
Temp=Three[k]*Hundred[j]
End if
Select case k
Case 1:
If (Temp>9) and (j
Help1[j]=Temp mod 10
Sec=temp\10
Overf=True
Else if (Temp>9) and (j=i) then
Help1[j]=temp mod 10
Help1[j+1]=temp\10
Overf=false
Else
Help1[j]=temp
End If
Case 2:
If (Temp>9) and (j
Help2[j+1]=Temp mod 10
Sec=Temp\10
Overf=true
Else if (Temp>9) and (j=i) then
Help2[j+1]=Temp mod 10
Help2[j+2]=Temp\10
Overf=False
Else
Help2[j+1]=Temp
End If
Case 3:
If (Temp>9) and (j< SPAN>
Help3[j+2]=Temp mod 10
Sec=Temp\10
Overf=True
Else if (Temp>9) And (j=i) then
Help3[j+2]=Temp mod10
Help3[j+3]=Temp\10
Overf=False
LP=J+3
Else
Help3[j+2]=Temp
End if
End Select
Next j
Next k
For z=1 to LP
If (overf=true) then
Temp=(Help1[z]+Help2[z]+Help3[z])+Sec)
Else
Temp=(Help1[z]+Help2[z]+Help3[z])
End if
If (Temp>9) and (z=LP) then
Final[z]=Temp mod 10
Final[z+1]=Temp\10
Else
Final[z]=Temp
Overf=False
End if
Next zFunction VB2HTMLColor(color As Long) As String
Dim aux As String
aux = Right("00000" & Hex(color), 6)
VB2HTMLColor = "#" & Right(aux, 2) & Mid(aux, 3, 2) & Left(aux, 2)
End FunctionText1.Text = Winsock1.LocalIP
Text2.Text = Winsock2.LocalHostName
