VERSION 5.

00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "Pintu Masuk Griya"
ClientHeight = 8610
ClientLeft = 45
ClientTop = 645
ClientWidth = 15720
BeginProperty Font
Name = "Tahoma"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "Form1.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8610
ScaleWidth = 15720
StartUpPosition = 2 'CenterScreen
WindowState = 2 'Maximized
Begin VB.Timer Timer1
Interval = 1000
Left = 9000
Top = 480
End
Begin VB.PictureBox Picture3
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 2010
Left = 6600
Picture = "Form1.frx":08CA
ScaleHeight = 1980
ScaleWidth = 6765
TabIndex = 11
Top = 8280
Width = 6795
End
Begin VB.CommandButton cmdSimpan
Height = 1170
Left = 9600
Picture = "Form1.frx":5C72
Style = 1 'Graphical
TabIndex = 10
Top = 6240
Width = 1215
End
Begin VB.PictureBox Picture1
Height = 7095
Left = 10920
ScaleHeight = 7035
ScaleWidth = 9075
TabIndex = 4
Top = 240
Width = 9135
End
Begin VB.PictureBox picSnapshot
Appearance = 0 'Flat
ForeColor = &H80000008&
Height = 7080
Left = 10920
ScaleHeight = 7050
ScaleWidth = 9345
TabIndex = 3
Top = 240
Width = 9375
End
Begin VB.CommandButton cmdSnap
Caption = "Snap"
Enabled = 0 'False
Height = 495
Left = 11880
TabIndex = 2
Top = 6480
Width = 1215
End
Begin VB.PictureBox Picture4
Height = 735
Left = 11400
Picture = "Form1.frx":60B4
ScaleHeight = 675
ScaleWidth = 1755
TabIndex = 8
Top = 4440
Width = 1815
End
Begin VB.PictureBox Picture2
AutoSize = -1 'True
Height = 735
Left = 11520
Picture = "Form1.frx":79F2
ScaleHeight = 675
ScaleWidth = 2325
TabIndex = 9
Top = 3360
Width = 2385
End
Begin VB.CommandButton cmdCetak
Caption = "Cetak"
Height = 255
Left = 11520
TabIndex = 7
Top = 5640
Width = 1335
End
Begin VB.Label lblTgl
Alignment = 2 'Center
Height = 255
Left = 9120
TabIndex = 6
Top = 7560
Width = 2175
End
Begin VB.Label lblIDParkir
Alignment = 2 'Center
Height = 255
Left = 9120
TabIndex = 5
Top = 7920
Width = 2175
End
Begin VB.Label Label2
Alignment = 2 'Center
Caption = "Captured"
Height = 255
Left = 10680
TabIndex = 1
Top = 0
Width = 9495
End
Begin VB.Image imgPlaceHolder
Appearance = 0 'Flat
BorderStyle = 1 'Fixed Single
Height = 7200
Left = 120
Stretch = -1 'True
Top = 240
Width = 9375
End
Begin VB.Label Label1
Alignment = 2 'Center
Caption = "Live Cam"
Height = 255
Left = 0
TabIndex = 0
Top = 0
 Width = 9375
End
Begin VB.Menu mnuCameras
Caption = "&Cameras"
Begin VB.Menu mnuCamerasChoice
Caption = "none"
Enabled = 0 'False
Index = 0
End
Begin VB.Menu mnuCamerasDiv1
Caption = "-"
End
Begin VB.Menu mnuCamerasAddNew
Caption = "Add &new camera..."
Shortcut = ^N
End
Begin VB.Menu mnuCamerasDiv2
Caption = "-"
End
Begin VB.Menu mnuCamerasRemove
Caption = "Remove camera list"
Enabled = 0 'False
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Dim gGraph As IMediaControl

Dim gRegFilters As Object
Dim gCapStill As VBGrabber

' GDI functions to draw a DIBSection into a DC

Private Declare Function CreateCompatibleDC Lib "GDI32" _
(ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "GDI32" _
(ByVal hdc As Long, ByVal hBitmap As Long) As Long
Private Declare Function BitBlt Lib "GDI32" _
(ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, _
ByVal width As Long, ByVal height As Long, _
ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal mode As Long) _
As Long
Private Declare Sub DeleteDC Lib "GDI32" _
 (ByVal hdc As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, src As Any, ByVal count As Long)

'=======================cursor pos==================
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal Y As
Long) As Long

Private Type POINTAPI

x As Long
Y As Long
End Type

' non-portable (win32 only) types and functions to

