ui123

回復 6# stillfish00

stillfish00大 好神，原來那是C 語言喔!

竟然可以改寫成VBA~真是厲害耶~

也謝謝ML089的參與^^~

stillfish00

回復 10# ML089
自訂函數

1. Function PolyArea(rngPoly As Range)
   
2.     Dim i As Long, j As Long
   
3.     Dim pix As Double, piy As Double
   
4.     Dim pjx As Double, pjy As Double
   
5.     Dim arPoly, area As Double
   
6.         
   
7.     arPoly = rngPoly.Value
   
8.     If UBound(arPoly, 2) <> 2 _
   
9.         Or arPoly(1, 1) <> arPoly(UBound(arPoly), 1) _
   
10.         Or arPoly(1, 2) <> arPoly(UBound(arPoly), 2) Then PolyArea = CVErr(xlErrRef): Exit Function
    
11.    
    
12.     area = 0
    
13.     For i = 1 To UBound(arPoly) - 1
    
14.         j = i + 1
    
15.         pix = arPoly(i, 1): piy = arPoly(i, 2)
    
16.         pjx = arPoly(j, 1): pjy = arPoly(j, 2)
    
17.         
    
18.         area = area + pix * pjy
    
19.         area = area - piy * pjx
    
20.     Next
    
21.     PolyArea = Abs(area) / 2
    
22. End Function

複製代碼

ML089

回復 12# stillfish00


收到了，感謝萬分
初步測試 OK

我們工程設計要算一些面積、形心、慣性矩Ix、 Iy、Ixy 等
程式都是DOS時期FORTRAN寫的，在WIN7、WIN8系統無法執行(越來越不相容)。
剛想轉為EXCEL VBA來處理，看來你已經幫我完成第一步了，感謝。

ui123

回復 12# stillfish00
stillfish00大 超厲害，真是天才耶~
我好好的研究一下，真的謝謝!   相信以後你有需要，別人也一定會幫你的^^~

ui123

b]回復 12# stillfish00

stillfish00 大您好，我剛剛用了一下你的自訂函數(第一次用這個)
但我不知道怎麼用，那個函數沒有說明?! 無法判出，如附件，拜託教教我<(_ _)>
還是有其他人會用了? ML089大?  感恩~
P.S.我還無法下載檔案

落點問題_判斷例子_.rar (17.73 KB)

用不出來
下載次數: 11

2013-11-14 19:53

ML089

回復 15# ui123

程式放在 Module1
A區面積 =PolyArea(C4:D8)

ui123

回復 16# ML089

ML089 大~  O4 儲存和下面的公式怎麼填，無法判出ABC區???，拜託幫我看一下，謝謝你^^
公式已放在裡面了，如附件(1小時回復3次用光了 :'( )
落點問題_判斷例子_try2.rar (18.36 KB)

下載次數: 9

2013-11-14 20:17

ui123

回復 12# stillfish00
成功了，判定出ABC區了 ~Ya^^   謝謝stillfish00大 及ML089大

問一下stillfish00大 及ML089大
1)包含點在ABC邊緣線上怎麼辦?(採取如果剛好在重疊的線上，取較小那一個(A<B<C)，例如，剛好在A區及B區交接線上，算A區的)
2)這個可以用在多邊形嗎? 有些"不規則的多邊形"呢?
3)還是不懂 A區面積 =PolyArea(C4:D8) 是要做什麼?
感謝萬分<(_ _)>

ui123

回復 12# stillfish00

關於剛剛的問題 for stillfish00大 及ML089大

1)包含點在ABC邊緣線上怎麼辦?(採取如果剛好在重疊的線上，取較小那一個(A<B<C)，例如，剛好在A區及B區交接線上，算A區的)
    Ans:重疊線上，會判皆沒再ABC區上

2)這個可以用在多邊形嗎? 有些"不規則的多邊形"呢?
    Ans:"應用性非常廣"，且可以對任何多邊形無限增加區域~超級厲害

3)還是不懂 A區面積 =PolyArea(C4:D8) 是要做什麼?
    Ans:還是不懂這要做什麼 @@ 可以解說一下功能嗎? 感恩

stillfish00大，可以想出判重疊線嗎?
缺臨門一腳了!
如果重疊線可判出，就非常"完美了"，不然會漏判掉很多線上點~
剛剛使用心得，超實用 再次謝謝  stillfish00大

stillfish00

回復 19# ui123
修改如下，可含邊上的點，有優先順序(靠前的優先)
區域不限ABC三區可在參數自行增加，但要依參數順序。

1. Function pointInPoly(ptx As Double, pty As Double, arPoly) As Boolean
   
2.     Dim i As Long, j As Long
   
3.     Dim pix As Double, piy As Double
   
4.     Dim pjx As Double, pjy As Double
   
5.    
   
6.     For i = 1 To UBound(arPoly) - 1
   
7.         j = i + 1
   
8.         pix = arPoly(i, 1): piy = arPoly(i, 2)
   
9.         pjx = arPoly(j, 1): pjy = arPoly(j, 2)
   
10.         
    
11.         '多邊形邊上
    
12.         If (pix - ptx) * (pjy - pty) - (piy - pty) * (pjx - ptx) = 0 And _
    
13.             (pix - ptx) * (pjx - ptx) + (piy - pty) * (pjy - pty) <= 0 Then _
    
14.         pointInPoly = True: Exit Function
    
15.         
    
16.         '多邊形內部
    
17.         If Not (piy > pty) = (pjy > pty) Then
    
18.             If ptx < (pjx - pix) * (pty - piy) / (pjy - piy) + pix Then pointInPoly = Not pointInPoly
    
19.         End If
    
20.     Next
    
21. End Function
    
22. 
    
23. Function RegionABC(x As Double, y As Double, ParamArray polyRegion())
    
24.     '3rd參數為A區，4th參數為B區。。。依此類推，越靠前的優先。
    
25.     Dim i As Long, arPoly
    
26.         
    
27.     For i = LBound(polyRegion) To UBound(polyRegion)
    
28.         arPoly = polyRegion(i).Value
    
29.         
    
30.         If UBound(arPoly, 2) <> 2 _
    
31.             Or arPoly(1, 1) <> arPoly(UBound(arPoly), 1) _
    
32.             Or arPoly(1, 2) <> arPoly(UBound(arPoly), 2) Then RegionABC = CVErr(xlErrRef): Exit Function
    
33.         
    
34.         If pointInPoly(x, y, arPoly) Then
    
35.             RegionABC = Chr(65 + i - LBound(polyRegion))    '依順位顯示A，B，C，D
    
36.             Exit Function
    
37.         End If
    
38.     Next i
    
39.     RegionABC = "不在範圍內"
    
40. End Function

複製代碼