Forum for Helpful Visual Basic 6.0 Codes... Part 3

All replies

• 

  

  0

  Sign in to vote

  
  

  Code 160 : This function rounds up and down in any step that you choose

  Function doRound(Value As Double, RStep As Double, Mode As String) As Double
      ' ***********************
      ' Mode    Process
      ' ----    -------
      '  UP     RoundUp
      '  DN     RoundDN
      ' ***********************
      Select Case UCase(Mode)
          Case "DN"
              doRound = (Int(Value / RStep) * RStep)
  
          Case "UP"
              If Value Mod RStep > 0 Then
                  doRound = ((Int(Value / RStep) * RStep) + RStep)
              Else
                  doRound = Value
              End If '»If Value Mod RStep > 0 Then
              
      End Select '»Select Case UCase(Mode)
  End Function
  
  

  Sunday, May 27, 2007 7:39 AM
• 

  

  0

  Sign in to vote

  
  

  Code 161 : Create random numbers when a button is pushed and display those numbers in a text box

  Private Sub Command1_Click()
  Randomize
     Dim 1 As Integer
     1 = Int(Rnd(1) * 9) ' create random numbers between 1 and 9
     Text1.Text = CStr(t1) ' display random number in text box
  End Sub
  'If you want to put different numbers in multiple text boxes
  'use the sample code below
  Private Sub Command1_Click()
  Randomize
     Dim t1 As Integer
     t1 = Int(Rnd(1) * 9)
     Text2.Text = CStr(t1)
     Dim t2 As Integer
     t2 = Int(Rnd(1) * 9)
     Text3.Text = CStr(t2)
     Dim t3 As Integer
     t3 = Int(Rnd(1) * 9)
     Text4.Text = CStr(t3)
     Dim t5 As Integer
     t5 = Int(Rnd(1) * 9)
     Text5.Text = CStr(t5)
     Dim t6 As Integer
     t6 = Int(Rnd(1) * 9)
     Text6.Text = CStr(t6)
     Dim t7 As Integer
     t7 = Int(Rnd(1) * 9)
     Text7.Text = CStr(t7)
  'If you want all these numbers to appear in another text box use
  'this code
  Text8.Text = (Text1.Text) & (Text2.Text) & (Text3.Text) & (Text4.Text) & (Text5.Text) & (Text6.Text) & (Text7.Text)
  End Sub

  Sunday, May 27, 2007 7:41 AM
• 

  

  0

  Sign in to vote

  Code 162 : Add bitmap images to a menu item
  
  Declarations
  

  Add the following code to the declarations section of a module:
  Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
  
  Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
  
  Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
  
  Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
  
  Public Const MF_BITMAP = &H4&
  
  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
  
  Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
  
  Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Boolean
  
  Public Const MIIM_ID = &H2
  Public Const MIIM_TYPE = &H10
  Public Const MFT_STRING = &H0&     
  

  
  
  

  Code 162 : Add bitmap images to a menu item
  
  
  

  'To start things off right, just add a form to a project (or just start a new project). Add a picturebox control. Set 'Autosize' to 'True' with a bitmap (not an Icon) at a maximum of 13X13. Add a comandbutton with the following code:
  Private Sub Command1_Click()
  'Get the menuhandle of your app
  hMenu& = GetMenu(Form1.hwnd)
  
  'Get the handle of the first submenu (Hello)
  hSubMenu& = GetSubMenu(hMenu&, 0)
  
  'Get the menuId of the first entry (Bitmap)
  hID& = GetMenuItemID(hSubMenu&, 0)
  
  'Add the bitmap
  SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture1.Picture
  
  'You can add two bitmaps to a menuentry one for the checked and one for the unchecked state.
  End Sub   
  

  
  
  

  Sunday, May 27, 2007 7:47 AM
• 

  

  0

  Sign in to vote

  
  

  Code 163 : Function to draw an etched (3-D) looking line on a form

  Sub EtchedLine(frmEtch As Form, ByVal intX1 As Integer, ByVal intY1 As Integer, ByVal intLength As Integer)
      Const lWHITE& = vb3DHighlight
      Const lGRAY& = vb3DShadow
  
      frmEtch.Line (intX1, intY1)-(intX1 + intLength, intY1), lGRAY
      frmEtch.Line (frmEtch.CurrentX + 5, intY1 + 20)-(intX1 - 5, intY1 + 20), lWHITE
  End Sub

  Sunday, May 27, 2007 7:48 AM
