jhone99 进来

zx091x 2010-10-12 10:34:48

你的字体太肥胖
.lfWidth = 0.5 * intFontWidth * -20 / Screen.TwipsPerPixelX
乘了个0.5后就不对称了

...全文

162 10 打赏收藏转发到动态举报

写回复

用AI写文章

10 条回复

切换为时间正序

请发表友善的回复…

发表回复

jhone99 2010-10-13

打赏
举报



Private Const LF_FACESIZE = 32

Private Const DEFAULT_CHARSET = 1



Private 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 Long



Private 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.1415926



Private 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 Integer

    Dim printFontWidth As Integer

    Dim sngRatio As Single

    

    BaseX = Me.Picture1.ScaleWidth / 2

    BaseY = Me.Picture1.ScaleHeight / 5 * 4

    printR = 4000

    sngRatio = 0.3

    printFontWidth = Int(printR * PI / 20 / Len(Text1) * sngRatio)

    printFontHeight = printFontWidth * 2

    printR2 = printR + printFontHeight * 20



    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)

        printY = BaseY - printR2 * Cos(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) * (1 - sngRatio) / 2)

        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

    

End Sub



Private Sub sub_RevolvePrint(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _

           , ByVal intAngle As Integer, ByVal strPrint As String _

           , ByVal intFontHeight As Integer, ByVal intFontWidth As Integer)

           

    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



End Sub

'要一个按钮一个picturebox

jhone99 2010-10-13

打赏
举报

[Quote=引用 7 楼 veron_04 的回复:]
这个的确不好调啊，需要耐性
[/Quote]

不是耐性问题，是计算比较复杂，要考虑很多因素，有的没有做好

jhone99 2010-10-13

打赏
举报



Private Const LF_FACESIZE = 32

Private Const DEFAULT_CHARSET = 1



Private 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 Long



Private 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.1415926



Private 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 Integer

    Dim printFontWidth As Integer

    Dim sngRatio As Single

    

    BaseX = Me.Picture1.ScaleWidth / 2

    BaseY = Me.Picture1.ScaleHeight / 5 * 4

    printR = 4000

    sngRatio = 0.3

    printFontWidth = Int(printR * PI / 180 / Len(Text1) * 4.5 * sngRatio)

    printFontHeight = printFontWidth * 2

    printR2 = printR + printFontHeight * 20



    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)

        printY = BaseY - printR2 * Cos(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) * (1 - sngRatio) / 2)

        printAngle = Int(90 - i * 180 / Len(Text1) - 180 / Len(Text1) * sngRatio / 2)

        Call sub_RevolvePrint(printX, printY, printAngle, Mid(Text1, i + 1, 1), printFontHeight, printFontWidth)

    Next i

    

End Sub



Private Sub sub_RevolvePrint(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _

           , ByVal intAngle As Integer, ByVal strPrint As String _

           , ByVal intFontHeight As Integer, ByVal intFontWidth As Integer)

           

    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



End Sub

'要一个按钮一个picturebox

贝隆 2010-10-13

打赏
举报

这个的确不好调啊，需要耐性

zx091x 2010-10-13

打赏
举报

sngRatio = 0.3 后就不对称了
对称问题一直没解决好,得用绝对值,或者用中值与位置的差(有负值的时候)

jhone99 2010-10-13

打赏
举报

Private Const LF_FACESIZE = 32

Private Const DEFAULT_CHARSET = 1



Private 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 Long



Private 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.1415926



Private 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 Integer

    Dim printFontWidth As Integer

    Dim sngRatio As Single

    

    BaseX = Me.Picture1.ScaleWidth / 2

    BaseY = Me.Picture1.ScaleHeight / 5 * 4

    printR = 4000

    sngRatio = 0.7

    printFontWidth = Int(printR * PI / 180 / Len(Text1) * 4.5 * sngRatio)

    printFontHeight = printFontWidth * 2

    printR2 = printR + printFontHeight * 20



    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))

        printY = BaseY - printR2 * Cos(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) * (1 - sngRatio))

        printAngle = Int(90 - i * 180 / Len(Text1) - 180 / Len(Text1) / 2 * sngRatio)

        Call sub_RevolvePrint(printX, printY, printAngle, Mid(Text1, i + 1, 1), printFontHeight, printFontWidth)

    Next i

    

End Sub



Private Sub sub_RevolvePrint(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _

           , ByVal intAngle As Integer, ByVal strPrint As String _

           , ByVal intFontHeight As Integer, ByVal intFontWidth As Integer)

           

    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



End Sub

'要一个按钮一个picturebox

jhone99 2010-10-13

打赏
举报



Private Const LF_FACESIZE = 32

Private Const DEFAULT_CHARSET = 1



Private 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 Long



Private 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.1415926



Private 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 Integer

    Dim printFontWidth As Integer

    Dim sngRatio As Single

    

    BaseX = Me.Picture1.ScaleWidth / 2

    BaseY = Me.Picture1.ScaleHeight / 5 * 4

    printR = 5000

    printFontWidth = Int(printR * PI / 180 / Len(Text1) * 3.5)

    printFontHeight = printFontWidth * 2

    sngRatio = printFontWidth / (printR * PI / Len(Text1) / 180 * 4.5)

    printR2 = printR + printFontHeight * 20



    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))

        printY = BaseY - printR2 * Cos(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) * (1 - sngRatio))

        printAngle = Int(90 - i * 180 / Len(Text1) - 180 / Len(Text1) / 2 * sngRatio)

        Call sub_RevolvePrint(printX, printY, printAngle, Mid(Text1, i + 1, 1), printFontHeight, printFontWidth)

    Next i

    

End Sub



Private Sub sub_RevolvePrint(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _

           , ByVal intAngle As Integer, ByVal strPrint As String _

           , ByVal intFontHeight As Integer, ByVal intFontWidth As Integer)

           

    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



End Sub

'要一个按钮一个picturebox

jhone99 2010-10-12

打赏
举报

换个方式，高度*2

jhone99 2010-10-12

打赏
举报



Private Const LF_FACESIZE = 32

Private Const DEFAULT_CHARSET = 1



Private 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 Long



Private 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.1415926



Private 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 sngRatio As Single

    

    BaseX = Me.Picture1.ScaleWidth / 2

    BaseY = Me.Picture1.ScaleHeight / 2

    printR = 2000

    

    For i = 0 To Len(Text1) - 1

        printX = BaseX + printR * Sin(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) / 10 * 6 * printR / 3000 * 32 / Len(Text1) / 32)

        printY = BaseY - printR * Cos(i * 180 / Len(Text1) * PI / 180 + PI / 180 * 270 + PI / 180 * 180 / Len(Text1) / 10 * 6 * printR / 3000 * 32 / Len(Text1) / 32)

        printAngle = Int(90 - i * 180 / Len(Text1) - 180 / Len(Text1) / 2 * 6 * printR / 3000 * 32 / Len(Text1) / 32)

        Call sub_RevolvePrint(printX, printY, printAngle, Mid(Text1, i + 1, 1), 6 * printR / 3000 * 32 / Len(Text1) * 2, 6 * printR / 3000 * 32 / Len(Text1))

    Next i

    

End Sub



Private Sub sub_RevolvePrint(ByVal sigCurrentX As Single, ByVal sigCurrentY As Single _

           , ByVal intAngle As Integer, ByVal strPrint As String _

           , ByVal intFontHeight As Integer, ByVal intFontWidth As Integer)

           

    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



End Sub

'要一个按钮一个picturebox