VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   735
      Left            =   2880
      TabIndex        =   1
      Top             =   2400
      Width           =   1695
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      Height          =   2895
      Left            =   120
      ScaleHeight     =   189
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   285
      TabIndex        =   0
      Top             =   120
      Width           =   4335
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal hSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop 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 Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hbrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function Ellipse Lib "gdi32.dll" (ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function Polyline Lib "gdi32.dll" (ByVal hdc As Long, lpPoint As POINT_TYPE, ByVal nCount As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)


' jpeg
'Private Declare Function SaveToPtr Lib "jpeg.dll" (ByVal DestJPegPtr As Long, ByVal SrcBitmapPtr As Long, ByVal Width As Long, ByVal Height As Long) As Long


Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs

Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type

Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Type BITMAPFILE
    bmiFile As BITMAPFILEHEADER
    bmiInfo As BITMAPINFO
    bmiData() As Byte
End Type

Private Type POINT_TYPE
    x As Long
    y As Long
End Type

Private bytArray() As Byte
Private done As Boolean

Dim w As Integer
Dim h As Integer

Dim BMPFile As BITMAPFILE

Private Sub DrawLine(ByVal hdc As Long, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single, ByVal Color As Long)

    Const PS_SOLID = 0
    Const nWidth = 1
    
    Dim retval As Long  ' return value
    Dim hpen As Long, holdpen As Long
    Dim pt As POINT_TYPE
    Dim Points(0 To 1) As POINT_TYPE

    hpen = CreatePen(PS_SOLID, nWidth, Color)
    holdpen = SelectObject(hdc, hpen)
    
    Points(0).x = x1
    Points(0).y = y1
    Points(1).x = x2
    Points(1).y = y2
    
    retval = Polyline(hdc, Points(0), 2)
    
    'retval = MoveToEx(hdc, x1, y1, pt)  ' set the current point to (x1,y1)
    'retval = LineTo(hdc, x2, y2)  ' draw a line from current point to (x2,y2)
    
    retval = SelectObject(hdc, holdpen)
    retval = DeleteObject(hpen)
End Sub


Private Sub DrawShape(ByVal hdc As Long, ByVal x As Single, ByVal y As Single, ByVal Style As Integer, Optional Size As Integer = 5)
    Dim Points(0 To 5) As POINT_TYPE
    Dim szTop As Integer
    Dim szBottom As Integer
    
    If Size Mod 2 = 0 Then ' even
        szTop = Size \ 2
        szBottom = szTop
    Else
        szTop = Size \ 2
        szBottom = szTop + 1
    End If
    
    Select Case Style
        Case 0 ' None
        
        Case 1 ' Circle
            Ellipse hdc, x - szTop, y - szTop, x + szBottom, y + szBottom
            
        Case 2 ' Rectangle
            Points(0).x = x - szTop
            Points(0).y = y - szTop
            Points(1).x = x + szBottom
            Points(1).y = y - szTop
            Points(2).x = x + szBottom
            Points(2).y = y + szBottom
            Points(3).x = x - szTop
            Points(3).y = y + szBottom
            Points(4).x = x - szTop
            Points(4).y = y - szTop
            
            Polyline hdc, Points(0), 5
            
        Case 3 ' Triangle
            Points(0).x = x
            Points(0).y = y - szTop
            Points(1).x = x + szBottom
            Points(1).y = y + szBottom
            Points(2).x = x - szTop
            Points(2).y = y + szBottom
            Points(3).x = x
            Points(3).y = y - szTop
            
            Polyline hdc, Points(0), 4
            
        Case 4 ' Diamond
            Points(0).x = x
            Points(0).y = y - szTop
            Points(1).x = x + szBottom
            Points(1).y = y
            Points(2).x = x
            Points(2).y = y + szBottom
            Points(3).x = x - szTop
            Points(3).y = y
            Points(4).x = x
            Points(4).y = y - szTop
            
            Polyline hdc, Points(0), 5
            
        Case 5 ' Star
            Points(0).x = x - szTop
            Points(0).y = y + szBottom
            Points(1).x = x
            Points(1).y = y - szTop
            Points(2).x = x + szBottom
            Points(2).y = y + szBottom
            Points(3).x = x - szTop
            Points(3).y = y
            Points(4).x = x + szBottom
            Points(4).y = y
            Points(5).x = x - szTop
            Points(5).y = y + szBottom
            
            Polyline hdc, Points(0), 6
            
    End Select
End Sub

Private Sub CreateBitmap(theBMP As BITMAPFILE, Width As Integer, Height As Integer)
    ' create the info header
    With theBMP
    
        With .bmiInfo
            With .bmiHeader
                .biBitCount = 24
                .biCompression = BI_RGB
                .biPlanes = 1
                .biSize = 40
                .biWidth = Width
                .biHeight = Height
                .biSizeImage = ((Width * 3# + 3) And &HFFFC) * Height
            End With
            
            ' create the color pallete
            'CreatePalette .bmiColors
        End With
        
        ' Now fill in the file header
        With .bmiFile
            .bfType = &H4D42  ' "BM" for Bitmap
            .bfOffBits = Len(theBMP.bmiInfo) + Len(theBMP.bmiFile)
            .bfSize = .bfOffBits + theBMP.bmiInfo.bmiHeader.biSizeImage - 1
        End With
        
        ' now dimension the data
        ReDim .bmiData(.bmiInfo.bmiHeader.biSizeImage - 1)
    End With
End Sub

Private Sub Form_Load()
    Dim mDC As Long
    Dim mBMP As Long
    Dim oBMP As Long
    
    Dim imgRect As RECT
    
    Dim hbrush As Long
    Dim holdbrush As Long
    
    Dim hpen As Long
    Dim holdpen As Long
    
    Dim retval As Long
    
    Dim i As Integer
    Dim j As Integer
    
    Dim hPointer As Long
    
    w = Picture1.ScaleWidth
    h = Picture1.ScaleHeight
    
    'Randomize Timer
    
    ' Initialization
    imgRect.right = w
    imgRect.bottom = h
    
    CreateBitmap BMPFile, w, h
    
    mDC = CreateCompatibleDC(0) ' create a compatible dc to the desktop
    mBMP = CreateDIBSection(mDC, BMPFile.bmiInfo, DIB_RGB_COLORS, hPointer, ByVal 0&, ByVal 0&)
    
    ' Clear the screen
    oBMP = SelectObject(mDC, mBMP) ' Select the bitmap in memory
                                     ' so we can start drawing on it
    hbrush = CreateSolidBrush(RGB(255, 255, 255)) ' White solid brush
    holdbrush = SelectObject(mDC, hbrush) ' Select the white brush
    retval = FillRect(mDC, imgRect, hbrush) ' Paint the entire bitmap white
    retval = SelectObject(mDC, holdbrush) ' now select the old brush, so that we can
    retval = DeleteObject(hbrush) ' delete the white one (cuz we no longer need it)

    ' Start drawing lines
    ' draw line

    For i = 0 To 10
        hpen = CreatePen(Int(Rnd * 6) + 1, Int(Rnd * 5) + 1, RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256)))
        holdpen = SelectObject(mDC, hpen)
        
        DrawShape mDC, Int(Rnd * (w - 40)), j, Int(Rnd * 5) + 1, 40
        j = j + Int(Rnd * 75)
        
        DrawLine mDC, Int(Rnd * w), Int(Rnd * h), Int(Rnd * w), Int(Rnd * h), RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
        
        retval = SelectObject(mDC, holdpen)
        retval = DeleteObject(hpen)
    Next i
    
    
    BitBlt Picture1.hdc, 0, 0, w, h, mDC, 0, 0, vbSrcCopy
    'StretchBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, mDC, 0, 0, w, h, vbSrcCopy
    Picture1.Refresh

    
    ' Release all memory associated with the bitmap
    retval = SelectObject(mDC, oBMP) ' let go of old bitmap
    retval = GetDIBits(mDC, mBMP, ByVal 0&, BMPFile.bmiInfo.bmiHeader.biHeight, _
                        BMPFile.bmiData(0), BMPFile.bmiInfo, DIB_RGB_COLORS)
  
    DeleteObject mBMP
    DeleteDC mDC
End Sub


Private Sub Command1_Click()
    ' now save it
    
        ' use byval varptr(0)
   
    Open "file" & Int(Rnd * Timer) Mod 100 & ".bmp" For Binary Lock Write As #1

    'Put #1, , BMPFile
    
    output ByVal VarPtr(BMPFile.bmiFile.bfType), 2
    output ByVal VarPtr(BMPFile.bmiFile.bfSize), 4
    output ByVal VarPtr(BMPFile.bmiFile.bfReserved1), 2
    output ByVal VarPtr(BMPFile.bmiFile.bfReserved2), 2
    output ByVal VarPtr(BMPFile.bmiFile.bfOffBits), 4
    
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biSize), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biWidth), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biHeight), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biPlanes), 2
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biBitCount), 2
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biCompression), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biSizeImage), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biXPelsPerMeter), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biYPelsPerMeter), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biClrUsed), 4
    output ByVal VarPtr(BMPFile.bmiInfo.bmiHeader.biClrImportant), 4
    
    'Dim z As Integer
    'For z = 0 To 255
    '    output ByVal VarPtr(BMPFile.bmiInfo.bmiColors(z)), 4
    'Next z
    
    output ByVal VarPtr(BMPFile.bmiData(0)), UBound(BMPFile.bmiData)
    
    Erase bytArray
    Close #1
    
End Sub

Private Sub output(ByVal pSrc As Long, ByVal Length As Long)
    ReDim bytArray(Length - 1) As Byte
    CopyMemory bytArray(0), ByVal pSrc, Length
    
    Put #1, , bytArray
End Sub