menu.frm

计算面积公式源代码

    If (RuntimeNumber = 0) Then  '如果第一次打开则显示
    
      RunTimeFiles(RuntimeNumber).Caption = "&" & CStr(RuntimeNumber + 1) & "  " & WFilename '动态显示部分
      RunTimeFiles(RuntimeNumber).Visible = True
      FileSep4.Visible = True
      WCompareString(RuntimeNumber) = WFilename                      '动态显示部分
      
      '显示图像部分和处理滚动条部分
      SourceX = 0: SourceY = 0             '源滚动部分的初值
      WSHScrol.Value = 0: WSVScrol.Value = 0
      Call DisplayPicture1(WFilename, WSPicture, WIPicture1, WIPicture2, WSHScrol, WSVScrol, Form1)
      
      RuntimeNumber = RuntimeNumber + 1            '记数部分
      FileClose.Enabled = True                     '显示关闭文件部分
    Else
        Wcompare = True: I = 0                     '比较的初值为False
        Do While (Wcompare And I < 4)
          WStringCompare = StrComp(WFilename, WCompareString(I), 0)
          If WStringCompare = 0 Then Wcompare = False   '表示找到相同的文件退出循环
          I = I + 1
        Loop
        
        If (Wcompare = True) Then        '如果不是第一次打开而且不是相同则加入
          
          Load RunTimeFiles(RuntimeNumber)   '动态显示部分
          RunTimeFiles(RuntimeNumber).Caption = "&" & CStr(RuntimeNumber + 1) & "  " & WFilename
          WCompareString(RuntimeNumber) = WFilename      '动态显示部分
          
          WIPicture2.Picture = LoadPicture()      '把目地图象清空
          wdPicture.Picture = LoadPicture()
          Form1.Frame2.Caption = WDString         '标题为“目的图象”
          
          '显示图像部分和处理滚动条部分
          SourceX = 0: SourceY = 0            '源滚动部分的初值
          WSHScrol.Value = 0: WSVScrol.Value = 0
          Call DisplayPicture1(WFilename, WSPicture, WIPicture1, WIPicture2, WSHScrol, WSVScrol, Form1)
          
          RuntimeNumber = RuntimeNumber + 1     '记数部分
        Else                             '如果相同打开则显示警告
          MsgBox "文件已打开，不能重复操作！", vbInformation, "警告"
        End If
    End If
  Else                                          '空文件的情况或打开文件小于6
    If (RuntimeNumber >= 4) Then
      RuntimeNumber = 4
      MsgBox "打开的文件数目，太多不再打开！", vbExclamation, "警告"
      Exit Sub
    Else
      MsgBox "不能打开空文件！", vbQuestion, "错误操作"
      Exit Sub
    End If
  End If
End Sub

Private Sub FileSaveas_Click()         '文件
   CommonDialog1.ShowSave
   If WSaveFileFlag = True Then
      SavePicture WIPicture2.Image, Form1.CommonDialog1.FileName
   Else
      MsgBox "不能存空图像！", vbInformation, "警告"
      Exit Sub
   End If
End Sub

Private Sub Form_Load()
  RuntimeNumber = 0        '关于打开文件数目的初始化
  WPath = "c:\WTemp.bmp"   '临时文件名
  WSaveFileFlag = False    '存盘标志为空
  WDString = "目的图象"    '目的图象的初值
  Frame2.Caption = WDString
End Sub