• 

  

  0

  Sign in to vote

  Code 164 : Routines for fading a picture in different ways
  
  Declarations
  

  Public Const FADE_T_TO_B = 0
  Public Const FADE_B_TO_T = 1
  Public Const FADE_L_TO_R = 2
  Public Const FADE_R_TO_L = 3
  Public Const FADE_RANDOM = 4
  Public Const FADE_OUTWARD = 5
  
  Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

  
  
  

  Code 164 : Routines for fading a picture in different ways
  
  Code
  

  Sub Fade(Pic As PictureBox, Style As Integer, Blocks As Integer)
      
      Dim width_section_size As Integer
      Dim height_section_size As Integer
      Dim i As Integer, j As Integer
      Dim save_color As Long
      
      'Saves the picbox's current forecolor
      save_color = Pic.ForeColor
  
      'Set Pics forecolor to its backcolor
      Pic.ForeColor = Pic.BackColor
  
      'Corrects the Blocks if needed
      If Blocks < 5 Then Blocks = 5
      If Blocks > 100 Then Blocks = 100
  
      'Sets the size of each width section
      width_section_size = Pic.ScaleWidth / Blocks
  
      'Sets the size of each height section
      height_section_size = Pic.ScaleHeight / Blocks
  
  
      Select Case Style
         '-------------------------------------------------------------------------------------
         Case 0  'Fading top to bottom
            
            For i = 0 To Blocks
               For j = 0 To Blocks
                  Pic.Line ((j * width_section_size), (i * height_section_size))-((j + 1) * width_section_size, (i + 1) * height_section_size), , BF
                  DoEvents
               Next
               DoEvents
            Next
         '-------------------------------------------------------------------------------------
         Case 1  'Fading bottom to top
            
            For i = Blocks To 0 Step -1
               For j = 0 To Blocks
                  Pic.Line (((j - 1) * width_section_size), ((i - 1) * height_section_size))-(j * width_section_size, i * height_section_size), , BF
                  DoEvents
               Next
               DoEvents
            Next
         '-------------------------------------------------------------------------------------
         Case 2  'Fading left to right
            
            For i = 0 To Blocks
               For j = 0 To Blocks
                  Pic.Line ((i * width_section_size), (j * height_section_size))-((i + 1) * width_section_size, (j + 1) * height_section_size), , BF
                  DoEvents
               Next
               DoEvents
            Next
         '-------------------------------------------------------------------------------------
         Case 3  'Fading right to left
            
            For i = Blocks To 0 Step -1
               For j = 0 To Blocks
                  Pic.Line (((i - 1) * width_section_size), (j * height_section_size))-(i * width_section_size, (j + 1) * height_section_size), , BF
                  DoEvents
               Next
               DoEvents
            Next
         '-------------------------------------------------------------------------------------
         Case 4  'Fading Random
         
            Dim bit_array() As Byte
            ReDim bit_array(Blocks, Blocks)
                
            Dim counter As Integer
         
            Do
               Do
                  width_next_block = Int(Blocks * Rnd) 'Generate the random numbers
                  height_next_block = Int(Blocks * Rnd) 'Generate the random numbers
                  'MsgBox bit_array(width_next_block, height_next_block)
                  If bit_array(width_next_block, height_next_block) = 0 Then
                    Exit Do
                  End If
                  counter = counter + 1
                  If counter = Blocks * 10 Then Exit Do
               Loop
               
               If counter = Blocks * 10 Then Exit Do
               counter = 0
            
               'Update the bit_array
               bit_array(width_next_block, height_next_block) = 1
            
      
                
               Pic.Line ((width_next_block * width_section_size), (height_next_block * height_section_size))-((width_next_block + 1) * width_section_size, (height_next_block + 1) * height_section_size), , BF
            
               DoEvents
            Loop
            
            Pic.Line (0, 0)-(Pic.ScaleWidth, Pic.ScaleHeight), , BF
   
         '-------------------------------------------------------------------------------------
         Case 5 'Fading Outward
         
            For i = (Blocks / 2) To 0 Step -1
               Sleep (20)
               Pic.Line (i * width_section_size, i * height_section_size)-(((Blocks - i) + 1) * width_section_size, ((Blocks - i) + 1) * height_section_size), , BF
            Next
            
         '-------------------------------------------------------------------------------------
      End Select
  
      'Restores the picbox's original forecolor        
      Pic.ForeColor = save_color
          
  End Sub

  
  
  

  Sunday, May 27, 2007 7:52 AM
• 

  

  0

  Sign in to vote

  
  

  Code 165 : Convert an RGB value to a long, or a long to RGB

  'Convert RGB to LONG:
   LONG = B * 65536 + G * 256 + R
  
  'Convert LONG to RGB:
   B = LONG \ 65536
   G = (LONG - B * 65536) \ 256
   R = LONG - B * 65536 - G * 256

  Sunday, May 27, 2007 7:54 AM
