如何用VB在已有的图形文件上加字，并能保存？

Question

set Pic1.Picture=LoadPicture(……)
Pic1.CurrentX=……
Pic1.CurrentY=……
Pic1.Print "jlty7390 (丹顶鹤)"
SavePicture Pic1.Picture, ……

Answer 1

Public Declare Sub CopyMemoryLong Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As LongPublic 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 LongPublic Declare Function GetTabbedTextExtent Lib "user32" Alias "GetTabbedTextExtentA" (ByVal hdc As Long, ByVal lpString As String, ByVal nCount As Long, ByVal nTabPositions As Long, lpnTabStopPositions As Long) As LongPublic Declare Function TabbedTextOut Lib "user32" Alias "TabbedTextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long, ByVal nTabPositions As Long, lpnTabStopPositions As Long, ByVal nTabOrigin As Long) As LongPublic Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPublic Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPublic Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPublic Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As LongPublic Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As LongPublic Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As LongPublic Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As LongPublic Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hbrush As Long) As LongPublic Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPublic Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As LongPublic Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPublic Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As LongPublic Declare Function GetGDIObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public 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 * 32
End Type
Public Type POINTAPI
        x As Long
        y As Long
End Type
Public Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End TypePublic Type BITMAPINFOHEADER '40 bytes
        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 TypePublic Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End TypePublic Type DWORD
    low As Integer
    high As Integer
End TypePublic Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Answer 2

以下是form1Option Explicit
Private Sub Form_Load()
    Picture1.Cls
    drawtext Picture1.hdc, "Rang3r", 0, 170, vbWhite, 0.6, "Arial", 82
    drawtext Picture1.hdc, "Antialias text", 0, 210, vbYellow, 1, "Arial", 52
    Picture1.Refresh