' convert a bitmap into a safe array of bytes
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
rgsabound(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" _
(Ptr() As Any) As Long

Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&,
ByVal HelpFile$, ByVal wCommand%, dwData As Any)

'Requires a reference to:

'
' ActiveMovie control type library (quartz.dll).
'

Private Const WS_BORDER = &H800000

Private Const WS_DLGFRAME = &H400000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const MASKBORDERLESS = Not (WS_BORDER Or WS_DLGFRAME Or WS_SYSMENU Or
WS_THICKFRAME)
Private Const MASKBORDERMIN = Not (WS_DLGFRAME Or WS_SYSMENU Or WS_THICKFRAME)

'FILTER_STATE values, should have been defined in Quartz.dll,

'but another item Microsoft left out.
Private Enum FILTER_STATE
State_Stopped = 0
State_Paused = 1
State_Running = 2
End Enum

Private Const E_FAIL As Long = &H80004005

'These are "scripts" followed by BuildGraph() below to create a

'DirectShow FilterGraph for webcam viewing.
'
'FILTERLIST is incomplete, and must be prepended with the name
'of your webcam's Video Capture Source filter. Since there may
'be multiples, FILTERLIST begins with "~Capture" which is used
'when BuildGraph() interprets this script to select one having
'a pin named "Capture".
Private Const FILTERLIST As String = _
"~Capture|" _
& "AVI Decompressor|" _
& "Color Space Converter|" _
& "Video Renderer"
Private Const CONNECTIONLIST As String = _
"Capture~XForm In|" _
& "XForm Out~Input|" _
& "XForm Out~VMR Input0"

Private fgmVidCap As QuartzTypeLib.FilgraphManager 'Not "Is Nothing" means camera

is previewing.
Private bv2VidCap As QuartzTypeLib.IBasicVideo2
Private vwVidCap As QuartzTypeLib.IVideoWindow
Private SelectedCamera As Integer '-1 means none selected.
Private InsideWidth As Double
Private AspectRatio As Double

Dim Cursor As POINTAPI

Private Function BuildGraph( _

ByVal FGM As QuartzTypeLib.FilgraphManager, _
ByVal Filters As String, _
ByVal Connections As String) As Integer
'Returns -1 on success, or FilterIndex when not found, or
'ConnIndex + 100 when a pin of the connection not found.
'
'Filters:
'
' A string with Filter Name values separated by "|" delimiters
' and optionally each of these can be followed by one required
 ' Pin Name value separated by a "~" delimiter for use as a tie
' breaker when there might be multiple filters with the same
' Name value.
'
'Connections:
'
' A string with a list of output pins to be connected to
' input pins. Each pin-pair is separated by "|" delimiters
' and each pair has out and in pins separated by a "~"
' delimiter. The pin-pairs should be one less than the number
' of filters.
Dim FilterNames() As String
Dim FilterIndex As Integer
Dim FilterParts() As String
Dim FoundFilter As Boolean
Dim rfiEach As QuartzTypeLib.IRegFilterInfo
Dim fiFilters() As QuartzTypeLib.IFilterInfo
Dim Conns() As String
Dim ConnIndex As Integer
Dim ConnParts() As String
Dim piEach As QuartzTypeLib.IPinInfo
Dim piOut As QuartzTypeLib.IPinInfo
Dim piIn As QuartzTypeLib.IPinInfo

'Setup for filter script processing.

FilterNames = Split(UCase$(Filters), "|")
ReDim fiFilters(UBound(FilterNames))
On Error Resume Next
'Find and add filters.
For FilterIndex = 0 To UBound(FilterNames)
FilterParts = Split(FilterNames(FilterIndex), "~")
For Each rfiEach In FGM.RegFilterCollection
If UCase$(rfiEach.Name) = FilterParts(0) Then
rfiEach.filter fiFilters(FilterIndex)
If UBound(FilterParts) > 0 Then
For Each piEach In fiFilters(FilterIndex).Pins
If UCase$(piEach.Name) = FilterParts(1) Then
FoundFilter = True
Exit For
End If
Next
Else
FoundFilter = True
Exit For
End If
End If
Next
If FoundFilter Then
FoundFilter = False
Else
 BuildGraph = FilterIndex
Exit Function 'Error result will be 0, 1, etc.
End If
Next
BuildGraph = -1

'Setup for connection script processing.

Conns = Split(UCase$(Connections), "|")
FilterIndex = 0

'Find and connect pins.