• 

  

  0

  Sign in to vote

  Code 166 : Demonstrates three graphics manipulation routines. Flip, Rotate, Mirror
  
  Declarations
  

  Const SRCCOPY = &HCC0020
  Const Pi = 3.14159265359
  Private Declare Function SetPixel Lib "GDI32" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal crColor As Long) As Long
  Private Declare Function GetPixel Lib "GDI32" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long
  Private Declare Function StretchBlt% Lib "GDI32" (ByVal hDC%, ByVal X%, ByVal Y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal nSrcWidth%, ByVal nSrcHeight%, ByVal dwRop&)
  
  

  
  
  

  Code 166 : Demonstrates three graphics manipulation routines. Flip, Rotate, Mirror
  
  Code
  

  '  add three command buttons and two pictureboxes. Load a bitmap into picture1 in design
  '  mode. Set both box to the same size. Routines execute 3 times faster than routines
  '  found in Microsoft's Knowledge Base.
  
  
  'Sub Form_Load ()
  Picture1.ScaleMode = 3
  Picture2.ScaleMode = 3
  'End Sub
  
  'Sub Command1_Click ()
  'flip horizontal
  picture2.Cls
  px% = picture1.ScaleWidth
  py% = picture1.ScaleHeight
  retval% = StretchBlt(picture2.hDC, px%, 0, -px%, py%, picture1.hDC, 0, 0, px%, py%, SRCCOPY)
  'End Su
  
  'Sub Command2_Click ()
                  'flip vertical
                  picture2.Cls
                  px% = picture1.ScaleWidth
                  py% = picture1.ScaleHeight
                  retval% = StretchBlt(picture2.hDC, 0, py%, px%, -py%, picture1.hDC, 0, 0, px%, py%, SRCCOPY)
                 'End Sub
  
                 'Sub Command3_Click ()
                  'rotate 45 degrees
                  picture2.Cls
                  Call bmp_rotate(picture1, picture2, 3.14 / 4)
                 'End Sub
  
  
  'Sub bmp_rotate (pic1 As PictureBox, pic2 As PictureBox, ByVal theta!)
    ' bmp_rotate(pic1, pic2, theta)
    ' Rotate the image in a picture box.
    '   pic1 is the picture box with the bitmap to rotate
    '   pic2 is the picture box to receive the rotated bitmap
    '   theta is the angle of rotation
    Dim c1x As Integer, c1y As Integer
    Dim c2x As Integer, c2y As Integer
    Dim a As Single
    Dim p1x As Integer, p1y As Integer
    Dim p2x As Integer, p2y As Integer
    Dim n As Integer, r   As Integer
  
    c1x = pic1.ScaleWidth \ 2
    c1y = pic1.ScaleHeight \ 2
    c2x = pic2.ScaleWidth \ 2
    c2y = pic2.ScaleHeight \ 2
    If c2x < c2y Then n = c2y Else n = c2x
    n = n - 1
    pic1hDC% = pic1.hDC
    pic2hDC% = pic2.hDC
  
          For p2x = 0 To n
              For p2y = 0 To n
            If p2x = 0 Then a = Pi / 2 Else a = Atn(p2y / p2x)
            r = Sqr(1& * p2x * p2x + 1& * p2y * p2y)
          p1x = r * Cos(a + theta!)
          p1y = r * Sin(a + theta!)
          c0& = GetPixel(pic1hDC%, c1x + p1x, c1y + p1y)
          c1& = GetPixel(pic1hDC%, c1x - p1x, c1y - p1y)
          c2& = GetPixel(pic1hDC%, c1x + p1y, c1y - p1x)
          c3& = GetPixel(pic1hDC%, c1x - p1y, c1y + p1x)
          If c0& <> -1 Then xret& = SetPixel(pic2hDC%, c2x + p2x, c2y + p2y, c0&)
          If c1& <> -1 Then xret& = SetPixel(pic2hDC%, c2x - p2x, c2y - p2y, c1&)
          If c2& <> -1 Then xret& = SetPixel(pic2hDC%, c2x + p2y, c2y - p2x, c2&)
          If c3& <> -1 Then xret& = SetPixel(pic2hDC%, c2x - p2y, c2y + p2x, c3&)
        Next
      t% = DoEvents()
     Next
  'End Sub

  
  
  

  Monday, May 28, 2007 7:10 PM