Private Sub HuiTwoImage_Click()      '二值图象
  Dim I, J As Integer
  Dim R, G, B As Integer
  Dim N As Integer               '关于进度条的记数
  Dim L As Long                  '亮度
  Dim WSBmpDc As Long
  Dim WSBmp As Long
  Dim WTwoValue As Integer       '阈值
  
  WTwoValue = WYuFuction2(WHuiArray)
  
  Screen.MousePointer = 11         '显示鼠标为漏斗状
  
  Form2.ProgressBar1.Min = 0                 '进度条的情况
  Form2.ProgressBar1.Max = WIPicture1.ScaleWidth
  Form2.Show
  Form2.Caption = "二值在处理..."
  Form1.Enabled = False
  Form2.ProgressBar1.Value = Form2.ProgressBar1.Min '进度条的情况
  
  N = 0                          '进度条初值
  
  WSBmp = CreateCompatibleBitmap(WIPicture2.hdc, WIPicture2.ScaleWidth, WIPicture2.ScaleHeight)
  WSBmpDc = CreateCompatibleDC(WIPicture2.hdc)
  SelectObject WSBmpDc, WSBmp
  
  BitBlt WSBmpDc, 0, 0, WIPicture2.ScaleWidth, WIPicture2.ScaleHeight, WIPicture2.hdc, 0, 0, &HCC0020
  
  For I = 0 To WIPicture2.ScaleWidth - 1                 '二值
   For J = 0 To WIPicture2.ScaleHeight - 1
        If WImage(0, I, J) > WTwoValue Then
           L = 255
        Else
           L = 0
        End If
        SetPixel WSBmpDc, I, J, RGB(Int(L), Int(L), Int(L))
      Next J
      N = N + 1
      Form2.ProgressBar1.Value = N
      DoEvents
  Next I
  
  BitBlt WIPicture2.hdc, 0, 0, WIPicture2.ScaleWidth, WIPicture2.ScaleHeight, WSBmpDc, 0, 0, &HCC0020
  
  Form2.Hide
  Form1.Enabled = True
  Screen.MousePointer = 0              '鼠标恢复正常
  
  '显示目的图像
  DestX = 0: DestY = 0
  WDHScrol.Value = 0: WDVScrol.Value = 0
  Call DisplayPicture2(wdPicture, WIPicture2, WDHScrol, WDVScrol, Form1)
  WSaveFileFlag = True      '可以存盘的标志为真
  
  Form1.Frame2.Caption = WDString & "(二值)"
  Form1.SetFocus
  
  Call DeleteDC(WSBmpDc)
  Call DeleteObject(WSBmp)
End Sub

Private Sub IndusArea_Click()           '面积测量
Dim area(0 To 1000) As Long
Dim p(0 To 300, 0 To 300) As Integer
Dim count As Integer
Dim I, J As Integer
Dim i1, j1 As Integer
Dim ij As Integer
Dim iij As Integer
Dim c As Long
Dim R As Integer
Dim corlor  As Integer
Dim condition As Boolean
Dim ltor(0 To 300, 0 To 300) As Integer
Screen.MousePointer = 11

For I = 2 To WSPicture.Height - 2
  For J = 2 To WSPicture.Width - 2
  c = WSPicture.Point(I, J)
  R = (c And &HFF)
    If R = 0 Then
    p(I, J) = 0
    End If
        If R <> 0 Then
        p(I, J) = -1
        End If
  Next
Next
count = 0
 For I = 2 To WSPicture.Height - 2
   For J = 2 To WSPicture.Width - 2
      If p(I, J) = 0 Then
        count = count + 1
        p(I, J) = count
        ij = p(I, J)
        If p(I - 1, J - 1) > -1 Then p(I - 1, J - 1) = ij
        If p(I - 1, J) > -1 Then p(I - 1, J) = ij
        If p(I - 1, J + 1) > -1 Then p(I - 1, J + 1) = ij
        If p(I, J + 1) > -1 Then p(I, J + 1) = ij
        If p(I + 1, J + 1) > -1 Then p(I + 1, J + 1) = ij
        If p(I + 1, J) > -1 Then p(I + 1, J - 1) = ij
        If p(I + 1, J - 1) > -1 Then p(I + 1, J - 1) = ij
        If p(I, J - 1) > -1 Then p(I, J - 1) = ij
        
        
        
        
      ElseIf p(I, J) > 0 Then
        ij = p(I, J)
        If p(I - 1, J - 1) > -1 Then p(I - 1, J - 1) = ij
        If p(I - 1, J) > -1 Then p(I - 1, J) = ij
        If p(I - 1, J + 1) > -1 Then p(I - 1, J + 1) = ij
        If p(I, J + 1) > -1 Then p(I, J + 1) = ij
        If p(I + 1, J + 1) > -1 Then p(I + 1, J + 1) = ij
        If p(I + 1, J) > -1 Then p(I + 1, J - 1) = ij
         If p(I + 1, J - 1) > -1 Then p(I + 1, J - 1) = ij
        If p(I, J - 1) > -1 Then p(I, J - 1) = ij
        
        
      End If
   Next
 Next
 For I = WSPicture.Height - 2 To 2 Step -1
   For J = WSPicture.Width - 2 To 2 Step -1
   
      If p(I, J) > 0 Then
        ij = p(I, J)
      
        If p(I + 1, J + 1) > -1 Then p(I + 1, J + 1) = ij
        If p(I, J + 1) > -1 Then p(I, J + 1) = ij
        If p(I - 1, J + 1) > -1 Then p(I - 1, J + 1) = ij
        If p(I - 1, J) > -1 Then p(I - 1, J) = ij
        If p(I - 1, J - 1) > -1 Then p(I - 1, J - 1) = ij
        If p(I, J - 1) > -1 Then p(I, J - 1) = ij
        If p(I + 1, J - 1) > -1 Then p(I + 1, J - 1) = ij
        If p(I + 1, J) > -1 Then p(I + 1, J - 1) = ij

      End If
   Next
 Next
  
  For I = 2 To WSPicture.Height - 2
     For J = 2 To WSPicture.Width - 2
      If p(I, J) > 0 Then
         ij = p(I, J)
         
         If (p(I - 1, J - 1) > 0) And (p(I - 1, J - 1) <> ij) Then
               iij = p(I - 1, J - 1)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If
        
         If (p(I - 1, J) > 0) And (p(I - 1, J) <> ij) Then
               iij = p(I - 1, J)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If
         If (p(I - 1, J + 1) > 0) And (p(I - 1, J + 1) <> ij) Then
               iij = p(I - 1, J + 1)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If
         If (p(I, J + 1) > 0) And (p(I, J + 1) <> ij) Then
               iij = p(I, J + 1)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If
         If (p(I + 1, J + 1) > 0) And (p(I + 1, J + 1) <> ij) Then
               iij = p(I + 1, J + 1)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If
         If (p(I, J - 1) > 0) And (p(I, J - 1) <> ij) Then
               iij = p(I, J - 1)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If
         If (p(I + 1, J) > 0) And (p(I + 1, J) <> ij) Then
               iij = p(I + 1, J)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If
         If (p(I + 1, J - 1) > 0) And (p(I + 1, J - 1) <> ij) Then
               iij = p(I + 1, J - 1)
              For i1 = 2 To WSPicture.Height - 2
                For j1 = 2 To WSPicture.Width - 2
                    If p(i1, j1) = iij Then p(i1, j1) = ij
                Next
              Next
         End If

      End If
     Next
  Next
   
   
   For I = 2 To WSPicture.Height - 2
      For J = 2 To WSPicture.Width - 2
      If p(I, J) > 0 Then
       area(p(I, J)) = area(p(I, J)) + 1
       
      End If
      Next
   Next
 
