图片处理，如何按一定角度叠加几个字？

Question

在图片上某一位置叠加几个字，该图片都是按固定角度拍摄而成（大概前方30度），用户可以调整位置，大小等，如何实现？

Answer 1

Private Declare Function CreateFontIndirect Lib "gdi32" _
                Alias "CreateFontIndirectA" _
                (lpLogFont As LOGFONT) _
                As Long
                
Private Declare Function SelectObject Lib "gdi32" _
                (ByVal hdc As Long, _
                ByVal hObject As Long) _
                As Long
                
Private Declare Function TextOut Lib "gdi32" _
                Alias "TextOutA" _
                (ByVal hdc As Long, _
                ByVal x As Long, _
                ByVal y As Long, _
                ByVal lpString As String, _
                ByVal nCount As Long) _
                As Long
                
Private Declare Function DeleteObject Lib "gdi32" _
                (ByVal hObject As Long) _
                As Long
                
Private Declare Function SetBkMode Lib "gdi32" _
                (ByVal hdc As Long, _
                ByVal nBkMode As Long) _
                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 As String * 50
End TypeDim RF As LOGFONT
Dim NewFont As Long
Dim OldFont As LongPrivate Sub Command_View_Click()
     Dim Throw As Long
     Me.Picture1.Cls
     RF.lfEscapement = Int(Val(Me.txtEscapement.Text)) * 10
    '设置文本倾斜度
     '设置字体参数
     NewFont = CreateFontIndirect(RF)
     '创建新字体
     OldFont = SelectObject(Me.Picture1.hdc, NewFont)
     '应用新字体
     x = Me.Picture1.ScaleWidth / 2
     y = Me.Picture1.ScaleHeight / 2
     '选择显示文本的起点
     Throw = TextOut(Me.Picture1.hdc, x, y, Me.Text_Input.Text, _
                Len(Me.Text_Input.Text))
     '显示文本
     NewFont = SelectObject(Me.Picture1.hdc, OldFont)
     '选择旧字体
     Throw = DeleteObject(NewFont)
     '删除新字体
End SubPrivate Sub Form_Load()
     SetBkMode Me.Picture1.hdc, 1
     RF.lfHeight = 50
     '设置字符高度
     RF.lfWidth = 10
     '设置字符平均宽度
     RF.lfEscapement = 0
     '设置文本倾斜度
     RF.lfWeight = 400
     '设置字体的轻重
     RF.lfItalic = 0
     '字体不倾斜
     RF.lfUnderline = 0
     '字体不加下划线
     RF.lfStrikeOut = 0
     '字体不加删除线
     RF.lfOutPrecision = 0
     '设置输出精度
     RF.lfClipPrecision = 0
     '设置剪辑精度
     RF.lfQuality = 0
     '设置输出质量
     RF.lfPitchAndFamily = 0
     '设置字体的字距和字体族
     RF.lfCharSet = 0
     '设置字符集
     RF.lfFaceName = "Arial" + Chr(0)
     '设置字体名称
     
     Me.txtEscapement.Text = RF.lfEscapement / 10
End Sub

Answer 2

补充:
Text_Input文本框输入需显示的文字
txtEscapement文本框输入需旋转的角度
改变文字颜色使用Picture1的属性ForeColor设置.

Answer 3

To: zdingyun
调试没显示文字，不知是哪出问题了？

Answer 4

Option ExplicitPrivate 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 TypePrivate Sub Command1_Click()
        Dim TFont As LOGFONT
        Dim hOldFont As Long, hFont As Long
        
        With TFont
        .lfHeight = 32 * -20 / Screen.TwipsPerPixelY
        .lfWidth = 32 * -20 / Screen.TwipsPerPixelX
        .lfEscapement = 45 * 10
        .lfWeight = 700
        .lfCharSet = DEFAULT_CHARSET
        End With
        
        hFont = CreateFontIndirect(TFont)
        hOldFont = SelectObject(Me.Picture1.hdc, hFont)
        
        With Me.Picture1
        .AutoRedraw = False
        .Cls
        .CurrentX = .ScaleWidth / 2
        .CurrentY = .ScaleHeight / 2
        End With
        Picture1.Print "aa"
        
        SelectObject Me.Picture1.hdc, hOldFont
        DeleteObject hFontEnd Sub

