cell.ctl

来自「采用VB编写的一个电路分析系统」· CTL 代码 · 共 1,237 行 · 第 1/3 页

VERSION 5.00
Begin VB.UserControl cell 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00FFFFFF&
   ClientHeight    =   600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   795
   MouseIcon       =   "cell.ctx":0000
   MousePointer    =   99  'Custom
   ScaleHeight     =   600
   ScaleWidth      =   795
   Tag             =   "0"
End
Attribute VB_Name = "cell"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'缺省属性值:
Const m_def_n1tag = 0
Const m_def_n2tag = 0
Const m_def_main1 = 0
Const m_def_main2 = 0
Const m_def_isnew = 0
Const m_def_n1x = 0
Const m_def_n1y = 300
Const m_def_n2x = 800
Const m_def_n2y = 300
Const m_def_mytag = 0
Const m_def_cellvalue = 0
Const m_def_cellinbranch = 0
Const m_def_celln1 = 0
Const m_def_celln2 = 0
Const m_def_cellinhole1 = 0
Const m_def_cellinhole2 = 0
Const m_def_celltag = 0
Const m_def_n1volt = 0
Const m_def_n2volt = 0
Const m_def_cellcurrent = 0
Const m_def_cellarc = 0
Const m_def_cellstate = -1
Const m_def_cellindex = 0
Const m_def_celltype = 0



'属性变量:
Dim m_n1tag As Integer
Dim m_n2tag As Integer
Dim m_main1 As Integer
Dim m_main2 As Integer
Dim m_isnew As Integer
Dim m_n1x As Single   'i define this four variable to mark the position of the two node for the out modol to line them
Dim m_n1y As Single   '//////////////////////////////////////////////////////////////////////////////////////////////
Dim m_n2x As Single
Dim m_n2y As Single
Dim m_mytag As Integer
Dim m_cellvalue As Variant
Dim m_cellinbranch As Integer
Dim m_celln1 As Integer
Dim m_celln2 As Integer
Dim m_cellinhole1 As Variant
Dim m_cellinhole2 As Variant
Dim m_celltag As Variant
Dim m_n1volt As Variant
Dim m_n2volt As Variant
Dim m_cellcurrent As Variant
Dim m_cellarc As Integer
Dim m_cellstate As Integer
Dim m_cellindex As Integer
Dim m_celltype As Integer
'事件声明:
'Event Hide() 'MappingInfo=UserControl,UserControl,-1,Hide
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "当用户在一个对象上按下并释放鼠标按钮时发生。"
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"
Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,OLEDragDrop
Attribute OLEDragDrop.VB_Description = "OLEDropMode 的属性设置为手动、且数据通过 OLE 拖/放操作放入控件时发生。"
Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, Y As Single, State As Integer) 'MappingInfo=UserControl,UserControl,-1,OLEDragOver
Attribute OLEDragOver.VB_Description = "当 OLEDropMode 属性设置为手动、且 OLE 拖/放操作期间鼠标经过控件时发生。"
Event Show() 'MappingInfo=UserControl,UserControl,-1,Show
Attribute Show.VB_Description = "当控件的 Visible 属性变为 True 时发生。"
Event WriteProperties(PropBag As PropertyBag) 'MappingInfo=UserControl,UserControl,-1,WriteProperties
Attribute WriteProperties.VB_Description = "当要求用户控件或用户文档向一个文件写入数据时发生。"
Event mouseover()




'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "返回/设置对象中文本和图形的前景色。"
    ForeColor = UserControl.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    UserControl.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "返回/设置一个值，决定一个对象是否响应用户生成事件。"
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "返回一个 Font 对象。"
Attribute Font.VB_UserMemId = -512
    Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set UserControl.Font = New_Font
    PropertyChanged "Font"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,BackStyle
Public Property Get BackStyle() As Integer
Attribute BackStyle.VB_Description = "指出 Label 或 Shape 的背景样式是透明的还是不透明的。"
    BackStyle = UserControl.BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    UserControl.BackStyle() = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,Refresh
