能。
不但可以无标题,还可以是任意形状。
Option Explicit
Const pi = 3.1415927
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '挂起该线程
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long '改变窗体形状
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long '创建椭圆
Dim i
Dim j
Dim Degree
Dim bdeg
Dim oldAngle
Dim oldPosx As Single
Dim oldPosy As Single
Dim mDown As Boolean
Dim dbd As Single
Private Sub Form_DblClick()
End
End Sub
Private Sub Form_Load()
SetWindowRgn Me.hWnd, CreateEllipticRgn(12, 12, (Me.Width / Screen.TwipsPerPixelX) - 8, (Me.Height / Screen.TwipsPerPixelY) - 8), True
Form_MouseMove vbRightButton, 0, 1200, 1200
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
mDown = False
oldPosx = X
oldPosy = Y
Form_MouseMove Button, Shift, X, Y
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form_MouseMove Button, Shift, X, Y
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Dim dx, dy, adeg, xdeg
Dim fixAngle
If Button Then
dx = (X - 1215)
dy = (Y - 1215)
If dx = 0 Then dx = 0.00001
If dy = 0 Then dy = 0.00001
xdeg = Atn(dy / dx)
If dx > 0 And dy < 0 Then adeg = 6.283 - (xdeg * -1) '+,-
If dx < 0 And dy < 0 Then adeg = 3.142 + (xdeg * 1) '-,-
If dx < 0 And dy > 0 Then adeg = 3.142 - (xdeg * -1) '-,+
If dx > 0 And dy > 0 Then adeg = (xdeg * 1) '+,+
bdeg = (adeg * 180 / pi)
If Not mDown Then
oldAngle = bdeg
mDown = True
dbd = Fix(bdeg)
End If
If Fix(bdeg) - dbd >= 0 Then
Label1.Caption = Fix(bdeg) - dbd & "?"
Else
Label1.Caption = 360 + Fix(bdeg) - dbd & "?"
End If
Label1.Caption = Fix(bdeg) & "?"
If Fix(oldAngle - bdeg) < 0 Then '
fixAngle = 360 - Fix(bdeg)
Else
fixAngle = Fix(oldAngle - bdeg)
End If
Label2.Caption = fixAngle
Cls
Me.DrawWidth = 2
Me.ForeColor = 0
For j = adeg To adeg + 130 Step 6
Me.ForeColor = RGB(210, 210, 210)
PSet ((Cos(j) * 945) + 1230, (Sin(j) * 945) + 1230)
Me.ForeColor = RGB(160, 160, 160)
PSet ((Cos(j) * 945) + 1215, (Sin(j) * 945) + 1215)
Next
Me.DrawWidth = 3
Me.ForeColor = vbRed
Line ((Cos(adeg) * 915) + 1215, (Sin(adeg) * 915) + 1215)-((Cos(adeg) * 970) + 1215, (Sin(adeg) * 970) + 1215)
PSet ((Cos(adeg) * 945) + 1215, (Sin(adeg) * 945) + 1215)
Me.DrawWidth = 1
Me.ForeColor = vbBlack
Me.ForeColor = RGB(210, 210, 210)
Circle (1225, 1225), 880
Me.ForeColor = RGB(180, 180, 180)
Circle (1210, 1210), 880
Me.ForeColor = RGB(140, 140, 140)
Me.DrawWidth = 2
Circle (1215, 1215), 1030
Me.ForeColor = RGB(210, 210, 210)
Me.DrawWidth = 1
Circle (1215, 1215), 1000
End If
End Sub
有难度
方法有多种,如果只是想去掉标题栏可以在form_load中添加如下代码(放在lngCalculator赋值语句后):
Dim lstyle As Long
lstyle = GetWindowLong(lngCalculator, gwl_style)
lstyle = lstyle And Not ws_caption
SetWindowLong lngCalculator, gwl_style, lstyle
你所需再添加的API和常数:
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nindex As Long) As Long
Private Const ws_caption = &HC0000
或者用CreateRoundRectRgn、CreateRectRgn等API截除掉标题栏。