For ConnIndex = 0 To UBound(Conns)
ConnParts = Split(Conns(ConnIndex), "~")
For Each piEach In fiFilters(FilterIndex).Pins
If UCase$(piEach.Name) = ConnParts(0) Then
Set piOut = piEach
Exit For
End If
Next
For Each piEach In fiFilters(FilterIndex + 1).Pins
If UCase$(piEach.Name) = ConnParts(1) Then
Set piIn = piEach
Exit For
End If
Next
If piOut Is Nothing Or piIn Is Nothing Then
'Error, missing a pin.
BuildGraph = ConnIndex + 100 'Error result will be 100, 101, etc.
Exit Function
End If
piOut.ConnectDirect piIn
FilterIndex = FilterIndex + 1
Next
End Function

Private Sub DeselectFailedCamera(ByVal Error As Long)

Dim CameraName As String

With mnuCamerasChoice(SelectedCamera)
.Checked = False
CameraName = .Caption
End With
SelectedCamera = -1
SaveSettings
MsgBox "Selected camera failed, may not be connected:" & vbNewLine _
& vbNewLine _
& CameraName & vbNewLine _
& vbNewLine _
& "BuildGraph error " & CStr(Error), _
vbOKOnly Or vbInformation
End Sub

Private Function IsCameraInMenu(ByVal CameraName As String) As Boolean

Dim C As Integer

If SelectedCamera >= 0 Then

For C = 0 To mnuCamerasChoice.UBound
If CameraName = mnuCamerasChoice(C).Caption Then
IsCameraInMenu = True
Exit For
End If
Next
End If
End Function

Private Sub LoadSettings()

Dim F As Integer
Dim C As Integer
Dim CameraName As String

SelectedCamera = -1 'None.
On Error Resume Next
GetAttr "Settings.txt"
If Err.Number = 0 Then
On Error GoTo 0
F = FreeFile(0)
Open "Settings.txt" For Input As #F
Input #F, SelectedCamera
Do Until EOF(F)
Input #F, CameraName
If C > 0 Then Load mnuCamerasChoice(C)
With mnuCamerasChoice(C)
.Enabled = True
.Caption = CameraName
.Checked = C = SelectedCamera
End With
C = C + 1
Loop
Close #F
mnuCamerasRemove.Enabled = True
End If
End Sub

Private Sub SaveSettings()

Dim F As Integer
Dim C As Integer

F = FreeFile(0)
Open "Settings.txt" For Output As #F
Write #F, SelectedCamera
 For C = 0 To mnuCamerasChoice.UBound
Write #F, mnuCamerasChoice(C).Caption
Next
Close #F
End Sub

Private Function StartCamera(ByVal CamName As String) As Integer

'Returns -1 on success, or BuildGraph() error on failures.

Set fgmVidCap = New QuartzTypeLib.FilgraphManager

'Tack camera name onto FILTERLIST and try to start it.
StartCamera = BuildGraph(fgmVidCap, CamName & FILTERLIST, CONNECTIONLIST)
If StartCamera >= 0 Then Exit Function

Set bv2VidCap = fgmVidCap

With bv2VidCap
AspectRatio = CDbl(.VideoHeight) / CDbl(.VideoWidth)
End With

Set vwVidCap = fgmVidCap

With vwVidCap
.FullScreenMode = False
.Left = ScaleX(imgPlaceHolder.Left, ScaleMode, vbPixels)
.Top = ScaleY(imgPlaceHolder.Top, ScaleMode, vbPixels)
.width = ScaleX(InsideWidth, ScaleMode, vbPixels) + 2
.height = ScaleY(InsideWidth * AspectRatio, ScaleMode, vbPixels) + 2
picSnapshot.height = InsideWidth * AspectRatio + ScaleY(2, vbPixels,
ScaleMode)
imgPlaceHolder.Visible = False
.WindowStyle = .WindowStyle And MASKBORDERMIN
.Owner = hwnd
.Visible = True
End With

StartCamera = -1
cmdSnap.Enabled = True
fgmVidCap.Run
End Function

Private Sub StopCamera()

Const StopWaitMs As Long = 40
Dim State As FILTER_STATE

If Not fgmVidCap Is Nothing Then

With fgmVidCap
.Stop
Do
.GetState StopWaitMs, State
Loop Until State = State_Stopped Or Err.Number = E_FAIL
End With
 With vwVidCap
.Visible = False
.Owner = 0
End With
Set vwVidCap = Nothing
Set bv2VidCap = Nothing
Set fgmVidCap = Nothing
End If
imgPlaceHolder.Visible = True
cmdSnap.Enabled = False
End Sub