Public Sub Refresh()
Attribute Refresh.VB_Description = "强制完全重画一个对象。"
    UserControl.Refresh
End Sub

Private Sub UserControl_Click()
    RaiseEvent Click
Call drawface
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub



Private Sub UserControl_Initialize()
Call drawface
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, x, Y)





End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, x, Y)

If mytag <> 0 Then
UserControl.MouseIcon = LoadPicture(syspath + "\Cursors\harrow.cur")

Else
UserControl.MouseIcon = LoadPicture(syspath + "\Cursors\hmove.cur")
End If

UserControl.DrawMode = 7
If cellarc = 0 Then
If x < 100 And Y > 200 And Y < 400 And mytag = 0 Then
   UserControl.Circle (50, 300), 30, vbWhite
    mytag = 1
 End If
If x < 100 And Y > 200 And Y < 400 And mytag = 2 Then
    UserControl.Circle (750, 300), 30, vbWhite
     UserControl.Circle (50, 300), 30, vbWhite
    mytag = 1
End If
If x > 700 And Y > 200 And Y < 400 And mytag = 0 Then
       UserControl.Circle (750, 300), 30, vbWhite
     mytag = 2
   End If
 If x > 700 And Y > 200 And Y < 400 And mytag = 1 Then
  UserControl.Circle (50, 300), 30, vbWhite
    UserControl.Circle (750, 300), 30, vbWhite
      mytag = 2
  End If
 If (x > 100 And x < 700) Or (x < 100 And (Y < 200 Or Y > 400)) Or (x > 700 And (Y < 200 Or Y > 400)) Then
   If mytag = 1 Then
      UserControl.Circle (50, 300), 30, vbWhite
  
  ElseIf mytag = 2 Then
         UserControl.Circle (750, 300), 30, vbWhite
    End If
 mytag = 0
End If
Else
If Y < 100 And x > 200 And x < 400 And mytag = 0 Then
   UserControl.Circle (300, 50), 30, vbWhite
    mytag = 1
 End If
If Y < 100 And x > 200 And x < 400 And mytag = 2 Then
    UserControl.Circle (300, 750), 30, vbWhite
     UserControl.Circle (300, 50), 30, vbWhite
    mytag = 1
End If
If Y > 700 And x > 200 And x < 400 And mytag = 0 Then
       UserControl.Circle (300, 750), 30, vbWhite
     mytag = 2
   End If
 If Y > 700 And x > 200 And x < 400 And mytag = 1 Then
  UserControl.Circle (300, 50), 30, vbWhite
    UserControl.Circle (300, 750), 30, vbWhite
      mytag = 2
  End If
 If (Y > 100 And Y < 700) Or (Y < 100 And (x < 200 Or x > 400)) Or (Y > 700 And (x < 200 Or x > 400)) Then
   If mytag = 1 Then
      UserControl.Circle (300, 50), 30, vbWhite
  
  ElseIf mytag = 2 Then
         UserControl.Circle (300, 750), 30, vbWhite
    End If
 mytag = 0
End If
End If

UserControl.DrawMode = 13

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, x, Y)
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,AutoRedraw
Public Property Get AutoRedraw() As Boolean
Attribute AutoRedraw.VB_Description = "返回/设置从 graphics 方法到一个持久性位图的输出。"
    AutoRedraw = UserControl.AutoRedraw
End Property

Public Property Let AutoRedraw(ByVal New_AutoRedraw As Boolean)
    UserControl.AutoRedraw() = New_AutoRedraw
    PropertyChanged "AutoRedraw"
