none
Forum for Helpful Visual Basic 6.0 Codes... Part 3 RRS feed

  • Question

  • Hello friends,

    I'm starting 3rd part of this thread in continuation on special request of "Harshil Patel".

    To all those who are interested, please participate in this thread. I can't do everything on own. Some help is needed from all the participants.

    Waiting for all of you to rock here,




    Sunday, May 27, 2007 7:35 AM

Answers


  • 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

  • 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
  • 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

  • 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
  • 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

  • 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
  • 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
  • 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
  • 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

  • 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

  • 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
  • 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

  • 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
  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

All replies


  • 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

  • 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
  • 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

  • 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
  • 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

  • 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
  • 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
  • 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
  • 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

  • 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

  • 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
  • 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
  • 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

  • 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
  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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

  • 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
  • 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
  • Awesome Sanket, let them comming.
    Thursday, June 14, 2007 3:52 PM