• 

  

  0

  Sign in to vote

  Code 167 : Smoothly scrolls either text, graphics or controls across a form
  
  Declarations
  

  Public Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
  
  Dim thetop As Long
  Dim p1hgt  As Long
  Dim p1wid  As Long
  Dim theleft As Long
  
  

  
  
  

  Code 167 : Smoothly scrolls either text, graphics or controls across a form
  
  Code
  

  Sub centerIT (C As Control, Txt As String)
  C.CurrentX = (C.ScaleWidth - C.TextWidth(Txt)) / 2
  C.Print Txt
  End Sub
  
  'Sub Form_Load ()
  p1.autoredraw = true
  p1.visible = false
  p1.FontSize = 12
  p1.ForeColor = &HFF0000
  p1.BackColor = BackColor
  p1.ScaleMode = 3
  centerIT p1, "Sanket Shah"
  centerIT p1, "Student Rockstar"
  
  ScaleMode = 3
  theleft = (ScaleWidth - p1.TextWidth("Scroll Test...")) / 2
  thetop = ScaleHeight
  p1hgt = p1.ScaleHeight
  p1wid = p1.ScaleWidth
  timer1.Enabled = True
  timer1.Interval = 10
  'End Sub
  
  
  'Sub Timer1_Timer ()
        X% = BitBlt(hDC, theleft, thetop, p1wid, p1hgt, p1.hDC, 0, 0, &HCC0020)
        thetop = thetop - 1
        If thetop < -p1hgt Then
        Timer1.Enabled = False
        Txt$ = "Finished With Scrolling"
        CurrentY = ScaleHeight / 2
        CurrentX = (ScaleWidth - TextWidth(Txt$)) / 2
        Print Txt$
     End If
  'End Sub

  
  
  

  Monday, May 28, 2007 7:12 PM
• 

  

  0

  Sign in to vote

  Code 168 : Create / Delete DSN
  
  Declarations
  

  
  Option Explicit
  
  'Declarations Used to Generate DSN
  Private Const ODBC_ADD_DSN = 1         ' Add data source
  Private Const ODBC_CONFIG_DSN = 2      ' Configure (edit) data source
  Private Const ODBC_REMOVE_DSN = 3      ' Remove data source
  Private Const vbAPINull As Long = 0&   ' NULL Pointer
  
  Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
  
  

  
  
  

  Code 168 : Create / Delete DSN
  
  Code
  

  Public Sub CreateDSN(sDSN As String)
  
     Dim nRet                As Long
     Dim sDriver             As String
     Dim sAttributes         As String
  
     sDriver = "Oracle73 Ver 2.5"
     sAttributes = "Server=pressdb.world" & Chr$(0)
     sAttributes = sAttributes & "DESCRIPTION=" & sDSN & Chr$(0)
     sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0)
     sAttributes = sAttributes & "DATABASE=DB" & Chr$(0)
     sAttributes = sAttributes & "UID=Waty" & Chr$(0)
     sAttributes = sAttributes & "PWD=myPassword" & Chr$(0)
  
     DBEngine.RegisterDatabase "sanket", "Oracle73 Ver 2.5", True, sAttributes
  
     'nRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, sDriver, sAttributes)
  
  End Sub
  
  Public Sub DeleteDSN(sDSN As String)
     Dim nRet                As Long
     Dim sDriver             As String
     Dim sAttributes         As String
  
     sDriver = "Oracle73 Ver 2.5"
     sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0)
  
     nRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, sDriver, sAttributes)
  
  End Sub
  
  

  
  
  

  Monday, May 28, 2007 7:16 PM
• 

  

  0

  Sign in to vote

  
  

  Code 169 : Export a Grid to a text file

  Public Sub GridExport(GridToExport _
              As Object, FileName As String, Optional _
              Delimiter As Variant, Optional _
              EncloseStrings As Variant)
      Dim iNumRows As Integer
      Dim iNumCols As Integer
      Dim iFileNumber As Integer
   
      If IsMissing(Delimiter) Then
          Delimiter = vbTab
      End If
      If IsMissing(EncloseStrings) Then
          EncloseStirngs = ""
      End If
      iFileNumber = FreeFile
      Open FileName For Output As #iFileNumber
      For iNumRows = 0 To _
                  GridToExport.rows - 1
          GridToExport.Row = iNumRows
          For iNumCols = 0 To _
                      GridToExport.Cols - 1
              GridToExport.col = iNumCols
              'if it isn't the first column,
              'put a delimiter before the value
              If iNumCols > 0 Then
                  Print #iFileNumber, Delimiter;
              End If
              Print #iFileNumber, EncloseStrings & _
                      GridToExport.Text & EncloseStrings;
          Next iNumCols
          Print #iFileNumber, ""
      Next iNumRows
      Close #iFileNmuber
  End Sub
   
  Private Sub cmdExport_Click()
      Call GridExport(MSFlexGrid1, "c:/test.csv", ",", Chr$(34))
  End Sub
   
  Private Sub Form_Load()
      MSFlexGrid1.AddItem "Sanket Shah"
      MSFlexGrid1.AddItem "Student Rockstar"
  End Sub
  
  

  Monday, May 28, 2007 7:18 PM