wdPicture.Picture = WSPicture.Picture
  J = 0
For I = 0 To 1000
    If area(I) > 50 Then
     J = J + 1
    wdPicture.Print "面积" + CStr(J) + ":" + CStr(area(I))

    End If
Next

Screen.MousePointer = 0
End Sub

Private Sub IndusCircle_Click()
Dim I As Single, J As Single
Dim t As Single
Dim c1 As Long
Dim h1 As Long
Dim r1 As Integer, g1 As Integer, b1 As Integer
Dim c2 As Long
Dim h2 As Long
Dim a(0 To 1000, 0 To 1000) As Integer
Dim r2 As Integer, g2 As Integer, b2 As Integer
Const dx As Integer = 1
Const dy As Integer = 1
MousePointer = 11
'
For I = 2 To WSPicture.Width - 2
  For J = 2 To WSPicture.Height - 2
c1 = WSPicture.Point(I, J)
r1 = (c1 And &HFF)
g1 = (c1 And 65280) \ 256
b1 = (c1 And &HFF0000) \ 65536
h1 = (r1 + g1 + b1) \ 3
c2 = WSPicture.Point(I, J + dy)
r2 = (c2 And &HFF)
g2 = (c2 And 65280) \ 256
b2 = (c2 And &HFF0000) \ 65536
h2 = (r2 + g2 + b2) \ 3
If (h1 - h2) > 10 Then
a(I, J + dy) = 1
End If
If h2 - h1 > 12 Then
a(I, J) = 1
End If
Next
Next
'
For J = 2 To WSPicture.Height - 2
  For I = 2 To WSPicture.Width - 2
c1 = WSPicture.Point(I, J)
r1 = (c1 And &HFF)
g1 = (c1 And 65280) \ 256
b1 = (c1 And &HFF0000) \ 65536
h1 = (r1 + g1 + b1) \ 3
c2 = WSPicture.Point(I + dx, J)
r2 = (c2 And &HFF)
g2 = (c2 And 65280) \ 256
b2 = (c2 And &HFF0000) \ 65536
h2 = (r2 + g2 + b2) \ 3
If (h1 - h2) > 12 Then
a(I + dx, J) = 1
End If
If h2 - h1 > 12 Then
a(I, J) = 1
End If
Next
Next
'
For I = 2 To wdPicture.Width - 2
 For J = 2 To wdPicture.Height - 2
 If a(I, J) = 1 Then
 
 t = t + 1
 
 End If
Next
Next
wdPicture.Picture = WSPicture.Picture
wdPicture.Print "周长=" + CStr(t)

MousePointer = 0

End Sub

Private Sub IndusSign_Click()           '标号处理

HuiTwoImage_Click



End Sub