Взаимодействие графических примитивов - VB
Формулировка задачи:
Возможно ли на VB6 создать программу в которой было бы реализовано в полной мере взаимодействие графических примитивов с привязанными к ним элементами и базой данных?
Решение задачи: «Взаимодействие графических примитивов»
textual
Листинг программы
Private Type Point X As Single Y As Single End Type Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Function CreateShape(Pt() As Point, ParamArray B()) As Boolean Dim V As Variant, I As Long ReDim Pt(UBound(B) \ 2) For Each V In B If I And 1 Then Pt(I \ 2).Y = V Else Pt(I \ 2).X = V I = I + 1 Next CreateShape = True End Function Private Function AddToDB(Pt() As Point) As Boolean On Error GoTo ERRSUB Dim Dat() As Byte ReDim Dat(UBound(Pt) * 8 + 7) CopyMemory Dat(0), Pt(0), UBound(Pt) * 8 + 8 DB.Recordset.AddNew DB.Recordset.Fields("Vtx").Value = UBound(Pt) + 1 DB.Recordset.Fields("Data").Value = Dat DB.Recordset.Update AddToDB = True Exit Function ERRSUB: MsgBox "Ошибка записи в БД" End Function Private Function LoadFromBD(Pt() As Point) As Boolean On Error GoTo ERRSUB Dim Dat() As Byte, I As Long I = DB.Recordset.Fields("Vtx") If I <= 0 Then MsgBox "Ошибка в формате данных: неверное число вершин фигуры": Exit Function Dat() = DB.Recordset.Fields("Data") If UBound(Dat) <> (I - 1) * 8 + 7 Then MsgBox "Ошибка в формате данных: неверные данные фигуры": Exit Function ReDim Pt(I - 1) CopyMemory Pt(0), Dat(0), UBound(Pt) * 8 + 8 LoadFromBD = True Exit Function ERRSUB: MsgBox "Ошибка чтения из БД" End Function Private Sub DrawShape(Pt() As Point) Dim I As Long picDisplay.Cls picDisplay.CurrentX = -2 picDisplay.CurrentY = -2 picDisplay.Print "Число вершин: " & UBound(Pt) + 1 picDisplay.CurrentX = Pt(0).X picDisplay.CurrentY = Pt(0).Y For I = 0 To UBound(Pt) picDisplay.Line -(Pt(I).X, Pt(I).Y) Next picDisplay.Line -(Pt(0).X, Pt(0).Y) 'Замыкаем picDisplay.Refresh End Sub Private Sub DB_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean) fCancelDisplay = True End Sub Private Sub DB_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset) Dim Pt() As Point If pRecordset.EOF Or pRecordset.BOF Then Exit Sub If LoadFromBD(Pt) Then DrawShape Pt End Sub Private Sub Form_Load() On Error GoTo ERRSUB Dim Pt() As Point Me.Show DB.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _ App.Path & "\DataBase.mdb;Mode=ReadWrite;Persist Security Info=False" DB.RecordSource = "SELECT * FROM Figures" DB.Refresh ' Создание фигур и добавление в БД ' CreateShape Pt, -1, -1, 1, -1, 1, 1, -1, 1 ' Прямоугольник ' AddToDB Pt ' CreateShape Pt, 0, -1, 1, 1, -1, 1 ' Треугольник ' AddToDB Pt ' CreateShape Pt, 0, -1, 1, 0, 0, 1, -1, 0 ' Ромб ' AddToDB Pt ' CreateShape Pt, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd ' AddToDB Pt Exit Sub ERRSUB: MsgBox "Ошибка подключения к базе данных", vbCritical: End End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д