End SubPublic Sub drawtext(hdc As Long, text As String, xpos As Long, ypos As Long, color As Long, opacity As Double, fontname As String, fontsize As Long)
    Dim size                                  As DWORD
    Dim ret                                   As Long
    Dim ndc                                   As Long
    Dim nbmp                                  As Long
    Dim hjunk
    Dim font                                  As LOGFONT
    Dim hfont                                 As Long
    Dim pixels()                              As RGBQUAD
    Dim npixels()                             As RGBQUAD
    Dim bgpixels()                            As RGBQUAD
    Dim rgbcol(3)                             As Byte
    Dim x, y, yy
    Dim bminfo                                As BITMAPINFO
    Dim tmp                                   As Double
    Dim alpha                                 As Double
    With font
        .lfHeight = -(fontsize * 20) / Screen.TwipsPerPixelY ' set font size
        .lfFaceName = fontname & Chr(0) 'apply font name
        .lfWeight = 0   'this is how bold the font is .. apply a in param if you want
    End With
    
    '-----------------------------------------
    'create a dc for our backbuffer
    ndc = CreateCompatibleDC(hdc)
    'create a bitmap for our backbuffer
    nbmp = CreateCompatibleBitmap(hdc, 1, 1) 'make a temp bitmap so we can get the size of the text
    'attach our bitmap to our backbuffer
    hjunk = SelectObject(ndc, nbmp)
    'apply the font to our backbuffer
    hfont = CreateFontIndirect(font)
    SelectObject ndc, hfont
    
    'get size of the text we want to draw
    ret = GetTabbedTextExtent(ndc, text, Len(text), 0, 0)
    
    'delete our temp bmp
    DeleteObject hfont
    DeleteObject ndc
    DeleteObject nbmp
    'this part was only to measure the size of the text
    '----------------------------------------
    'now lets draw the text...
    
    
    'split our color value to a byte array
    'this is my own invention ... pretty nice (?)
    CopyMemoryLong VarPtr(rgbcol(0)), VarPtr(color), 4
    'split the return value from gettextextent into two integers
    CopyMemoryLong VarPtr(size), VarPtr(ret), 4
    
    ypos = ypos - size.high / 2
    'create a dc for our backbuffer
    ndc = CreateCompatibleDC(hdc)
    'create a bitmap for our backbuffer
    nbmp = CreateCompatibleBitmap(hdc, size.low, size.high)
    'attach our bitmap to our backbuffer
    hjunk = SelectObject(ndc, nbmp)
    'apply the font to our backbuffer
    hfont = CreateFontIndirect(font)
    SelectObject ndc, hfont
    'set black background coloy
    SetBkColor ndc, 0
    'set white forecolor
    SetTextColor ndc, vbWhite
    'write the text to our backbuffer
    TabbedTextOut ndc, 0, 0, text, Len(text), 0, 0, 0
    'resize the arrays to the same size as the bbuffer
    ReDim pixels(size.low - 1, size.high - 1)
    ReDim npixels(size.low - 1, size.high - 1)
    ReDim bgpixels(size.low - 1, size.high - 1)
    
    'set the bitmap info (so we can get the gfx data in and out of our arrays
    With bminfo.bmiHeader
        .biSize = Len(bminfo.bmiHeader)
        .biWidth = size.low
        .biHeight = size.high
        .biPlanes = 1
        .biBitCount = 32
    End With
    'store the drawn text in our "pixels" array
    GetDIBits ndc, nbmp, 0, size.high, pixels(0, 0), bminfo, 1
    'get the bg graphics into our "bgpixels" array
    BitBlt ndc, 0, 0, size.low, size.high, hdc, xpos, ypos, vbSrcCopy
    GetDIBits ndc, nbmp, 0, size.high, bgpixels(0, 0), bminfo, 1
    yy = Int(size.high / 2)
    npixels = bgpixels
    For x = 0 To size.low - 2 Step 2
        For y = 0 To size.high - 2 Step 2
            'alpha is the average of the color of 2*2 pixels /255
            'now we have a value between 0 and 1
            '0 is transparent
            '1 is soild white
            'now multiply alpha with the opacity factor
            'ie if opacity is 0.5 ...  aplha will be max 0.5
            'since we draw our text with white . we only need to check the strength of one color (in this case blue)
            'coz red and green will always be the same as the blue
            alpha = (((0 + (pixels(x + 0, y + 0).rgbBlue) + (pixels(x + 1, y + 0).rgbBlue) + (pixels(x + 0, y + 1).rgbBlue) + (pixels(x + 1, y + 1).rgbBlue)) / 4) / 255) * opacity
            'alpha is now the opacity factor 0-1
            'calculate amount of blue to apply
            'and how much of the background that is going to be seen
            tmp = (alpha * rgbcol(2)) + bgpixels(x / 2, y / 2).rgbBlue * (1 - alpha)
            'never go higher than 255
            If tmp > 255 Then tmp = 255
            'store the result at x/2 and y/2 (the new picture is only 0.5 times as high and wide
            npixels(x / 2, y / 2).rgbBlue = tmp
            'calculate amount of red to apply
            'and how much of the background that is going to be seen
            tmp = (alpha * rgbcol(0)) + bgpixels(x / 2, y / 2).rgbRed * (1 - alpha)
            'never go higher than 255
            If tmp > 255 Then tmp = 255
            npixels(x / 2, y / 2).rgbRed = tmp
            'calculate amount of green to apply
            'and how much of the background that is going to be seen
            tmp = (alpha * rgbcol(1)) + bgpixels(x / 2, y / 2).rgbGreen * (1 - alpha)
            'never go higher than 255
            If tmp > 255 Then tmp = 255
            npixels(x / 2, y / 2).rgbGreen = tmp
        Next
    Next
    'apply the new picture to our bbuffer-dc
    SetDIBits ndc, nbmp, 0, size.high, npixels(0, 0), bminfo, 1
    'blit our bbuffer-dc to the screen
    BitBlt hdc, xpos, ypos, size.low, size.high, ndc, 0, 0, vbSrcCopy
    'clean up
    DeleteObject hfont
    DeleteObject ndc
    DeleteObject nbmp
End Sub

Answer 3