• 

  

  0

  Sign in to vote

  
  

  Code 170 : Prints a MSChart

  'Add the following code To the Click event of Command1  
  
  MSChart1.EditCopy
  Printer.Print " "
  Printer.PaintPicture Clipboard.GetData(), 0, 0
  Printer.EndDoc
  
  

  Monday, May 28, 2007 7:22 PM
• 

  

  0

  Sign in to vote

  Code 171 : Brings up different sized bubbles and does other misc. things
  
  Declarations
  

  Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
  Public Declare Function GetDesktopWindow Lib "user32" () As Long
  Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  Public Const SWP_NOSIZE = &H1
  Public Const SWP_NOMOVE = &H2
  Public Const HWND_TOPMOST = -1
  Public Const HWND_NOTOPMOST = -2
  Public Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
  
  

  
  
  

  Code 171 : Brings up different sized bubbles and does other misc. things
  
  Code
  

  Private Sub Form_Click()
          FillColor = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
          FillStyle = 0
          Circle (Int(Rnd * 11970), Int(Rnd * 8985)), Int(Rnd * 255)
          DoEvents
  End Sub
  
  Private Sub Form_DblClick()
      End
  End Sub
  
  Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
          Do
          FillColor = RGB(Int(0), Int(0), Int(0))
          FillStyle = 0
          Circle (Int(Rnd * 11970), Int(Rnd * 8985)), Int(Rnd * 255)
          DoEvents
          Loop
  End Sub
  
  Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
          Do
          FillColor = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
          FillStyle = 0
          Circle (Int(Rnd * 11970), Int(Rnd * 8985)), Int(Rnd * 255)
          DoEvents
          Loop
  End Sub
  
  Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
      Do While True
  '        SetWindowPos Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
  '        SetPixel Form1.hdc, Int(Rnd * 800), Int(Rnd * 600), RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
          FillColor = RGB(Int(255), Int(255), Int(255))
          FillStyle = 0
          Circle (Int(Rnd * 11970), Int(Rnd * 8985)), Int(Rnd * 255)
             DoEvents
      Loop
  End Sub
  
  

  
  
  

  Monday, May 28, 2007 7:27 PM
• 

  

  0

  Sign in to vote

  Man you are great. You have really contributed a lot . Hope many others also benefit from this. I have befitted a lot.
  

  Tuesday, May 29, 2007 2:06 PM
• 

  

  0

  Sign in to vote

  
  

  Code 172 : Makes the program "halt" for a set time, excelent for use in animations
  

  Sub Delay(milliseconds)
  secs = milliseconds*1000
  G= TIMER
  Do while timer-G < secs:LOOP
  End Sub

  Thursday, June 14, 2007 12:49 PM
