تابع تبدیل عدد BCD به باینری

Private Function BCDToBinary(ByVal lngNum As Long) As String
Dim strResult As String
Dim lngResult1 As Long
Dim strResult2 As String
Dim lngCount As Long

    lngResult1 = lngNum
    lngCount = lngNum

    Do While lngCount > 0
        lngResult1 = lngResult1 Mod 2
        strResult = Trim(strResult) & Trim(Str(lngResult1))
        lngCount = lngCount 2
        lngResult1 = lngCount
    Loop
    For lngCount = Len(strResult) To 1 Step -1
        strResult2 = Trim(strResult2) & Mid(strResult, lngCount, 1)
    Next lngCount
BCDToBinary = Trim(strResult2)
End Function

تابع GotoRecord

Private Function GoToRecord(ByVal rs As ADODB.Recordset, _
                            intRecordNum As Integer) As Recordset
Dim intCount As Integer
    If rs.RecordCount > 0 Then rs.MoveFirst
        For intCount = 1 To intRecordNum - 1
            If Not rs.EOF Then
                rs.MoveNext
            Else
                Exit For
            End If
        Next intCount
Set GoToRecord = rs
End Function

توضیح تابع : این تابع یک Recordset  پر و یک عدد دریافت میکند و در رکورد ست دریافتی رکورد شماره ورودی را فعال میکند .

به عبارت دیگر به رکورد شماره مورد نظر پرش میکند و اگر عدد بزرگتر از تعداد رکورد داخل رکوردست بود آخرین رکورد فعال میشود.

تغییر تنضیمات صفحه نمایش

Const CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H2
Const CDS_FULLSCREEN = &H4
Const CDS_GLOBAL = &H8
Const CDS_SET_PRIMARY = &H10
Const CDS_RESET = &H40000000
Const CDS_SETRECT = &H20000000
Const CDS_NORESET = &H10000000
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const DISP_CHANGE_FAILED = -1
Const DISP_CHANGE_BADMODE = -2
Const DISP_CHANGE_NOTUPDATED = -3
Const DISP_CHANGE_BADFLAGS = -4
Const DISP_CHANGE_BADPARAM = -5

Private Const ENUM_CURRENT_SETTINGS = -1

Private Type DEVMODE
    dmDeviceName As String * 32
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * 32
    dmUnusedPadding As Integer
    dmBitsPerPixel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
    'Windows 95, 98, 2000
    dmICMMethod As Long
    dmICMIntent As Long
    dmMediaType As Long
    dmDitherType As Long
    dmReserved1 As Long
    dmReserved2 As Long
    'Windows 2000
    dmPanningWidth As Long
    dmPanningHeight As Long
End Type
Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, _
    ByVal iModeNum As Long, lpDevMode As DEVMODE) As Long
Private Declare Function ChangeDisplaySettings Lib "user32.dll" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags _
    As Long) As Long

Private Sub Command1_Click()
  Dim dm As DEVMODE
  Dim retval As Long
  dm.dmSize = Len(dm)
  retval = EnumDisplaySettings(vbNullString, ENUM_CURRENT_SETTINGS, dm)
  dm.dmPelsWidth = 800
  dm.dmPelsHeight = 600
  retval = ChangeDisplaySettings(dm, CDS_TEST)
    If retval <> DISP_CHANGE_SUCCESSFUL Then
        Me.Print "Cannot change to that resolution!"
    Else
       retval = ChangeDisplaySettings(dm, CDS_UPDATEREGISTRY)
        Select Case retval
        Case DISP_CHANGE_SUCCESSFUL
            Me.Print "Resolution successfully changed!"
        Case DISP_CHANGE_RESTART
            Me.Print "A reboot is necessary before the changes will take effect."
        Case Else
            Me.Print "Unable to change resolution!"
        End Select
    End If
End Sub

باز و بسته کردن در CD

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Dim lngReturn As Long
Dim strReturn As Long

Private Sub Command1_Click()
lngReturn = mciSendString("set CDAudio door open", strReturn, 127, 0)
End Sub

Private Sub Command2_Click()
lngReturn = mciSendString("set CDAudio door closed", strReturn, 127, 0)
End Sub

ساعت عقربه ای

