Option Explicit
Private Const PI = 3.14159265358979
Private Const HALF_PI = 1.5707963267949
Private Const ROTATE_INTERVAL = 1
Dim PicAngle As Single
Dim MDX As Single, MDY As Single
Dim cx As Single, cy As Single
Dim CenterX As Single, CenterY As Single
Dim AL(1 To 1000000) As AngledLine
Dim CurLineID As Long
Private Type AngledLine
x1 As Single
y1 As Single
x2 As Single
y2 As Single
x3 As Single
y3 As Single
End Type
Public bDontRun As Boolean
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const MAGICX As Long = 30
Private Const MAGICY As Long = 48
Dim PixelsX As Long
Dim PixelsY As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
TOP As Long
Right As Long
Bottom As Long
End Type
Private DPI_MONITOR As Long
Private PixelsPerInchX As Long
Private PixelsPerInchY As Long
Dim startX As Single, startY As Single
Private hFrmDC As LongPtr
#Else
Private hFrmDC As Long
Private blnDraw As Boolean
Dim p_mb As POINTAPI
Dim p As POINTAPI
Private Const CWIDTH = 320
Private Const CHEIGHT = 240
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long
Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As LongPtr
Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As LongPtr
Private Declare PtrSafe Function Polyline Lib "gdi32" (ByVal hDC As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As LongPtr
Private Declare PtrSafe Function PolylineTo Lib "gdi32.dll" (ByVal hDC As LongPtr, lppt As POINTAPI, ByVal cCount As Long) As LongPtr
Private Declare PtrSafe Function Polygon Lib "gdi32" (ByVal hDC As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As LongPtr
Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
Private Declare PtrSafe Function Ellipse Lib "gdi32" (ByVal hDC As LongPtr, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As LongPtr
Private Declare PtrSafe Function AngleArc Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal dwRadius As Long, ByVal eStartAngle As Single, ByVal eSweepAngle As Single) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, pbmi As BITMAPINFO, ByVal iUsage As Long, ByVal ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hgdiobj As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal fnPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal IfdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As LongPtr
Private Const PS_SOLID = 0
Private Const PS_DASH = 1
Private Const PS_DOT = 2
Private Const PS_DASHDOT = 3
Private Const PS_DASHDOTDOT = 4
Private Const PS_NULL = 5
Private Const PS_INSIDEFRAME = 6
Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const OEM_CHARSET = 255
Private Const SHIFTJIS_CHARSET = 128
Private Const SYMBOL_CHARSET = 2
Private Const BALTIC_CHARSET = 186
Private Const CHINESEBIG5_CHARSET = 136
Private Const EASTEUROPE_CHARSET = 238
Private Const GREEK_CHARSET = 161
Private Const HANGEUL_CHARSET = 129
Private Const MAC_CHARSET = 77
Private Const RUSSIAN_CHARSET = 204
Private Const TURKISH_CHARSET = 162
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_OUTLINE_PRECIS = 8
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_TT_PRECIS = 4
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_EMBEDDED = 128
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_MASK = &HF
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_TO_PATH = 4097
Private Const CLIP_TT_ALWAYS = 32
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2
Private Const FF_DECORATIVE = 80
Private Const FF_DONTCARE = 0
Private Const FF_MODERN = 48
Private Const FF_ROMAN = 16
Private Const FF_SCRIPT = 64
Private Const FF_SWISS = 32
Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4
Private Const DT_DISPFILE = 6
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_METAFILE = 5
Private Const DT_LEFT = &H0
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0
Private Const DT_RASCAMERA = 3
Private Const DT_RASDISPLAY = 1
Private Const DT_RASPRINTER = 2
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const DIB_RGB_COLORS = 0
Private Const DIB_PAL_COLORS = 1
Private Const DIB_PAL_INDICES = 2
Private Const NULL_BRUSH = 5
Private Const BLACK_BRUSH = 4
Private Const DKGRAY_BRUSH = 3
Private Const GRAY_BRUSH = 2
Private Const HOLLOW_BRUSH = NULL_BRUSH
Private Const LTGRAY_BRUSH = 1
Private Const WHITE_BRUSH = 0
Private Const BLACK_PEN = 7
Private Const WHITE_PEN = 6
Private Const ANSI_FIXED_FONT = 11
Private Const ANSI_VAR_FONT = 12
Private Const DEVICE_DEFAULT_FONT = 14
Private Const DEFAULT_GUI_FONT = 17
Private Const OEM_FIXED_FONT = 10
Private Const SYSTEM_FONT = 13
Private Const SYSTEM_FIXED_FONT = 16
Private Const DEFAULT_PALETTE = 15
Private hUsrFrmDC As LongPtr
Private myDC0 As LongPtr, myDC1 As LongPtr
Private myBMP As LongPtr
Private myPen As LongPtr
Private myBrush As LongPtr
Private myFont As LongPtr
Private hdlPen As LongPtr
Private hdlBrush As LongPtr
#Else
Private hUsrFrmDC As Long
Private myDC0 As Long, myDC1 As Long
Private myBMP As Long
Private myPen As Long
Private myBrush As Long
Private myFont As Long
Private hdlPen As Long
Private hdlBrush As Long
Private myFntFamily As String
Private myRct As RECT
Private myPnt As POINTAPI
Private Type BITMAPFILEHEADER
bfType As String * 2
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
End Type
Private myBMPInf As BITMAPINFO, myBMPFLHdr As BITMAPFILEHEADER, myBMPBits() As Byte
Private myStrFile As String, iFileOut As Long
Private Sub UserForm_Initialize()
Call api_GetPPI
DPI_MONITOR = Application.InchesToPoints(1)
Dim hDC As LongPtr
#Else
Dim hDC As Long
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
hDC = GetDC(0)
PixelsPerInchX = GetDeviceCaps(hDC, LOGPIXELSX)
PixelsPerInchY = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
Me.Show
Call fCanvas_Create
End Sub
Private Sub btUserFrm_DrawLines_Click()
Dim i As Long
hUsrFrmDC = GetDC(GetActiveWindow)
Me.Repaint
For i = 1 To 10
DrawLine hUsrFrmDC, Rnd() * 15, Rnd() * 15, 300, (Me.InsideHeight * 4 / 3) - 8
Next i
End Sub
Private Sub DrawLine(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
Optional ByVal hPen As LongPtr)
#Else
Private Sub DrawLine(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
Optional ByVal hPen As Long)
Dim oPtTmp As POINTAPI
MoveToEx hDC, x1, y1, oPtTmp
LineTo hDC, x2, y2
Dim points(0 To 3) As POINTAPI
Dim retval As LongPtr
points(0).x = 100: points(0).y = 100
points(1).x = 200: points(1).y = 150
points(2).x = 0: points(2).y = 150
points(3) = points(0)
retval = Polyline(hDC, points(0), 4)
Dim Pts() As POINTAPI
ReDim Pts(0 To 3)
With Pts(0)
.x = 10
.y = 10
End With
With Pts(1)
.x = 100
.y = 100
End With
With Pts(2)
.x = 200
.y = 200
End With
With Pts(3)
.x = 1000
.y = 1000
End With
Polyline hDC, Pts(0), UBound(Pts) - LBound(Pts) + 1
Dim points_(0 To 2) As POINTAPI
Dim curpt As POINTAPI
retval = MoveToEx(hDC, 100, 100, curpt)
points_(0).x = 330: points_(0).y = 150
points_(1).x = 28: points_(1).y = 150
points_(2).x = 170: points_(2).y = 100
retval = PolylineTo(hDC, points_(0), 3)
End Sub
Private Sub DrawRectangle(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
Optional ByVal hPen As LongPtr, Optional ByVal hBrush As LongPtr)
#Else
Private Sub DrawRectangle(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
Optional ByVal hPen As Long, Optional ByVal hBrush As Long)
End Sub
Private Sub DrawEllipse(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
Optional ByVal hPen As LongPtr, Optional ByVal hBrush As LongPtr)
#Else
Private Sub DrawEllipse(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
Optional ByVal hPen As Long, Optional ByVal hBrush As Long)
End Sub
Private Sub btCanvas_New_Click()
Call fCanvas_Create
fCanvasToBMP
End Sub
Private Sub btCanvas_WhiteBackground_Click()
myPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255))
Call SelectObject(myDC1, myPen)
myBrush = GetStockObject(WHITE_BRUSH)
Call SelectObject(myDC1, myBrush)
Call Rectangle(myDC1, 0, 0, CWIDTH, CHEIGHT)
Call DeleteObject(myPen)
Call DeleteObject(myBrush)
fCanvasToBMP
End Sub
Private Function fPen(Optional ByVal LineType As Long = PS_SOLID, _
Optional ByVal PenWidth As Long = 0, _
Optional ByVal Color As Long = vbWhite) As Boolean
Dim lgRetVal As Long
myPen = CreatePen(LineType, PenWidth, Color)
lgRetVal = SelectObject(myDC1, myPen)
End Function
Private Function fBrush(Optional ByVal Color As Long = WHITE_BRUSH) As Boolean
Dim lgRetVal As Long
myBrush = GetStockObject(Color)
lgRetVal = SelectObject(myDC1, myBrush)
End Function
Private Sub btUserFrm_DrawPolyLine_Click()
myPen = CreatePen(PS_SOLID, 6, vbRed)
Call SelectObject(myDC1, myPen)
myBrush = GetStockObject(BLACK_BRUSH)
Call SelectObject(myDC1, myBrush)
Dim Pts() As POINTAPI
ReDim Pts(0 To 3)
With Pts(0)
.x = 10
.y = 10
End With
With Pts(1)
.x = 100
.y = 100
End With
With Pts(2)
.x = 200
.y = 200
End With
With Pts(3)
.x = 1000
.y = 1000
End With
Polyline myDC1, Pts(0), UBound(Pts) - LBound(Pts) + 1
Call DeleteObject(myPen)
Call DeleteObject(myBrush)
fCanvasToBMP
End Sub
Private Sub Command1_Click()
Dim i As Integer
i = 3
Call Draw_Shape(Image1, i)
End Sub
Private Sub btCanvas_DrawShapes_Click()
Call fPen(PS_SOLID, 0, vbWhite)
Call fBrush(vbWhite)
Call Rectangle(myDC1, 0, 0, CWIDTH, CHEIGHT)
Call DeleteObject(myPen)
Call DeleteObject(myBrush)
myPen = CreatePen(PS_SOLID, 6, vbRed)
Call SelectObject(myDC1, myPen)
myBrush = GetStockObject(BLACK_BRUSH)
Call SelectObject(myDC1, myBrush)
Call Ellipse(myDC1, 100, 110, 200, 210)
Call DeleteObject(myPen)
Call DeleteObject(myBrush)
myPen = CreatePen(PS_SOLID, 10, RGB(0, 0, 255))
Call SelectObject(myDC1, myPen)
myBrush = GetStockObject(GRAY_BRUSH)
Call SelectObject(myDC1, myBrush)
Call Rectangle(myDC1, 10, 50, 60, 100)
Call DeleteObject(myPen)
Call DeleteObject(myBrush)
myPen = CreatePen(PS_SOLID, 2, vbBlue)
Call SelectObject(myDC1, myPen)
Call MoveToEx(myDC1, 150, 50, myPnt)
Call LineTo(myDC1, 300, 50)
Call DeleteObject(myPen)
fCanvasToBMP
End Sub
Private Sub btCanvas_InsertText_Click()
myPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255))
Call SelectObject(myDC1, myPen)
myBrush = GetStockObject(WHITE_BRUSH)
Call SelectObject(myDC1, myBrush)
Call Rectangle(myDC1, 0, 0, CWIDTH, CHEIGHT)
Call DeleteObject(myPen)
Call DeleteObject(myBrush)
myFont = CreateFont(18, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SCRIPT, myFntFamily)
Call SelectObject(myDC1, myFont)
With myRct
.Left = 10
.TOP = 50
.Right = 310
.Bottom = 75
End With
Call SetTextColor(myDC1, RGB(255, 0, 0))
Call SetBkColor(myDC1, RGB(0, 0, 0))
Call DrawText(myDC1, "AIUEOKAKIKUKEKO", -1, myRct, DT_CENTER Or DT_SINGLELINE)
With myRct
.TOP = 70
.Bottom = 95
End With
Call SetTextColor(myDC1, RGB(255, 255, 255))
Call SetBkColor(myDC1, RGB(0, 255, 0))
Call DrawText(myDC1, "Sashisuseso Tatsutetsu to Naninune", -1, myRct, DT_CENTER Or DT_SINGLELINE)
Call DeleteObject(myFont)
myFont = CreateFont(24, 0, 0, 0, FW_BOLD, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SCRIPT, myFntFamily)
Call SelectObject(myDC1, myFont)
With myRct
.TOP = 90
.Bottom = 115
End With
Call SetTextColor(myDC1, RGB(0, 0, 255))
Call SetBkColor(myDC1, RGB(255, 0, 0))
Call DrawText(myDC1, "Hahifuheho", -1, myRct, DT_CENTER Or DT_SINGLELINE)
Call DeleteObject(myFont)
fCanvasToBMP
End Sub
Private Function fCanvas_Create()
myDC0 = GetDC(0)
myDC1 = CreateCompatibleDC(myDC0)
With myBMPInf.bmiHeader
.biSize = 40
.biWidth = CWIDTH
.biHeight = CHEIGHT
.biPlanes = 1
.biBitCount = 24
End With
myBMP = CreateDIBSection(myDC1, myBMPInf, 0, 0, 0, 0)
Call SelectObject(myDC1, myBMP)
End Function
Private Sub DeleteTmpBMP(ByVal strFile As String)
Dim MyFSO As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
If MyFSO.FileExists(strFile) = True Then MyFSO.DeleteFile strFile
Set MyFSO = Nothing
End Sub
Private Sub btCanvas_ExportToBMP_Click()
Call fCanvasToBMP
End Sub
Private Function fCanvasToBMP()
myStrFile = ThisWorkbook.Path & "\tmp00.bmp"
Call GetDIBits(myDC1, myBMP, 0, CHEIGHT, ByVal 0&, myBMPInf, 0)
ReDim myBMPBits(myBMPInf.bmiHeader.biSizeImage - 1)
Call GetDIBits(myDC1, myBMP, 0, CHEIGHT, myBMPBits(0), myBMPInf, 0)
iFileOut = FreeFile
Open myStrFile For Binary As
With myBMPFLHdr
.bfType = "BM"
.bfReserved1 = 0
.bfReserved2 = 0
.bfSize = Len(myBMPFLHdr) + Len(myBMPInf) + UBound(myBMPBits) + 1
.bfOffBits = Len(myBMPFLHdr) + Len(myBMPInf)
End With
Put
Put
Put
Close
Me.Image1.Picture = LoadPicture(myStrFile)
End Function
Private Sub UserForm_Terminate()
Call DeleteObject(myBMP)
Call DeleteObject(myDC1)
Call ReleaseDC(0, myDC0)
End Sub
Private Function Radians(ByVal Degrees As Single) As Single
Radians = Degrees * PI / 180
End Function
Private Function Degrees(ByVal Radians As Single) As Single
Degrees = Radians / PI * 180
End Function
Private Function InchesToPoints(valueInches As Single) As Single
InchesToPoints = Application.InchesToPoints(valueInches)
End Function
Private Function CmToPoints(valueCentimeters As Single) As Single
CmToPoints = Application.CentimetersToPoints(valueCentimeters)
End Function
Private Function PointsToCm(valuePoints As Single) As Single
PointsToCm = valuePoints / Application.CentimetersToPoints(1)
End Function
Private Function PointsToInches(valuePoints As Single) As Single
PointsToInches = valuePoints / Application.InchesToPoints(1)
End Function
Private Function PointsToPixels(valuePoints As Single, ByVal bHorizontal As Boolean) As Long
If bHorizontal Then
PointsToPixels = Application.ActiveWindow.PointsToScreenPixelsX(valuePoints)
Else
PointsToPixels = Application.ActiveWindow.PointsToScreenPixelsY(valuePoints)
End If
End Function
Private Sub GetPositionInScreeenPoints(ByVal Left As Double, ByVal TOP As Double, ByRef x As Double, ByRef y As Double)
Dim CurrentZoomRatio As Long
CurrentZoomRatio = ActiveWindow.Zoom / 100
x = ActiveWindow.PointsToScreenPixelsX(0) + Left * CurrentZoomRatio * PixelsPerInchX / DPI_MONITOR
x = VBA.Round(x, 0) * DPI_MONITOR / PixelsPerInchX
y = ActiveWindow.PointsToScreenPixelsY(0) + TOP * CurrentZoomRatio * PixelsPerInchY / DPI_MONITOR
y = VBA.Round(y, 0) * DPI_MONITOR / PixelsPerInchY
End Sub
Private Function api_GetPPI(Optional pbHorizontal As Boolean = True) As Long
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Dim hDC As LongPtr
#Else
Dim hDC As Long
hDC = GetDC(0)
If pbHorizontal <> True Then
api_GetPPI = GetDeviceCaps(hDC, LOGPIXELSY)
Else
api_GetPPI = GetDeviceCaps(hDC, LOGPIXELSX)
End If
hDC = ReleaseDC(0, hDC)
End Function
Private Sub sDrawLine(ByVal x1 As Single, ByVal y1 As Single, _
ByVal x2 As Single, ByVal y2 As Single)
Dim oPoint As POINTAPI
oPoint.x = x1
oPoint.y = y1
MoveToEx hFrmDC, x1, y1, p
LineTo hFrmDC, x2, y2
End Sub
Private Sub DrawCuboid(ByVal x As Single, _
ByVal y As Single, _
ByVal Width As Single, _
ByVal Depth As Single, _
ByVal Height As Single)
CenterX = x
CenterY = y
AngleLine (Depth / 2), Width, HALF_PI, CurLineID
AngleLine (Width / 2), Depth, PI, CurLineID, HALF_PI
AngleLine -(Depth / 2), Width, HALF_PI, CurLineID
AngleLine -(Width / 2), Depth, PI, CurLineID, HALF_PI
CenterY = y + Height
AngleLine (Depth / 2), Width, HALF_PI, CurLineID
AngleLine (Width / 2), Depth, PI, CurLineID, HALF_PI
AngleLine -(Depth / 2), Width, HALF_PI, CurLineID
AngleLine -(Width / 2), Depth, PI, CurLineID, HALF_PI
CenterY = y
AngleLineXY AL(1).x2, AL(1).y2, Height, PI, CurLineID
AngleLineXY AL(1).x3, AL(1).y3, Height, PI, CurLineID
AngleLineXY AL(2).x3, AL(2).y3, Height, PI, CurLineID
AngleLineXY AL(4).x3, AL(4).y3, Height, PI, CurLineID
End Sub
Private Sub AngleLineXY(x As Single, _
y As Single, _
LineLength As Single, _
AngleRAD As Single, _
LineID As Long, _
Optional Color As Long = vbBlack)
Dim x1 As Single
Dim y1 As Single
Dim x2 As Single
Dim y2 As Single
x1 = CenterX + x
y1 = CenterY + y
x2 = x1 + (Cos(AngleRAD - HALF_PI) * LineLength)
y2 = y1 + (Sin(AngleRAD - HALF_PI) * LineLength)
Stop
AL(LineID).x1 = x1 - CenterX
AL(LineID).y1 = y1 - CenterY
AL(LineID).x2 = x2 - CenterX
AL(LineID).y2 = y2 - CenterY
CurLineID = CurLineID + 1
End Sub
Private Sub AngleLine(ByVal RadiusLength As Single, _
ByVal LineLength As Single, _
ByVal AngleRAD As Single, _
ByRef LineID As Long, _
Optional ByVal ExtraPicAngle As Single)
Dim RPicAngle As Single
Dim x1 As Single
Dim y1 As Single
Dim x2 As Single
Dim y2 As Single
Dim x3 As Single
Dim y3 As Single
RPicAngle = Radians(PicAngle)
x1 = CenterX + (Cos(ExtraPicAngle + RPicAngle - HALF_PI) * RadiusLength)
y1 = CenterY + (Sin(ExtraPicAngle + RPicAngle - HALF_PI) * RadiusLength)
x2 = x1 + (Cos((RPicAngle) + AngleRAD - HALF_PI + PI) * (LineLength / 2))
y2 = y1 + (Sin((RPicAngle) + AngleRAD - HALF_PI + PI) * (LineLength / 2))
x3 = x1 + (Cos((RPicAngle) + AngleRAD - HALF_PI) * (LineLength / 2))
y3 = y1 + (Sin((RPicAngle) + AngleRAD - HALF_PI) * (LineLength / 2))
Stop
AL(LineID).x1 = x1 - CenterX
AL(LineID).y1 = y1 - CenterY
AL(LineID).x2 = x2 - CenterX
AL(LineID).y2 = y2 - CenterY
AL(LineID).x3 = x3 - CenterX
AL(LineID).y3 = y3 - CenterY
CurLineID = CurLineID + 1
End Sub
Private Sub Draw_Shape(PBox As Control, PNum As Integer)
Dim v(1 To 8) As POINTAPI, Rtn As Long
Dim DeltaX As Integer, DeltaY As Integer
Select Case PNum
Case 0
DeltaX = 0.05 * 55
DeltaY = 0.05 * 56
v(1).x = DeltaX: v(1).y = DeltaY
v(2).x = 55 - DeltaX: v(2).y = v(1).y
v(3).x = v(2).x: v(3).y = 56 - DeltaY
v(4).x = v(1).x: v(4).y = v(3).y
Rtn = Polygon(myDC1, v(1), 4)
Case 1
DeltaX = 0.3 * 55
DeltaY = 0.05 * 56
v(1).x = DeltaX: v(1).y = DeltaY
v(2).x = 55 - DeltaX: v(2).y = v(1).y
v(3).x = v(2).x: v(3).y = 56 - DeltaY
v(4).x = v(1).x: v(4).y = v(3).y
Rtn = Polygon(myDC1, v(1), 4)
Case 2
DeltaX = 0.05 * 55
DeltaY = 0.05 * 56
v(1).x = DeltaX: v(1).y = 56 - DeltaY
v(2).x = 0.5 * 55: v(2).y = DeltaY
v(3).x = 55 - DeltaX: v(3).y = v(1).y
Rtn = Polygon(myDC1, v(1), 3)
Case 3
DeltaX = 0.05 * 55
DeltaY = 0.05 * 56
v(1).x = DeltaX: v(1).y = 0.5 * 56
v(2).x = 0.25 * 55: v(2).y = DeltaY
v(3).x = 0.75 * 55: v(3).y = v(2).y
v(4).x = 55 - DeltaX: v(4).y = v(1).y
v(5).x = v(3).x: v(5).y = 56 - DeltaY
v(6).x = v(2).x: v(6).y = v(5).y
Rtn = Polygon(myDC1, v(1), 6)
Case 4
DeltaX = 0.05 * 55
DeltaY = 0.05 * 56
v(1).x = DeltaX: v(1).y = 0.3 * 56
v(2).x = 0.3 * 55: v(2).y = DeltaY
v(3).x = 0.7 * 55: v(3).y = v(2).y
v(4).x = 55 - DeltaX: v(4).y = v(1).y
v(5).x = v(4).x: v(5).y = 0.7 * 56
v(6).x = v(3).x: v(6).y = 56 - DeltaY
v(7).x = v(2).x: v(7).y = v(6).y
v(8).x = v(1).x: v(8).y = v(5).y
Rtn = Polygon(myDC1, v(1), 8)
End Select
End Sub
Private Sub sCubeSpinner3D()
Dim radi As Double
Dim box() As POINTAPI
radi = radi + 0.01
Dim i As Integer
End Sub