• 

  

  0

  Sign in to vote

  Code 173 : Create a dynamically scrolling graph in Visual Basic
  
  Declarations
  

  Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
  Private Const PS_SOLID = 0
  
  Private Declare Function CreateCompatibleDC Lib "gdi32" _
                 (ByVal hdc As Long) As Long
  
  Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
                 (ByVal hdc As Long, _
                 ByVal nWidth As Long, _
                 ByVal nHeight As Long) As Long
  
  Private Declare Function SelectObject Lib "gdi32" _
                 (ByVal hdc As Long, _
                 ByVal hObject As Long) As Long
  
  Private Declare Function CreatePen Lib "gdi32" _
                 (ByVal nPenStyle As Long, _
                 ByVal nWidth As Long, _
                 ByVal crColor As Long) As Long
  
  Private Declare Function LineTo Lib "gdi32" _
                 (ByVal hdc As Long, _
                 ByVal x As Long, _
                 ByVal y As Long) As Long
  
  Private Declare Function MoveToEx Lib "gdi32" _
                 (ByVal hdc As Long, _
                 ByVal x As Long, _
                 ByVal y As Long, _
                 ByVal lpPoint As Long) As Long
  
  Private Declare Function BitBlt Lib "gdi32" _
                 (ByVal hDestDC 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 dwRop As Long) As Long
  
  Private Const pWidth = 250    ' Width of picture box in pixels.
  Private Const pHeight = 150   ' Height of picture box in pixels.
  Private Const pGrid = 25      ' Distance between grid lines.
  Private Const tInterval = 100 ' Interval between timer samplings
                                ' in milliseconds.
  Private Const pHeightHalf = pHeight \ 2
  Dim counter As Long  ' Number of data points logged so far. Used to
                       ' sync grid.
  Dim oldY As Long     ' Contains the previous y coordinate.
  Dim hDCh As Long, hPenB As Long, hPenC As Long

  
  
  

  Code 173 : Create a dynamically scrolling graph in Visual Basic
  
  Code
  

  1) Start a new Standard EXE project in Visual Basic. Form1 is created by default.
  2) Add a Timer and a PictureBox control to Form1.
  3) Copy the following code to the Code window of Form1:
  
  Private Sub Form_Load()
      Dim hBmp As Long
      Dim i As Integer
      Me.Show
      Picture1.ScaleMode = 3
      Picture1.Left = 0
      Picture1.Top = 0
      Form1.ScaleMode = 3
      Picture1.Height = 155
      Picture1.Width = 255
      counter = 0
      hDCh = CreateCompatibleDC(Picture1.hdc)
      hBmp = CreateCompatibleBitmap(Picture1.hdc, _
                                   pWidth, _
                                   pHeight)
      Call SelectObject(hDCh, hBmp)
      hPenB = CreatePen(PS_SOLID, 0, vbBlack)
      hPenC = CreatePen(PS_SOLID, 0, vbRed)
      Call SelectObject(hDCh, hPenB)
  
  ' Plot horizontal grid lines.
      For i = pGrid To pHeight - 1 Step pGrid
          Picture1.Line (0, i)-(pWidth, i)
      Next
  
  ' Plot vertical grid lines.
      For i = pGrid - (counter Mod pGrid) To _
                       pWidth - 1 Step pGrid
          Picture1.Line (i, 0)-(i, pHeight)
      Next
  
      Call BitBlt(hDCh, _
                 0, _
                 0, _
                 pWidth, _
                 pHeight, _
                 Picture1.hdc, _
                 0, _
                 0, _
                 SRCCOPY)
      Timer1.Interval = 100
      Timer1.Enabled = True
      oldY = pHeightHalf
  End Sub
  
  Private Sub Timer1_Timer()
      Dim i As Integer
      Call BitBlt(hDCh, _
                    0, _
                    0, _
                    pWidth - 1, _
                    pHeight, _
                    hDCh, _
                    1, _
                    0, _
                    SRCCOPY)
  
      If counter Mod pGrid = 0 Then
          Call MoveToEx(hDCh, pWidth - 2, 0, 0)
          Call LineTo(hDCh, pWidth - 2, pHeight)
      End If
  
      i = Sin(0.1 * counter) * _
           (pHeightHalf - 1) + _
           pHeightHalf
  
      Call SelectObject(hDCh, hPenC)
      Call MoveToEx(hDCh, pWidth - 3, oldY, 0)
      Call LineTo(hDCh, pWidth - 2, i)
      Call SelectObject(hDCh, hPenB)
      Call BitBlt(Picture1.hdc, _
                    0, _
                    0, _
                    pWidth, _
                    pHeight, _
                    hDCh, _
                    0, _
                    0, _
                    SRCCOPY)
      counter = counter + 1
      oldY = i
  End Sub
   
  
  

  
  
  

  Thursday, June 14, 2007 12:52 PM
• 

  

  0

  Sign in to vote

  
  

  Code 174 : Make 3d Text With Some Lines of code !! Very COol !

  Private Sub Command1_Click()
  ' Add It To a ButtoN !
  ForeColor = 0: x = CurrentX: y = CurrentY
  For i = 1 To 100
          Print "YOUR TEXT HERE" ' Text Here
          x = x + 1: y = y + 1: CurrentX = x: CurrentY = y
  Next
  ForeColor = &HFFFF& 'Change Color Here
  Print "YOUR TEXT HERE" ' Text Goes Here
  End Sub
  
  

  Thursday, June 14, 2007 12:53 PM
