module-menu.bas

计算面积公式源代码

Attribute VB_Name = "Module1"
Option Explicit
Public WPath As String
Public WImage() As Integer      '图象象素点的数组
Public WDString As String            '显示目的图象的名字
Public WSaveFileFlag As Boolean      '可以存盘的标志
Public WHuiArray(255) As Long     '图象的灰度
Public WHuiMax As Long            '灰度的最大值
Public WHuiYuValue1 As Integer      '灰度阈值
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nwidth As Long, ByVal nheight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public 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
Public Declare Function StretchBlt Lib "gdi32" (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 ysrcwidth As Long, ByVal nsrcheight As Long, ByVal dwrop As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

  Sub DisplayPicture1(DFilename As String, DSPicture1 As PictureBox, DIPicture1 As PictureBox, DIPicture2 As PictureBox, DHScrol1 As HScrollBar, DVScrol1 As VScrollBar, DForm1 As Form)
      Dim I As Integer
      Dim J As Integer
      Dim R As Integer, G As Integer, B As Integer
      Dim DReadPixel As Long
      Dim WDBmp As Long
      Dim WDBmpDc As Long
      
      DSPicture1.ScaleMode = 3               '显示图像部分
      DIPicture1.ScaleMode = 3
      
      DSPicture1.AutoRedraw = True
      DIPicture1.Picture = LoadPicture(DFilename)
      DIPicture2.Picture = LoadPicture(DFilename)      'wwwwwwwwwwwwwwww
      DSPicture1.Picture = DIPicture1.Picture '显示图像部分
      DForm1.Refresh
      
      If DSPicture1.ScaleWidth < DIPicture1.ScaleWidth Then '处理滚动条部分
         DHScrol1.Enabled = True
      Else
         DHScrol1.Enabled = False
      End If
      If DSPicture1.ScaleHeight < DIPicture1.ScaleHeight Then
         DVScrol1.Enabled = True
      Else
         DVScrol1.Enabled = False
      End If
      DHScrol1.Min = 0
      DHScrol1.Max = DIPicture1.ScaleWidth - DSPicture1.ScaleWidth
      DVScrol1.Min = 0
      DVScrol1.Max = DIPicture1.ScaleHeight - DSPicture1.ScaleHeight '处理滚动条部分
      
      Screen.MousePointer = 11
      DForm1.Frame1.Caption = "正在读图像..."
      Form1.Refresh
      
      ReDim WImage(2, DIPicture1.ScaleWidth - 1, DIPicture1.ScaleHeight - 1) As Integer '生成动态数组
      
      WDBmp = CreateCompatibleBitmap(DIPicture1.hdc, DIPicture1.ScaleWidth, DIPicture1.ScaleHeight)
      WDBmpDc = CreateCompatibleDC(DIPicture1.hdc)
      SelectObject WDBmpDc, WDBmp
      
      BitBlt WDBmpDc, 0, 0, DIPicture1.ScaleWidth, DIPicture1.ScaleHeight, DIPicture1.hdc, 0, 0, &HCC0020
      
      For I = 0 To (DIPicture1.ScaleWidth - 1)       '读象素点
        For J = 0 To (DIPicture1.ScaleHeight - 1)

        DReadPixel = GetPixel(WDBmpDc, I, J)
        R = DReadPixel Mod 256
        G = (DReadPixel And &HFF00FF00) \ 256
        B = (DReadPixel And &HFF0000) \ 65536
        WImage(0, I, J) = R
        WImage(1, I, J) = G
        WImage(2, I, J) = B
       Next J
      Next I
      
      Call DeleteDC(WDBmpDc)
      Call DeleteObject(WDBmp)
      
      Screen.MousePointer = 0
      DForm1.Frame1.Caption = "源图像"
 End Sub

Sub DisplayPicture2(DSPicture2 As PictureBox, DIPicture2 As PictureBox, DHScrol2 As HScrollBar, DVScrol2 As VScrollBar, DForm2 As Form)
      DSPicture2.ScaleMode = 3               '显示图像部分
      DIPicture2.ScaleMode = 3
      
      DSPicture2.AutoRedraw = True
      DSPicture2.Picture = DIPicture2.Image    'www
      DForm2.Refresh                         '显示图像部分
      
      If DSPicture2.ScaleWidth < DIPicture2.ScaleWidth Then '处理滚动条部分
         DHScrol2.Enabled = True
      Else
         DHScrol2.Enabled = False
      End If
      If DSPicture2.ScaleHeight < DIPicture2.ScaleHeight Then
         DVScrol2.Enabled = True
      Else
         DVScrol2.Enabled = False
      End If
      DHScrol2.Min = 0
      DHScrol2.Max = DIPicture2.ScaleWidth - DSPicture2.ScaleWidth
      DVScrol2.Min = 0
      DVScrol2.Max = DIPicture2.ScaleHeight - DSPicture2.ScaleHeight '处理滚动条部分
      
 End Sub
 
 Function WYuFuction1(WH() As Long) As Integer
   Dim YuAver As Long
   Dim WGai(255) As Single
   Dim YuArray(255) As Double
   Dim WArray(255) As Double
   Dim QArray(255) As Double
   Dim WTemp As Double
   Dim QMax As Double
   Dim WSum As Double
   Dim I As Integer, J As Integer, Position As Integer
   
   Screen.MousePointer = 11
   
   For I = 0 To 255
       WSum = WSum + WH(I)
   Next I
   
   For I = 0 To 255
       WGai(I) = WH(I) / WSum
   Next I
   
   For I = 1 To 255
      YuAver = YuAver + (I - 1) * WGai(I)
   Next I
   
   QMax = 0
   For I = 1 To 255
      For J = 1 To I
       YuArray(I) = YuArray(I) + (J - 1) * WGai(J)
       WArray(I) = WArray(I) + WGai(J)
      Next J
      WTemp = YuAver * WArray(I) - YuArray(I)
      WTemp = WTemp * WTemp
      If WTemp <> 0 Then QArray(I) = WTemp / (WArray(I) * (1 - WArray(I)))
      If QArray(I) > QMax Then
        QMax = QArray(I)
        Position = I
      End If
   Next I
   
   Screen.MousePointer = 0
   
   WYuFuction1 = Position - 1
 End Function
 
 Function WYuFuction2(WH() As Long) As Integer
 Dim S1(255) As Long, S2(255) As Long
 Dim I As Integer, J As Integer
 Dim N1 As Integer, N2 As Integer
 Dim WImageHui() As Integer
 Dim Width As Integer, Height As Integer
 Dim Temp As Long
 Dim Wmax1 As Long, Wmax2 As Long
 Dim Position1 As Integer, Position2 As Integer

 Width = Form1.WIPicture1.ScaleWidth - 1 + 2
 Height = Form1.WIPicture1.ScaleHeight - 1 + 2
 ReDim WImageHui(Width, Height)
 
 Screen.MousePointer = 11
 
 
 For I = 0 To Form1.WIPicture1.ScaleWidth - 1
   For J = 0 To Form1.WIPicture1.ScaleHeight - 1
   WImageHui(I + 2, J + 2) = WImage(0, I, J)
   Next J
 Next I
 
 For I = 1 To Form1.WIPicture1.ScaleWidth - 1
  For J = 1 To Form1.WIPicture1.ScaleHeight - 1
    For N1 = -1 To 1
     For N2 = -1 To 1
       Temp = WImageHui(I, J) - WImageHui(I + N1, J + N2)
       If Temp >= 0 Then
         S1(WImageHui(I, J)) = S1(WImageHui(I, J)) + Temp
       Else
         S2(WImageHui(I, J)) = S2(WImageHui(I, J)) + Temp
       End If
     Next N2
    Next N1
  Next J
 Next I
 
 Wmax1 = 0: Wmax2 = 0
 For I = 0 To 255
   If S1(I) > Wmax1 Then
      Wmax1 = S1(I)
      Position1 = I
   End If
   If Abs(S2(I)) > Wmax2 Then
      Wmax2 = Abs(S2(I))
      Position2 = I
   End If
 Next I
 
 Screen.MousePointer = 0
 
 WYuFuction2 = Int((Position1 + Position2) / 2)
 End Function
 
Sub Scanhao(WI() As Long, I As Integer, J As Integer, WHao As Long)
  If WImage(0, I, J) = 255 Or WI(I, J) = WHao Then
     Exit Sub
  Else
     WI(I, J) = WHao
     Call Scanhao(WI, I - 1, J, WHao)
     Call Scanhao(WI, I + 1, J, WHao)
     Call Scanhao(WI, I, J - 1, WHao)
     Call Scanhao(WI, I, J + 1, WHao)
  End If
End Sub