Answer 5

LZ:你先不在PICTUREBOX加载图片调试。

Answer 6

zdingyun ：也不显示呢，你试过没？

Answer 7

chenjl1031 ：你好。这样显示是平面的字，角度体现不出来，加的文字要和拍的图角度一致，不知有什么方法不

Answer 8

手工调整这个值:  TFont.lfEscapement = 45 * 10

Answer 9

LZ：我是在WINXP及VB6条件下试过才贴出代码的。

Answer 10

仔细检查代码没错，仅是
Picture1的属性ScaleMode需设置为3
即将Form_Load代码改为：Private Sub Form_Load()
    Picture1.ScaleMode = 3
     SetBkMode Me.Picture1.hdc, 1
     RF.lfHeight = 50
     '设置字符高度
     RF.lfWidth = 10
     '设置字符平均宽度
     RF.lfEscapement = 0
     '设置文本倾斜度
     RF.lfWeight = 400
     '设置字体的轻重
     RF.lfItalic = 0
     '字体不倾斜
     RF.lfUnderline = 0
     '字体不加下划线
     RF.lfStrikeOut = 0
     '字体不加删除线
     RF.lfOutPrecision = 0
     '设置输出精度
     RF.lfClipPrecision = 0
     '设置剪辑精度
     RF.lfQuality = 0
     '设置输出质量
     RF.lfPitchAndFamily = 0
     '设置字体的字距和字体族
     RF.lfCharSet = 0
     '设置字符集
     RF.lfFaceName = "Arial" + Chr(0)
     '设置字体名称
     
     Me.txtEscapement.Text = RF.lfEscapement / 10
End Sub

Answer 11

你说清楚嘛,那就用Word提供的艺术字效果.

Answer 12

chenjl1031：代码如何写呢？

Answer 13

Option ExplicitDim w As New Word.Application
  