下一步是要复制才能保存
Step-by-Step Example
Here is an example showing how to copy the contents of a picture control to the contents of another picture control. Start a new project in Visual Basic. Form1 is created by default. Place two picture controls (Picture1 and Picture2) on Form1. 
Add a BAS module to the project. 
In the General Declarations section of the module place the following code to declare the BitBlt API:       #If Win32 Then
      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
      #Else
      Declare Function BitBlt Lib "GDI" (ByVal hDestDC%, ByVal X%, ByVal _
      Y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, _
      ByVal YSrc%, ByVal dwRop&) As Integer
      #End If
 Display some graphics on Picture1 by loading from a picture file or by pasting from the clipboard at design time. You can load a picture from a file as follows:
Select Picture from the Properties list box and click the button with three dots to the right of the Settings box. 
Then select the desired picture file such as a .BMP or .ICO file supplied with Microsoft Windows from the dialog box. Add the following code to the Form_Click procedure:       Private Sub Form_Click ()
      #If Win32 Then
      Const PIXEL = 3
      Picture1.ScaleMode = PIXEL
      Picture2.ScaleMode = PIXEL
      hDestDC& = Picture2.hDC
      x& = 0: y& = 0
      nWidth& = Picture2.ScaleWidth
      nHeight& = Picture2.ScaleHeight
      ' Assign information of the source bitmap.
      hSrcDC& = Picture1.hDC
      xSrc& = 0: ySrc& = 0
      ' Assign the SRCCOPY constant to the Raster operation.
      dwRop& = &HCC0020
      Suc& = BitBlt(hDestDC&, x&, y&, nWidth&, nHeight&, hSrcDC&, _
      xSrc&, ySrc&, dwRop&)
      #Else
      ' Assign information of the destination bitmap. Note that Bitblt
      ' requires coordinates in pixels.
      Const PIXEL = 3
      Picture1.ScaleMode = PIXEL
      Picture2.ScaleMode = PIXEL
      hDestDC% = Picture2.hDC
      x% = 0: y% = 0
      nWidth% = Picture2.ScaleWidth
      nHeight% = Picture2.ScaleHeight
      ' Assign information of the source bitmap.
      hSrcDC% = Picture1.hDC
      xSrc% = 0: ySrc% = 0
      ' Assign the SRCCOPY constant to the Raster operation.
      dwRop& = &HCC0020
      Suc% = BitBlt(hDestDC%, x%, y%, nWidth%, nHeight%, hSrcDC%, _
      xSrc%, ySrc%, dwRop&)
      #End If
      End Sub
 Run the program. Click the form. The contents of the first picture will be displayed on the se cond picture. 

Answer 4

几种方法:比如api 函数里的 textout
还有就是picture1.print

Answer 5

TO：zyl910(910：分儿，我来了！) 
我为什么用SavePicture不行？？？？？

Answer 6

Bardo(巴顿) :我试了怎么没反应？

Answer 7

Bardo(巴顿)  :我试了怎么没反应？盼回答

Answer 8

回复人： Bardo(巴顿) (  ) 信誉：100  2002-2-27  19:17:53  得分:0  
  
TO：zyl910(910：分儿，我来了！)  
  我为什么用SavePicture不行？？？？？ picture1.autoredraw=true
savepicture picture1.image.....

Answer 9

我可以加字但不能存，再次麻烦Bardo(巴顿)  谢谢

Answer 10

你必须用另一个PictureBox
用后面保存的程序转移前一个中的当前图片
调试时先看看：
文件是否可以转移得过去。
如不能，则存不了
如能则可以

Answer 11

我的方法是可行的，已经过调试
我觉得当picture1.autoredraw=true时实际上picturebox存了2张图
一张在picture属性
一张在image属性
image上既是你所能看到的

Answer 12

'葡萄的思路是正确的
'要设置autodraw属性，调用savepicture方法时使用picture1.image
Picture1.AutoRedraw = True
Picture1.CurrentX = 100
Picture1.CurrentY = 100
Picture1.Print "hello"
SavePicture Picture1.Image, "c:\aa.bmp"