• 

  

  0

  Sign in to vote

  
  

  Code 175 : Slide a form to the left and slide down to the taskbar

  '1.  Put this in the declarations section of your form or module
  Sub Slide_Window(frmSlide As Form, iSpeed As Integer)
  
  While frmSlide.Left + frmSlide.Width < Screen.Width
      DoEvents
      frmSlide.Left = frmSlide.Left + iSpeed
  Wend
  
  While frmSlide.Top - frmSlide.Height < Screen.Height
      DoEvents
      frmSlide.Top = frmSlide.Top + iSpeed
  Wend
      
  frmSlide.Hide
  
  End Sub
  
  '2. Call the Slide procedure from the click event of a text box and pass it 2 'paramaters
  'a. The form name - in this case form1.
  'b. The speed - I use 250 the higher the faster
  
  Call Slide_Window (form1, 250)

  Thursday, June 14, 2007 12:54 PM
• 

  

  0

  Sign in to vote

  
  

  Code 176 : Picture load in effect - "Mercury Rising"

  
  Option Explicit   
  
  Private Sub CmdMercury_Click()
      Const TubeWidth = 80
      Dim XTube As Long, Offset As Long, XPicture As Long, Erg As Double
          
      Erg = 3.14159265358979 / 2 * (TubeWidth / 2)
      For Offset = 0 To Picture1.ScaleWidth - 1
          If Offset - TubeWidth >= 0 Then Picture2.PaintPicture Picture1.Picture, Offset - TubeWidth, 0, 1, Picture1.ScaleHeight, Offset - TubeWidth, 0, 1, Picture1.ScaleHeight
          For XTube = 1 To TubeWidth
              XPicture = Mercury(XTube * (TubeWidth * 2)) * Erg
              If Offset + XPicture < Picture1.ScaleWidth Then
                  Picture2.PaintPicture Picture1.Picture, Offset - XTube + TubeWidth, 0, 1, Picture1.ScaleHeight, Offset - XPicture, 0, 1, Picture1.ScaleHeight
              Else
                  Picture2.PaintPicture Picture1.Picture, Offset - XTube + TubeWidth, 0, 1, Picture1.ScaleHeight, Offset - XTube + TubeWidth, 0, 1, Picture1.ScaleHeight
              End If
          Next XTube
      Next Offset
  
  End Sub
  
  Private Sub Form_Load()
      Picture2.Width = Picture1.Width
      Picture2.Height = Picture1.Height
  End Sub
  
  Private Function Mercury(X As Double)
      X = X - 1
      If X < 1 And X > -1 Then
          Mercury = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
      Else
          Mercury = 0
      End If
  End Function
     
  

  Thursday, June 14, 2007 12:56 PM
• 

  

  0

  Sign in to vote

  
  

  Code 177 : Convert an 8-bit BMP (Windows Bitmap) to an 8-bit RAW (raw pixel data)

  This is VERY simple code that simply shaves the top 1078 characters (pallette info) off of an 8-bit, greyscale BMP and saves the resulting data to a file as basic pixel data.  Note that the resulting image can be loaded in applications as a RAW image file.  The image saved by this function will appear 'upside-down' when viewed, and requires being flipped for upright viewing.
  
  Function BMPtoRAW(fullbmptxt As String, outfilename As String) As Boolean
       'This function shaves off the first 1078 characters of the
       'bitmap file, then saves the resulting data into a raw file
       'off the specified name
       On Error Goto err_BMPtoRAW
       Dim wrkstr As String
            wrkstr = Mid$(fullbmptxt,1079)
            Open outfilename For Output As #1
                 Print #1, wrkstr
            Close #1
            BMPtoRAW=True
       end_BMPtoRAW:
            Exit Function
       err_BMPtoRAW:
            BMPtoRAW=False
  End Function
  
            
  
  

  
  

  Thursday, June 14, 2007 12:58 PM
• 

  

  0

  Sign in to vote

  
  

  Code 178 : Extract the Red, Green, and Blue color values from a Long color ID

  Public Enum RGBColor
      gcRed = 1
      gcBlue = 2
      gcGreen = 3
  End Enum

  
  

  Code 178 : Extract the Red, Green, and Blue color values from a Long color ID

  Public Function GetRGBColor(ByVal Color As String, ColorPart As RGBColor) As Long
      Dim strColor As String
      Select Case ColorPart
          Case gcRed
              strColor = Right$("000000" & Hex$(Color), 6)
              GetRGBColor = Val("&h" & Right$(strColor, 2))
          Case gcBlue
              strColor = Right$("000000" & Hex$(Color), 6)
              GetRGBColor = Val("&h" & Left$(strColor, 2))
          Case gcGreen
              strColor = Right$("000000" & Hex$(Color), 6)
              GetRGBColor = Val("&h" & Mid$(strColor, 3, 2))
      End Select
  End Function

  Thursday, June 14, 2007 12:59 PM