Private Sub cmdCetak_Click()

Dim KodeParkir As String

Printer.PaintPicture Picture2.Picture, 1800, 0

Printer.PaintPicture Picture4.Picture, 0, 0
Printer.CurrentY = 1000
Printer.FontName = "Arial"
Printer.FontSize = 14

Printer.FontBold = True
Printer.CurrentX = 1170
Printer.Print "TIKET PARKIR"
Printer.FontBold = False
Printer.FontName = "Free 3 of 9 Regular"
'KodeParkir = "*" & Right(lblIDParkir.Caption, 8) & "*"

KodeParkir = "*" & lblIDParkir.Caption & "*"

Printer.FontSize = 28
'Printer.FontSize = 32
' Printer.Print "eeeeeeee*" & txtKode1.Text & "*eeeeeeeeeeeee*" & txtKode2.Text &
"*eeeeeeeeeeeee*" & txtKode3.Text & "*"
' Printer.Print "eeeeeeee*" & txtKode1.Text & "*eeeeeeeeeeeee*" & txtKode2.Text &
"*eeeeeeeeeeeee*" & txtKode3.Text & "*"
Printer.CurrentX = 700
'Printer.CurrentX = 100
'Printer.Print "e*" & lblIDParkir.Caption & "*"
Printer.Print KodeParkir
Printer.CurrentX = 700
Printer.Print KodeParkir
'Printer.Print "*" & lblIDParkir.Caption & "*"

Printer.CurrentX = 0

Printer.FontName = "Arial"
Printer.FontSize = 7
Printer.Print " " & lblIDParkir.Caption
Printer.FontSize = 10
Printer.FontBold = True
'Printer.Print ""
Printer.Print " " & Format(Now, "dd-mm-yyyy hh:mm")
Printer.FontSize = 1
Printer.Print ""
'Printer.Print ""
Printer.Font = "Arial"
Printer.FontSize = 1
Printer.Print ""
Printer.FontSize = 6
Printer.FontBold = False
Printer.Print "- Kehilangan Tiket ini akan diperiksa & Dikenakan Denda"
Printer.Print "- Jangan meninggalkan barang berharga/tiket ini pada Kendaraan"
Printer.Print "- Kehilangan menjadi tanggungan pemilik sepenuhnya"
Printer.EndDoc
PlaySound "D:\Sound\SelamatDatangDi.wav", 0, SND_FILENAME

End Sub

Private Sub cmdSimpan_Click()