End Property
'
'' "Circle" 后面的下划线是必须的，
''因为它是 VBA 中的保留字。
''注意！不要删除或修改下列被注释的行！
''MappingInfo=UserControl,UserControl,-1,Circle
''///////////////////////////////////////////////////////////////////////
'Public Sub Circle_(X As Single, Y As Single, Radius As Single, Color As Long, StartPos As Single, EndPos As Single, Aspect As Single)
'End Sub
'    UserControl.Circle (X, Y), Radius, Color, StartPos, EndPos, Aspect
'End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,Cls
Public Sub Cls()
Attribute Cls.VB_Description = "清除窗体、图像或图片框中在运行时生成的图形和文本。"
    UserControl.Cls
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,CurrentX
Public Property Get CurrentX() As Single
Attribute CurrentX.VB_Description = "返回/设置下次 print 或 draw 方法的水平坐标。"
    CurrentX = UserControl.CurrentX
End Property

Public Property Let CurrentX(ByVal New_CurrentX As Single)
    UserControl.CurrentX() = New_CurrentX
    PropertyChanged "CurrentX"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,CurrentY
Public Property Get CurrentY() As Single
Attribute CurrentY.VB_Description = "返回/设置下次 print 或 draw 方法的垂直坐标。"
    CurrentY = UserControl.CurrentY
End Property

Public Property Let CurrentY(ByVal New_CurrentY As Single)
    UserControl.CurrentY() = New_CurrentY
    PropertyChanged "CurrentY"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,DrawMode
Public Property Get DrawMode() As Integer
Attribute DrawMode.VB_Description = "设置以 graphics 方法或 Shape 、 Line 控件输出时的外观。"
    DrawMode = UserControl.DrawMode
End Property

Public Property Let DrawMode(ByVal New_DrawMode As Integer)
    UserControl.DrawMode() = New_DrawMode
    PropertyChanged "DrawMode"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,FillColor
Public Property Get FillColor() As OLE_COLOR
Attribute FillColor.VB_Description = "返回/设置填充形状、圆环和方框所使用的颜色。"
    FillColor = UserControl.FillColor
End Property

Public Property Let FillColor(ByVal New_FillColor As OLE_COLOR)
    UserControl.FillColor() = New_FillColor
    PropertyChanged "FillColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,FillStyle
Public Property Get FillStyle() As Integer
Attribute FillStyle.VB_Description = "返回/设置一个 shape 控件的填充样式。"
    FillStyle = UserControl.FillStyle
End Property

Public Property Let FillStyle(ByVal New_FillStyle As Integer)
    UserControl.FillStyle() = New_FillStyle
    PropertyChanged "FillStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,FontSize
Public Property Get FontSize() As Single
Attribute FontSize.VB_Description = "指定给定层的每一行出现的字体大小(以磅为单位)。"
    FontSize = UserControl.FontSize
End Property

Public Property Let FontSize(ByVal New_FontSize As Single)
    UserControl.FontSize() = New_FontSize
    PropertyChanged "FontSize"
End Property
'
''注意！不要删除或修改下列被注释的行！
''MappingInfo=UserControl,UserControl,-1,Line
'Public Sub Line(ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single, ByVal Color As Long)
'    UserControl.Line (X1, Y1)-(X2, Y2), Color
'End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,MouseIcon
Public Property Get MouseIcon() As Picture
Attribute MouseIcon.VB_Description = "设置一个自定义鼠标图标。"
    Set MouseIcon = UserControl.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
    Set UserControl.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,MousePointer
Public Property Get MousePointer() As Integer
Attribute MousePointer.VB_Description = "返回/设置当鼠标经过对象某一部分时鼠标的指针类型。"
    MousePointer = UserControl.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As Integer)
    UserControl.MousePointer() = New_MousePointer
    PropertyChanged "MousePointer"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,OLEDrag
Public Sub OLEDrag()
Attribute OLEDrag.VB_Description = "以给定控件作为源，启动一个 OLE 拖/放事件。"
    UserControl.OLEDrag
End Sub

Private Sub UserControl_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent OLEDragDrop(Data, Effect, Button, Shift, x, Y)
End Sub

Private Sub UserControl_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, Y As Single, State As Integer)
    RaiseEvent OLEDragOver(Data, Effect, Button, Shift, x, Y, State)
End Sub