Es una funcion que hice para ver de manera grafica poligonos y sacar su area apotema, etc. conociendo solamente la medida de un lado.
si hay algun error en la supresion/eliminacion de objetos favor de avisarme
'Autor: Xmbeat (JHCC)
'e-mail: xmbeat:-com, xmbeat@yahoo.com
'Fecha: 15 de marzo del 2010
'Descripcion: Funcion para dibujar, calcular,y sacar medidas de los poligonos regulares _
atravez solamente de su medida de un lado del poligono
'You can distribute the code freely without eliminating this commentaries
Option Explicit
Private Declare Function SetPolyFillMode Lib "gdi32" (ByVal hdc As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Type Coord
X As Long
Y As Long
End Type
Private Type Poligono
Area As Double
Apotema As Double
MedidaAnguloInterno As Double
Perimetro As Double
Finished As Boolean
End Type
Private Function DrawPoligonRegular(ByVal hdc As Long, ByVal Color As Long, ByVal BorderColor As Long, NumLados As Long, MedLad As Double, Xi As Long, Yi As Long, Optional Rotation As Long) As Poligono
Dim i As Double
Dim mAngInt As Double
Dim Area As Double
Dim Perimetro As Double
Dim Apotema As Double
Dim AngI As Double
Dim A As Double
Dim B As Double
Dim nTri As Long
Dim Count As Long
Dim RGN As Long
Dim bColor As Long
Dim Pen As Long
Dim Vertice() As Coord
On Error GoTo Fin
If NumLados < 3 Then Err.Raise 1
nTri = NumLados - 2 'numero de triangulos por vertice (si los trazamos en una hoja _
nos damos cuenta de esta logica).
mAngInt = nTri * 180 / NumLados 'medida de cada angulo interno (un triangulo _
tiene 180 grados y como tenemos el total de triangulos, entoces se hace esto).
AngI = 180 - mAngInt 'si trazamos una linea recta del _
centro del poligono a cada vertice del poligono forman angulos iguales, _
y es aqui donde almacenamos la medida de esos angulos ().
A = MedLad / 2 'Aqui va el Cateto Opuesto del triangulo rectangulo _
formado por la linea del centro al vertice, y del vertice a la mitad de la distancia _
del vertice inmediato.
Apotema = A / (Seno(90 - (mAngInt / 2))) 'quiero aclarar que no me acuerdo de si _
el Apotema es la distancia del centro al vertice o si es del centro a la mitad _
de un lado, y lo puse que es al vertice, corrijan si me equivoco, _
(de cualquier forma seria la hipotenusa de nuestro triangulo formado).
B = Sqr(Apotema ^ 2 - A ^ 2) 'sacamos el Cateto Adyacente, con clasico teorema de pitagoras
Perimetro = NumLados * MedLad 'perimetro seria lo mas sencillo...
Area = ((A * B) / 2) * NumLados * 2 'como ya tenemos las medidas de los catetos _
entoces los multiplicamos, y los dividimos entre 2(Formula del triangulo) y _
despues los multiplicamos por el doble de el total de lados (ya que nuestro _
triangulo fue dividido entre 2 inicialmente para convertirlo en triangulo rectangulo).
ReDim Vertice(1 To NumLados)
For i = Rotation To 360 + Rotation Step AngI
If Count < NumLados Then
Count = Count + 1
Vertice(Count).X = Xi - (Seno(i) * Apotema)
Vertice(Count).Y = Yi - (Seno(i, True) * Apotema)
End If
'MoveToEx hdc, Xi - (Seno(i) * Apotema), Yi - (Seno(i, True) * Apotema), 0
'LineTo hdc, Xi - (Seno(i + AngI) * Apotema), Yi - (Seno(i + AngI, True) * Apotema)
Next
Call OleTranslateColor(Color, 0, Color)
Call OleTranslateColor(BorderColor, 0, BorderColor)
RGN = CreatePolygonRgn(Vertice(1), NumLados, 2)
bColor = CreateSolidBrush(Color)
Pen = CreatePen(0, 2, BorderColor)
Call FillRgn(hdc, RGN, bColor)
Call SetPolyFillMode(hdc, 2)
Call DeleteObject(SelectObject(hdc, Pen))
Call Polygon(hdc, Vertice(1), NumLados)
Call DeleteObject(RGN)
Call DeleteObject(bColor)
Call DeleteObject(Pen)
Fin:
With DrawPoligonRegular
.Apotema = Apotema 'si me equivoque entonces seria B
.Area = Area
.MedidaAnguloInterno = mAngInt
.Perimetro = Perimetro
.Finished = Not CBool(Err.Number)
End With
End Function
'Esto es solo para convertir de grados a radianes
Private Function Seno(Angulo As Double, Optional isCoseno As Boolean) As Double
Const Pi As Double = 3.141592
If Not isCoseno Then
Seno = Sin((Angulo * Pi * 2) / 360)
Else
Seno = Cos((Angulo * Pi * 2) / 360)
End If
End Function
Private Sub Form_Load()
Me.ScaleMode = vbPixels
Me.AutoRedraw = True
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Figura As Poligono
Me.Cls
Figura = DrawPoligonRegular(Me.hdc, RGB(255 / Me.ScaleWidth * X, 255 / Me.ScaleHeight * Y, 255 / Me.ScaleWidth * (Me.ScaleWidth - X)), _
Me.ForeColor, CLng(8 / Me.ScaleWidth * X + 3), CLng(Y), Me.ScaleWidth / 2, Me.ScaleHeight / 2, CLng(360 / Me.ScaleWidth * X))
With Figura
If Figura.Finished Then
Me.Print " Area: " & .Area
Me.Print " Perimetro: " & .Perimetro
Me.Print " Medida de Angulo Interno: " & .MedidaAnguloInterno
Me.Print " Apotema: " & .Apotema
Else 'esto es si la figura fue una linea o un punto sin dimensiones
Me.Print " Ocurrio un error mientras se dibujaba la figura"
End If
End With
Me.Refresh
End Sub