Dim SQLTimI, Dir As String
Dim NoPol, Supir, Operator, IDTrx As String
Dim rsS As ADODB.Recordset
Dim rsTr As ADODB.Recordset
Dim rs7 As New ADODB.Recordset
Dim mystream As ADODB.Stream
Dim rsSD As ADODB.Recordset
Set rsSD = New ADODB.Recordset
Set rsTr = New ADODB.Recordset
Set rsS = New ADODB.Recordset
Set mystream = New ADODB.Stream
mystream.Type = adTypeBinary
'Dim bma As IBitmapAccess
'Set bma = gCapStill.CapToMem
IDTrx = lblIDParkir.Caption
SaveSetting App.EXEName, "IDPArkir", "Nomor", Right(lblIDParkir.Caption, 4)
SaveSetting App.EXEName, "IDParkir", "Tanggal", Format(Date, "yymmdd")
'Dir = "\\SERVER-SIGMA-PC\Data Server\ImageParking"
Dir = "D:\ImageParking"
'ShowBitmap
cmdSnap_Click
SavePicture picSnapshot.Image, Dir & "\" & IDTrx & "I.jpg"
Picture1.Picture = LoadPicture("")
Picture1.Picture = LoadPicture(Dir & "\" & IDTrx & "I.jpg")
SaveJPG Picture1.Picture, Dir & "\" & IDTrx & "I.jpg", 80 ' range is 0 to 100
SaveJPG Picture1.Picture, App.Path & "\" & IDTrx & ".jpg", 80 ' range is 0
to 100

'PlaySound "D:\Sounds\SelamatDatang.wav", 0, SND_FILENAME

cmdCetak_Click
 With rsParkir
.AddNew
!KodeTransaksi = lblIDParkir.Caption
!TglTransaksi = Format(Date, "dd/mm/yyyy")
!EntryTime = Format(Time, "hh:mm")
!ExitTime = Format(Time, "hh:mm")
' !NoPol = txtNoPolIn.Text
!LamaParkir = 0
!Nilai = 0
!EntryTimeValue = Format(Time, "#.00000000000000")
!ExitTimeValue = Format(Time, "#.00000000000000")
!TglParkir = Format(Date, "yyyy-mm-dd")
!OperatorEntry = Operator
!Aktif = True
.Update
End With
'===========================SAVE TO DATABASE
' rsS.Open "SELECT * FROM parkir WHERE KodeTransaksi = '" & IDTrx & "'", ConnP,
adOpenStatic, adLockOptimistic

' rsS.AddNew
' mystream.Open
' mystream.LoadFromFile App.Path & "\" & IDTrx & ".jpg"
' 'mystream.LoadFromFile Dir & "\" & IDTrx & "I.jpg"

' 'rsS!ImageIn = mystream.Read

' rsS.Update
' mystream.Close

'Picture1.Picture = LoadPicture("")
' Kill App.Path & "\" & IDTrx & ".jpg"

Form_Activate

' Dim bma As IBitmapAccess

' Set bma = gCapStill.CapToMem

' ShowBitmap bma

' Snap_Click
' Kill App.Path & "\" & lblIDParkir.Caption

End Sub

Private Sub cmdSimpan_GotFocus()

cmdSimpan.BackColor = &H8000000D
End Sub

Private Sub cmdSimpan_LostFocus()

cmdSimpan.BackColor = &H8000000F
End Sub

Private Sub cmdSnap_Click()

Const PauseWaitMs As Long = 16
Const biSize = 40 'BITMAPINFOHEADER and not BITMAPV4HEADER, etc. but we don't
get those.
Dim State As FILTER_STATE
Dim Size As Long
Dim DIB() As Long
Dim hBitmap As Long
Dim Pic As StdPicture

With fgmVidCap
.Pause
Do
.GetState PauseWaitMs, State
Loop Until State = State_Paused Or Err.Number = E_FAIL
If Err.Number = E_FAIL Then
MsgBox "Failed to pause webcam preview for snapshot!", _
vbOKOnly Or vbExclamation
Exit Sub
End If

With bv2VidCap
'Estimate size. Correct for 32-bit RGB and generous
'for anything with fewer bits per pixel, compressed,
'or palette-ized (we hope).
Size = biSize + .VideoWidth * .VideoHeight
ReDim DIB(Size - 1)
Size = Size * 4 'To bytes.
.GetCurrentImage Size, DIB(0)
End With

.Run
End With

hBitmap = LongDIB2HBitmap(DIB)
If hBitmap <> 0 Then
Set Pic = HBitmap2Picture(hBitmap, 0)
If Not Pic Is Nothing Then
With picSnapshot
.AutoRedraw = True
.PaintPicture Pic, 0, 0, .ScaleWidth, .ScaleHeight
.AutoRedraw = False
End With
End If
DeleteObject hBitmap
End If
End Sub
Private Sub Form_Activate()
Dim No As Single
Dim NamaUser, DateNow As String
Dim rsP As New ADODB.Recordset
Dim Tanggal, Nomor, TglDB, NoDB, KdTrx As String
'Me.WindowState = 1
DateNow = Format(Date, "yyyy-mm-dd")
lblTgl.Caption = Format(Date, "dd mmmm yyyy")

' rsP.Open "SELECT KodeTransaksi FROM parkir WHERE TglTransaksi = '" & DateNow &
"'", ConnP, adOpenDynamic, adLockOptimistic
' If rsP.EOF Then
' Nomor = "0001"
' Else
' rsP.MoveLast
' Nomor = Right(rsP!KodeTransaksi, 4)
Tanggal = GetSetting(App.EXEName, "IDParkir", "Tanggal")
Nomor = GetSetting(App.EXEName, "IDParkir", "Nomor")
No = Val(Nomor)
If Tanggal <> Format(Date, "yymmdd") Then
Nomor = "0001"
Else
No = No + 1
If No < 10 Then Nomor = "000" & Trim(str(No))
If No > 9 And No < 100 Then Nomor = "00" & Trim(str(No))
If No > 99 And No < 1000 Then Nomor = "0" & Trim(str(No))
If No > 999 Then Nomor = Trim(str(No))
End If
' lblIDParkir.Caption = "PM2" & Trim(Nomor)
lblIDParkir.Caption = Format(Date, "yymmdd") & "SV8" & Trim(Nomor)
' lblIDParkir.Caption = Format(Date, "yymmdd") & "218" & Trim(Nomor)
cmdSimpan.SetFocus

'SetCursorPos 515, 640 '1024 x 768

'SetCursorPos 688, 640 '1366 x 768
SetCursorPos 688, 500 '1366 x 768 Maximized

End Sub

Private Sub Form_Load()

Dim StartResult As Integer

InsideWidth = picSnapshot.width - ScaleX(2, vbPixels, ScaleMode)

LoadSettings
If SelectedCamera >= 0 Then
StartResult = StartCamera(mnuCamerasChoice(SelectedCamera).Caption)
If StartResult >= 0 Then DeselectFailedCamera StartResult
 End If

If App.PrevInstance = True Then

MsgBox "Sistem Parkir Sigma - Griya sudah Berjalan, Aplikasi Tidak Bisa " & Chr(13)
& "Dibuka Ulang Ketika Aplikasi Tengah Berjalan", vbExclamation, "Peringatan"
End
End If
Module1.OpenDB

'Set gGraph = New FilgraphManager

'Set gRegFilters = gGraph.RegFilterCollection
'RefreshRegFilters
'Preview_Click
'frmGateIn.mnf1_Click

Me.width = 10080
' Me.Height = 9315
rsParkir.CursorLocation = adUseClient
rsTarif.CursorLocation = adUseClient
rsUser.CursorLocation = adUseClient
rsParkir.Open "parkir", ConnP, adOpenDynamic, adLockOptimistic, adCmdTable
rsTarif.Open "tarif", ConnP, adOpenDynamic, adLockOptimistic, adCmdTable
rsUser.Open "user", ConnP, adOpenDynamic, adLockOptimistic, adCmdTable

End Sub

Private Sub Form_Unload(Cancel As Integer)

'Make sure we break the link, don't want to have a memory
'leak or hang the camera or something:
StopCamera

Unload Form2
End Sub

Private Sub mnuCamerasAddNew_Click()

Dim StartResult As Integer

Form2.Show vbModal, Me
If Form2.Oked Then
If IsCameraInMenu(Form2.CameraName) Then
MsgBox "Camera:" & vbNewLine _
& vbNewLine _
& Form2.CameraName & vbNewLine _
& vbNewLine _
& "Is already in the menu."
Else
StopCamera
StartResult = StartCamera(Form2.CameraName)
If StartResult < 0 Then
If SelectedCamera >= 0 Then
 mnuCamerasChoice(SelectedCamera).Checked = False
End If
If SelectedCamera >= 0 Then
SelectedCamera = mnuCamerasChoice.UBound + 1
Load mnuCamerasChoice(SelectedCamera)
Else
SelectedCamera = 0
End If
With mnuCamerasChoice(SelectedCamera)
.Caption = Form2.CameraName
.Checked = True
.Enabled = True
End With
SaveSettings
mnuCamerasRemove.Enabled = True
Else
MsgBox
"This doesn't seems to be a valid webcam:" & vbNewLine _
&
vbNewLine _
&
Form2.CameraName & vbNewLine _
&
vbNewLine _
&
"BuildGraph error " & CStr(Error), _
vbOKOnly Or vbInformation
'Try to go back to previous camera.
If SelectedCamera > -1 Then
StartResult =
StartCamera(mnuCamerasChoice(SelectedCamera).Caption)
If StartResult >= 0 Then DeselectFailedCamera StartResult
End If
End If
End If
End If
End Sub

Private Sub mnuCamerasChoice_Click(Index As Integer)

Dim StartResult As Integer

If Index <> SelectedCamera Then

If SelectedCamera >= 0 Then
StopCamera
mnuCamerasChoice(SelectedCamera).Checked = False
End If
SelectedCamera = Index
mnuCamerasChoice(SelectedCamera).Checked = True
StartResult = StartCamera(mnuCamerasChoice(SelectedCamera).Caption)
If StartResult < 0 Then
SaveSettings
Else
DeselectFailedCamera StartResult
End If
End If
End Sub

Private Sub mnuCamerasRemove_Click()

Dim C As Integer

StopCamera
SelectedCamera = -1
With mnuCamerasChoice(0)
.Caption = "none"
.Enabled = False
End With
For C = mnuCamerasChoice.UBound To 1 Step -1
Unload mnuCamerasChoice(C)
Next
mnuCamerasRemove.Enabled = False
On Error Resume Next
Kill "Settings.txt"
End Sub

Private Sub Timer1_Timer()

'SetCursorPos 515, 640
'SetCursorPos 688, 640 '1366 x 768
SetCursorPos 688, 500 '1366 x 768 Maximized
End Sub