• 

  

  0

  Sign in to vote

  
  

  Code 179 : Unload a form in a very Fancy way, it collapses the form and then streches it over the screen

  
  Private Sub Form_Unload(Cancel as Integer)
    Dim counter as Integer
    Dim I as Integer
    counter = me.Height
  'Collapse Form
    Do: DoEvents
      counter = counter - 10
      me.Height = counter
      me.Top = (screen.Height - me.Height) / 2
    Loop Until counter <= 10
    I = 15
    counter = me.Width
  'Strech form to edges
    Do: DoEvents
      counter = counter + I
      me.Width = counter
      me.Left = (screen.Width - me.Width) / 2
      I = I + 1
    Loop Until counter >= screen.Width
  End
  End Sub
  

  Thursday, June 14, 2007 1:01 PM
• 

  

  0

  Sign in to vote

  
  

  Code 180 : Flash a gradient 3D Text on a form

  'Code:
      Private Sub Timer1_Timer()
      Dim Tm As Double
      Dim strText As String
      Dim Ctr As Integer
  'Set Font Size & Style & Form Color
      With Form1
          .BackColor = RGB(0, 255, 0)
          .FontName = "Arial Black"
          .FontSize = 24
          .FontBold = True
          '.FontItalic = True
          .FontUnderline = True
      End With
  'Set the text to be printed on the form
          strText = "3 D TEXT"
          x = CurrentX
          y = CurrentY
          x = 1500 'Set the position of the_
          y = 1300 'text here x = ? ,y = ?
      For Ctr = 0 To 255
          ForeColor = RGB(Ctr, 0, 0) ' Change gradient color with the_
          x = x + 1          ' RGB()function
          y = y + 1
          CurrentX = x
          CurrentY = y
      Print strText
      Next Ctr
          ForeColor = RGB(0, 0, 0) 'Change text color here
          CurrentX = x: CurrentY = y
      Print strText
      For Tm = 1 To 70000  ' Adjust the time that the text _
                           'stays displayed
      DoEvents
      Next Tm
  
          Form1.Cls
      End Sub
  
  
  

  Thursday, June 14, 2007 1:03 PM
• 

  

  0

  Sign in to vote

  
  

  Code 181 : This code will give a great effect to any control making the user interface much more professional

  Option Explicit
  
  Private Sub Command1_Click()
  'Create a shadow to the right and below of Text1 (TextBox)
  Shadow Me, Text1
  End Sub
  
  Private Sub Shadow(fIn As Form, ctrlIn As Control)
  
  Const SHADOW_COLOR = &H40C0& 'Shadow Color
  Const SHADOW_WIDTH = 3 'Shadow Border Width
  
  Dim iOldWidth As Integer
  Dim iOldScale As Integer
  
  'Save the current DrawWidth and ScaleMode
  iOldWidth = fIn.DrawWidth
  iOldScale = fIn.ScaleMode
  
  fIn.ScaleMode = 3
  fIn.DrawWidth = 1
  
  'Draws the shadow around the control by drawing a gray
  'box behind the control that's offset right and down.
  
  fIn.Line (ctrlIn.Left + SHADOW_WIDTH, ctrlIn.Top + _
             SHADOW_WIDTH)-Step(ctrlIn.Width - 1, _
             ctrlIn.Height - 1), SHADOW_COLOR, BF
  
  'Restore Old Setting
  fIn.DrawWidth = iOldWidth
  fIn.ScaleMode = iOldScale
  
  End Sub
  
  
  

  Thursday, June 14, 2007 1:05 PM
• 

  

  0

  Sign in to vote

  
  

  Code 182 : This is a simple code to play a wave file

  Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA"(ByVal lpszSoundName as String, ByVal uFlags as Long) As Long

  
  

  Code 182 : This is a simple code to play a wave file

  Private Sub Form_Load()
  Dim filename as String
  Dim rc as Long
  
  filename = "C:\windows\media\tada.wav"
  rc = sndPlaySound(filename, 1)
  
  End Sub
  

  Thursday, June 14, 2007 1:08 PM
• 

  

  0

  Sign in to vote

  
  

  Code 183 : Draw circles on your form with one little line of code

  Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Circle (X, Y), 50
  End Sub
  

  Thursday, June 14, 2007 1:11 PM
• 

  

  0

  Sign in to vote

  I wanted to know the about the scope of using ADODC in applications where the application has to run in different subnets. Actually this question was asked by Ankit but I also got confused because I also got stuck on th same issue few months back.

  Thursday, June 14, 2007 1:26 PM
• 

  

  0

  Sign in to vote

  Awesome Sanket, let them comming.
  

  Thursday, June 14, 2007 3:52 PM