Private Const LF_FACESIZE = 32 Private Const DEFAULT_CHARSET = 1Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPrivate Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(0 To LF_FACESIZE - 1) As Byte End Type'Const PI = 3.14159265359Private Type POINTAPI X As Long Y As Long End TypePrivate Const PI As Single = 3.14159265359879 Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long Dim Ptg(9) As POINTAPIPrivate Sub Command1_Click() Dim BaseX As Integer, BaseY As Integer Dim printX As Integer Dim printY As Integer Dim printAngle As Integer Dim printR As Integer Dim printR2 As Integer Dim printFontHeight As Single Dim printFontWidth As Single Dim sngRatio As Single ' Picture1.AutoRedraw = False Picture1.AutoRedraw = True Picture1.Cls Picture1.ScaleMode = 3 Picture1.DrawWidth = 1 Picture1.BackColor = vbBlack BaseX = Me.Picture1.ScaleWidth / 2 BaseY = Me.Picture1.ScaleHeight / 6 * 3 printR = HScroll1.Value sngRatio = 0.3 printFontWidth = printR * PI / 20 / Len(Text1) * sngRatio '* HScroll1.Value / HScroll1.Max printFontHeight = printFontWidth * 2 '* HScroll1.Value / HScroll1.Max printR2 = printR + printFontHeight * 10
' Picture1.RefreshEnd Sub '要一个按钮一个pictureboxPrivate Sub sub_PrintStar(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _ , ByVal intPrintR As Integer) Dim tri(2) As POINTAPI Dim a As Single, nA As Single Dim rA As Single, rB As Single Dim cX As Long, cY As Long cX = sigCurrentX cY = sigCurrentY rA = intPrintR rB = rA * (Sin(18 * PI / 180) / Sin(126 * PI / 180)) a = 36 * PI / 180 tri(0).X = 0: tri(0).Y = -rA tri(1).X = -rB * Sin(a): tri(1).Y = -Cos(a) * rB tri(2).X = rB * Sin(a): tri(2).Y = -Cos(a) * rB Dim i As Integer, j As Integer Dim t(2) As POINTAPI Dim c(4) As Long ' c(0) = vbRed ' c(1) = vbBlue ' c(2) = vbYellow ' c(3) = vbGreen ' c(4) = RGB(255, 0, 255) c(0) = vbRed c(1) = vbRed c(2) = vbRed c(3) = vbRed c(4) = vbRed For i = 0 To 4 nA = 2 * PI / 5 * i For j = 0 To 2 t(j).X = tri(j).X * Cos(nA) + tri(j).Y * Sin(nA) + cX t(j).Y = -tri(j).X * Sin(nA) + tri(j).Y * Cos(nA) + cY Next j Ptg(i + 5) = t(0) Ptg(i) = t(1) drawPoly t, c(i) Next i drawPoly Ptg, vbRed, 5 End SubPrivate Sub drawPoly(p() As POINTAPI, Optional ByVal fillCol As Long, Optional ByVal nC As Long = 3) Picture1.FillStyle = 0 Picture1.FillColor = fillCol Polygon Picture1.hdc, p(0), nC End SubPrivate Sub Form_Load() Picture1.BackColor = vbWhite Picture1.ForeColor = vbRed Text1.Text = "中华人民共和国水电部节水办公室" Text2.Text = "灌水专用章" HScroll1.Value = 100 HScroll1.SmallChange = 2 HScroll1.LargeChange = 20 HScroll1.Min = 50 HScroll1.Max = 150 End SubPrivate Sub HScroll1_Change() Command1_Click Label1.Caption = HScroll1.Value End SubPrivate Sub HScroll1_Scroll() Command1_Click End Sub
Private Const DEFAULT_CHARSET = 1Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPrivate Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(0 To LF_FACESIZE - 1) As Byte
End Type'Const PI = 3.14159265359Private Type POINTAPI
X As Long
Y As Long
End TypePrivate Const PI As Single = 3.14159265359879
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Dim Ptg(9) As POINTAPIPrivate Sub Command1_Click()
Dim BaseX As Integer, BaseY As Integer
Dim printX As Integer
Dim printY As Integer
Dim printAngle As Integer
Dim printR As Integer
Dim printR2 As Integer
Dim printFontHeight As Single
Dim printFontWidth As Single
Dim sngRatio As Single
' Picture1.AutoRedraw = False
Picture1.AutoRedraw = True
Picture1.Cls
Picture1.ScaleMode = 3
Picture1.DrawWidth = 1 Picture1.BackColor = vbBlack
BaseX = Me.Picture1.ScaleWidth / 2
BaseY = Me.Picture1.ScaleHeight / 6 * 3
printR = HScroll1.Value
sngRatio = 0.3
printFontWidth = printR * PI / 20 / Len(Text1) * sngRatio '* HScroll1.Value / HScroll1.Max
printFontHeight = printFontWidth * 2 '* HScroll1.Value / HScroll1.Max
printR2 = printR + printFontHeight * 10
Picture1.FillStyle = 0
Picture1.FillColor = vbWhite Picture1.DrawWidth = 6 '/ HScroll1.Max * HScroll1.Value
Picture1.Circle (BaseX, BaseY), printR2 * 1.3, vbRed ', , 0, 1
Picture1.DrawWidth = 2 '/ HScroll1.Max * HScroll1.Value
Picture1.Circle (BaseX, BaseY), printR2 * 1.2, vbRed ', , 0, 1 For i = 0 To Len(Text1) - 1
printX = BaseX + printR2 * Sin(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) * (1 - sngRatio) / 2 * 0.5)
printY = BaseY - printR2 * Cos(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) * (1 - sngRatio) / 2 * 0.5)
printAngle = Int(90 - i * 180 / Len(Text1) - 180 / Len(Text1) / 2)
Call sub_RevolvePrint(printX, printY, printAngle, Mid(Text1, i + 1, 1), printFontHeight, printFontWidth)
Next i Dim sngWidth As Single
sngWidth = printFontWidth * Len(Text2) * 30 * 1.37
Call sub_RevolvePrint(BaseX - sngWidth / 2, BaseY + 0.6 * HScroll1.Value - printFontHeight * 20, 0, Text2.Text, printFontHeight, printFontWidth) Call sub_PrintStar(BaseX, BaseY, printR * 0.2)
' Picture1.Picture = Picture1.Image
' Picture1.DrawWidth = 2 '/ HScroll1.Max * HScroll1.Value Picture1.Line (BaseX - sngWidth / 2 * 1.2, BaseY + 0.66 * HScroll1.Value)-(BaseX + sngWidth / 2 * 1.2, BaseY + 0.664 * HScroll1.Value), vbRed, BF
' Picture1.DrawWidth = 4 '/ HScroll1.Max * HScroll1.Value Picture1.Line (BaseX - sngWidth / 2 * 1.2, BaseY + 0.7 * HScroll1.Value)-(BaseX + sngWidth / 2 * 1.2, BaseY + 0.72 * HScroll1.Value), vbRed, BF
Picture1.Refresh
End SubPrivate Sub sub_RevolvePrint(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _
, ByVal intAngle As Integer, ByVal strPrint As String _
, ByVal intFontHeight As Single, ByVal intFontWidth As Single)
Dim TFont As LOGFONT
Dim hOldFont As Long, hFont As Long
With TFont
.lfHeight = intFontHeight * 20 '/ Screen.TwipsPerPixelY
.lfWidth = intFontWidth * 20 '/ Screen.TwipsPerPixelX
.lfEscapement = intAngle * 10
.lfWeight = 700
.lfCharSet = DEFAULT_CHARSET
End With
hFont = CreateFontIndirect(TFont)
hOldFont = SelectObject(Me.Picture1.hdc, hFont)
With Me.Picture1
' .AutoRedraw = False
' .Cls
.CurrentX = sigCurrentX
.CurrentY = sigCurrentY
End With
Picture1.Print strPrint SelectObject Me.Picture1.hdc, hOldFont
DeleteObject hFont
' Picture1.RefreshEnd Sub
'要一个按钮一个pictureboxPrivate Sub sub_PrintStar(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _
, ByVal intPrintR As Integer)
Dim tri(2) As POINTAPI
Dim a As Single, nA As Single
Dim rA As Single, rB As Single
Dim cX As Long, cY As Long
cX = sigCurrentX
cY = sigCurrentY
rA = intPrintR
rB = rA * (Sin(18 * PI / 180) / Sin(126 * PI / 180))
a = 36 * PI / 180 tri(0).X = 0: tri(0).Y = -rA
tri(1).X = -rB * Sin(a): tri(1).Y = -Cos(a) * rB
tri(2).X = rB * Sin(a): tri(2).Y = -Cos(a) * rB Dim i As Integer, j As Integer
Dim t(2) As POINTAPI
Dim c(4) As Long
' c(0) = vbRed
' c(1) = vbBlue
' c(2) = vbYellow
' c(3) = vbGreen
' c(4) = RGB(255, 0, 255)
c(0) = vbRed
c(1) = vbRed
c(2) = vbRed
c(3) = vbRed
c(4) = vbRed
For i = 0 To 4
nA = 2 * PI / 5 * i
For j = 0 To 2
t(j).X = tri(j).X * Cos(nA) + tri(j).Y * Sin(nA) + cX
t(j).Y = -tri(j).X * Sin(nA) + tri(j).Y * Cos(nA) + cY
Next j
Ptg(i + 5) = t(0)
Ptg(i) = t(1) drawPoly t, c(i)
Next i drawPoly Ptg, vbRed, 5
End SubPrivate Sub drawPoly(p() As POINTAPI, Optional ByVal fillCol As Long, Optional ByVal nC As Long = 3)
Picture1.FillStyle = 0
Picture1.FillColor = fillCol
Polygon Picture1.hdc, p(0), nC
End SubPrivate Sub Form_Load()
Picture1.BackColor = vbWhite
Picture1.ForeColor = vbRed
Text1.Text = "中华人民共和国水电部节水办公室"
Text2.Text = "灌水专用章" HScroll1.Value = 100
HScroll1.SmallChange = 2
HScroll1.LargeChange = 20
HScroll1.Min = 50
HScroll1.Max = 150
End SubPrivate Sub HScroll1_Change()
Command1_Click
Label1.Caption = HScroll1.Value
End SubPrivate Sub HScroll1_Scroll()
Command1_Click
End Sub