Private Sub Form_Load()
   Me.BackColor = vbBlack
    Timer1.interval=1000
End Sub
Private Sub Timer1_Timer()

   Form1.Refresh
   X = Form1.Width / 2
   Y = Form1.Height / 2.2
   Circle (X, Y), Y - 200, vbWhite
   Circle (X, Y), Y - 220, vbWhite
   For i = 1 To 12
        Circle (X + (Y - 400) * Cos(i * 22 / 42), Y + (Y - 400) * Sin(i * 22 / 42)), 50, vbRed
   Next
   h = Hour(Time())
   If h > 12 Then
       h = h - 12
   End If
   m = Minute(Time())
   s = Second(Time())
   Line (X, Y)-(X + (Y - 600) * Cos((66 / 14 + s * (44 / 420))), Y + (Y - 600) * Sin((66 / 14 + s * (44 / 420)))), vbBlue
   Line (X, Y)-(X + (Y - 800) * Cos((66 / 14 + m * (44 / 420))), Y + (Y - 800) * Sin((66 / 14 + m * (44 / 420)))), vbYellow
   Line (X, Y)-(X + (Y - 1200) * Cos(66 / 14 + h * (44 / 84) + (m / 12) * (44 / 420)), Y + (Y - 1200) * Sin(66 / 14 + h * (44 / 84) + (m / 12) * (44 / 420))), vbWhite
End Sub

تبدیل فرم به صورت دایره

Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function ReleaseCapture Lib "USER32" () As Long Private Declare Function CreateEllipticRgn Lib "gdi32" _ (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function SetWindowRgn Lib "USER32" _ (ByVal hWnd As Long, ByVal hRgn As Long, _ ByVal bRedraw As Boolean) As Long Private Sub Form_Load() SetWindowRgn hWnd, CreateEllipticRgn(0, 0, 200, 200), True End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) MousePointer = 15 Call ReleaseCapture Call SendMessage(hWnd, &HA1, 2, 0&) MousePointer = 1 End Sub

ساخت یک ShortCut برای Lock کردن کامپیوتر

برای انجام این کار بر روی صفحه نمایش خود Right-Click کنید و از Shortcut گزینه ی New را انتخاب کنید.
سپس در پنجرهای که ظاهر می شود در قسمت Type the location of the item فرمان زیر را کپی کنید :


rundll32.exe user32.dll,LockWorkStation

نام و آیکو ن را برای ShortCut انتخاب کرده دکمه Finish را بزنید.

Provider SQL Server

 _ &  ";CnnStr = "Provider=SQLOLEDB.1 
         _ & ";Persist Security Info=True"
          _  & ";User ID=UserName"
            _ & ";PassWord=PassWord"
           _ & ";Initial Catalog=DataBase Name"
            "Data Source=Server Name"

تابع محاسبه دترمینال N x N در Visual Basic

Function determinant(Matrix() As Single, Norder As Integer, deter As SingleDim k, k1, i, j) As Integer
Dim save As Single
Dim check As Boolean
deter = 1
For k = 1 To Norder
 If Matrix(k, k) = 0 Then
  j = k
  Do
   check = True
   If Matrix(k, j) = 0 Then
    If j = Norder Then
     deter = 0
     Exit Function
    End If
    check = False
    j = j + 1
   End If
   If Matrix(k, j) <> 0 Then
    For i = k To Norder
    ( save = Matrix(i, j
   (  Matrix(i, j) = Matrix(i, k
     Matrix(i, k) = save
    Next i
    deter = -deter
   End If
  Loop While check = False
 End If
( deter = deter * Matrix(k, k
 If k - Norder < 0 Then
  k1 = k + 1
  For i = k1 To Norder
   For j = k1 To Norder
((    Matrix(i, j) = Matrix(i, j) - (Matrix(i, k) * Matrix(k, j) / Matrix(k, k 
   Next j
  Next i
 End If
Next k
End Function

ایجاد تاخیر در هر جای برنامه:

خط زیر را در قسمت General بنویسید

(Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long

از این به بعد در هر روال با نوشتن فرمان Sleep و وارد کردن مقدار تاخیر با واحد میلی ثانیه تاخیر مورد نظر ایجاد میشود.

مثال:

Sleep 2000

۲ ثانیه تاخیر