Private Sub Form_Load()
     w.Documents.Add.Select
     w.ActiveDocument.Shapes.AddTextEffect(0, "艺术字", "隶书", 48#, -1, 0, 183.75, 70.5).Select
End Sub
  
'点一次变一次字体（立体字）
Private Sub Form_Click()
     w.Selection.ShapeRange.TextEffect.PresetTextEffect = Int(Rnd(1) * 30)
     w.Selection.ShapeRange.TextEffect.FontName = "隶书"
     w.Selection.Copy
     Picture = Clipboard.GetData()
End Sub
  
Private Sub Form_Unload(Cancel As Integer)
     w.Quit wdDoNotSaveChanges
     Set w = Nothing
End Sub
  
Private Sub Command1_Click()
     End
End Sub

Answer 14

不好意思，太忙了，没时间回复。按照下面这样就可以了：'在VB工程中引用Microsoft Word 11.0 Object Library
'在Picture1上面放一个Image1（比Picture1小）
'还是用Image控件，因为PictureBox控件上的艺术字不能透明
Option ExplicitDim W As New Word.Application '定义Word对象Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source' 抓取屏幕图像到剪贴板
Private Function GetScreenBitmap(Left As Long, Top As Long, Right As Long, Bottom As Long)
    Dim rWidth As Long
    Dim rHeight As Long
    Dim SourceDC As Long
    Dim DestDC As Long
    Dim BHandle As Long
    Dim Wnd As Long
    Dim DHandle As Long
    On Error GoTo Lhandle
    rWidth = Right - Left
    rHeight = Bottom - Top
    SourceDC = CreateDC("DISPLAY", 0, 0, 0)
    DestDC = CreateCompatibleDC(SourceDC)
    BHandle = CreateCompatibleBitmap(SourceDC, rWidth, rHeight)
    SelectObject DestDC, BHandle
    BitBlt DestDC, 0, 0, rWidth, rHeight, SourceDC, Left, Top, &HCC0020
    Wnd = Screen.ActiveForm.hwnd
    OpenClipboard Wnd
    EmptyClipboard
    SetClipboardData 2, BHandle
    CloseClipboard
    DeleteDC DestDC
    ReleaseDC DHandle, SourceDC
Lhandle:
       Exit Function
End Function
'保存图片
Private Sub Command2_Click()
        'Clipboard.Clear
        'Me.ScaleMode = 3
        GetScreenBitmap Picture1.ScaleLeft + 2, Picture1.ScaleTop + 2, Picture1.ScaleLeft + 2 + Picture1.ScaleWidth, Picture1.ScaleTop + 2 + Picture1.ScaleHeight
        Me.ScaleMode = 1
        Picture2.Picture = Clipboard.GetData '(vbCFDIB)
        SavePicture Picture2.Image, "c:\艺术字.bmp"
        '清空剪贴板
        OpenClipboard Screen.ActiveForm.hwnd
        EmptyClipboard
End SubPrivate Sub Form_load()
     Me.ScaleMode = 3
     Picture1.ScaleMode = 3
     Picture2.ScaleMode = 3
     Picture1.AutoRedraw = False
     Picture2.AutoRedraw = False
     Picture1.AutoSize = False
     Picture2.AutoSize = False
     Picture2.Width = Picture1.Width
     Picture2.Height = Picture1.Height
     Command1.Caption = "改变字体"
     Command2.Caption = "保存图片"
     W.Documents.Add.Select
     W.ActiveDocument.Shapes.AddTextEffect(0, "艺术字", "隶书", 48#, -1, 0, 183.75, 70.5).Select
End SubPrivate Sub Form_Unload(Cancel As Integer)
     W.Quit wdDoNotSaveChanges
     Set W = Nothing
     Unload Me
     End
End Sub'点一次变一次字体（立体字）
Private Sub Command1_Click()
        W.Selection.ShapeRange.TextEffect.PresetTextEffect = Int(Rnd(1) * 30)
        W.Selection.ShapeRange.TextEffect.FontName = "隶书"
        W.Selection.Copy
        Image1.Picture = Clipboard.GetData
End Sub

Answer 15

还要改一下:
'在VB工程中引用Microsoft Word 11.0 Object Library
'在Picture1上面放一个Image1（比Picture1小）
'还是用Image控件，因为PictureBox控件上的艺术字不能透明
'将Form1的BorderStyle 设置为 0
Option ExplicitDim W As New Word.Application '定义Word对象Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source' 抓取屏幕图像到剪贴板
Private Function GetScreenBitmap(Left As Long, Top As Long, Right As Long, Bottom As Long)
    Dim rWidth As Long
    Dim rHeight As Long
    Dim SourceDC As Long
    Dim DestDC As Long
    Dim BHandle As Long
    Dim Wnd As Long
    Dim DHandle As Long
    On Error GoTo Lhandle
    rWidth = Right - Left
    rHeight = Bottom - Top
    SourceDC = CreateDC("DISPLAY", 0, 0, 0)
    DestDC = CreateCompatibleDC(SourceDC)
    BHandle = CreateCompatibleBitmap(SourceDC, rWidth, rHeight)
    SelectObject DestDC, BHandle
    BitBlt DestDC, 0, 0, rWidth, rHeight, SourceDC, Left, Top, &HCC0020
    Wnd = Screen.ActiveForm.hwnd
    OpenClipboard Wnd
    EmptyClipboard
    SetClipboardData 2, BHandle
    CloseClipboard
    DeleteDC DestDC
    ReleaseDC DHandle, SourceDC
Lhandle:
       Exit Function
End Function
'保存图片
Private Sub Command2_Click()
        Debug.Print Picture1.Left + 2, Picture1.Top + 2
        GetScreenBitmap Picture1.Left + 2, Picture1.Top + 2, Picture1.Left + 2 + Picture1.ScaleWidth, Picture1.Top + 2 + Picture1.ScaleHeight
        Picture2.Picture = Clipboard.GetData '(vbCFDIB)
        SavePicture Picture2.Image, "c:\艺术字.bmp"
        '清空剪贴板
        OpenClipboard Screen.ActiveForm.hwnd
        EmptyClipboard
End SubPrivate Sub Command3_Click()
        Unload Me
End SubPrivate Sub Form_load()
     Form1.BorderStyle = 0
     Form1.WindowState = 2
     Me.ScaleMode = 3
     Picture1.Left = 0
     Picture1.Top = 0
     Picture1.ScaleMode = 3
     Picture2.ScaleMode = 3
     Picture1.AutoRedraw = False
     Picture2.AutoRedraw = False
     Picture1.AutoSize = False
     Picture2.AutoSize = False
     Picture2.Width = Picture1.Width
     Picture2.Height = Picture1.Height
     Command1.Caption = "改变字体"
     Command2.Caption = "保存图片"
     Command3.Caption = "退    出"
     W.Documents.Add.Select
     W.ActiveDocument.Shapes.AddTextEffect(0, "艺术字", "隶书", 48#, -1, 0, 183.75, 70.5).Select
End SubPrivate Sub Form_Unload(Cancel As Integer)
     W.Quit wdDoNotSaveChanges
     Set W = Nothing
     Unload Me
     End
End Sub'点一次变一次字体（立体字）
Private Sub Command1_Click()
        W.Selection.ShapeRange.TextEffect.PresetTextEffect = Int(Rnd(1) * 30)
        W.Selection.ShapeRange.TextEffect.FontName = "隶书"
        W.Selection.Copy
        Image1.Picture = Clipboard.GetData
End Sub

Answer 16

想复杂了,其实很简单。这样可以完全保存。下面是最后的程序：'在VB工程中引用Microsoft Word 11.0 Object Library
'在Picture1上面放一个Image1（比Picture1小），再加一个Picture2
'还是用Image控件，因为PictureBox控件上的艺术字不能透明
'
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = sourceDim W As New Word.Application '定义Word对象'保存图片
Private Sub Command2_Click()
        Call BitBlt(Picture2.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc, 0, 0, SRCCOPY)
        SavePicture Picture2.Image, "c:\图片加上艺术字.bmp"
End SubPrivate Sub Command3_Click()
        Unload Me
End SubPrivate Sub Form_Activate()
        Picture1.AutoRedraw = False
        Set Image1.Container = Picture1
        With Picture2
            .AutoRedraw = True
            .Width = Picture1.Width
            .Height = Picture1.Height
            .Move Screen.Width
            '.Visible = True
        End With
End Sub
Private Sub Form_load()
     Me.ScaleMode = 3
     Picture1.ScaleMode = 3
     Picture2.ScaleMode = 3
     Picture1.AutoRedraw = False
     Command1.Caption = "改变字体"
     Command2.Caption = "保存图片"
     Command3.Caption = "退    出"
     W.Documents.Add.Select
     W.ActiveDocument.Shapes.AddTextEffect(0, "艺术字", "隶书", 48#, -1, 0, 183.75, 70.5).Select
End SubPrivate Sub Form_Unload(Cancel As Integer)
     W.Quit wdDoNotSaveChanges
     Set W = Nothing
     Unload Me
     End
End Sub'点一次变一次字体（立体字）
Private Sub Command1_Click()
        W.Selection.ShapeRange.TextEffect.PresetTextEffect = Int(Rnd(1) * 30)
        W.Selection.ShapeRange.TextEffect.FontName = "隶书"
        W.Selection.Copy
        Image1.Picture = Clipboard.GetData
End Sub

Answer 17

谢谢大家，特别是chenjl1031和zdingyun。

Answer 18

要注意的是：Picture2在外面，不在Picture1里头，不要搞错了。