Private Sub Command1_Click() Dim str As String str = "风雨无阻 拍摄" With Picture1 .AutoSize = True .ScaleMode = 3 .AutoRedraw = True .Picture = LoadPicture("c:\1.bmp") Picture1.Line (0, .ScaleHeight - 30)-(.ScaleWidth, .ScaleHeight), vbBlack, BF .CurrentX = (.ScaleWidth - .TextWidth(str)) / 2 .CurrentY = .ScaleHeight - 30 + (30 - .TextHeight(str)) / 2 .ForeColor = vbWhite Picture1.Print str End With SavePicture Picture1.Image, "c:\2.bmp" End Sub要改变 字体的话可以 直接更改Picture1的font属性
Option Explicit Private Const BI_RGB = 0& Private Const DIB_RGB_COLORS = 0 Private Const BITMAPTYPE = &H4D42 Private Const INVALID_HANDLE_VALUE = (-1) Private Const GENERIC_WRITE = &H40000000 Private Const CREATE_ALWAYS = 2 Private Const FILE_ATTRIBUTE_NORMAL = &H80 Private 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 Type Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Private Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type Private Type BITMAPFILEHEADER bfType As Integer bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw 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 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 CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Sub CmdOpen_Click() '打开文件并显示在Picture1中 On Error GoTo Err_handle CmnDlg1.DialogTitle = "打开" CmnDlg1.ShowOpen Picture1.Picture = LoadPicture(CmnDlg1.FileName) Picture1.Height = Picture1.Height + 30 Exit Sub Err_handle: Exit Sub End SubPrivate Sub CmdSave_Click() '保存转换后的图像 Dim hmemDC As Long Dim hmemBMP As Long Dim lpmemBits As Long Dim bmp_info As BITMAPINFO Dim hFile As Long Dim bmpfile_info As BITMAPFILEHEADER Dim lpBytesWritten As Long Picture1.ScaleMode = vbPixels With bmp_info.bmiHeader .biSize = LenB(bmp_info.bmiHeader) .biWidth = Picture1.ScaleWidth .biHeight = Picture1.ScaleHeight .biPlanes = 1 .biBitCount = 24 .biCompression = BI_RGB .biSizeImage = .biHeight * (((.biWidth * .biBitCount + 31) And &HFFFFFFE0) \ 8) End With hmemDC = CreateCompatibleDC(Picture1.hdc) hmemBMP = CreateDIBSection(Picture1.hdc, bmp_info, DIB_RGB_COLORS, lpmemBits, 0, 0) SelectObject hmemDC, hmemBMP BitBlt hmemDC, 0, 0, bmp_info.bmiHeader.biWidth, bmp_info.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy '保存图片 hFile = CreateFile(App.Path & "\test.bmp", GENERIC_WRITE, 0, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) If hFile <> INVALID_HANDLE_VALUE Then With bmpfile_info .bfType = BITMAPTYPE .bfOffBits = 14 + bmp_info.bmiHeader.biSize .bfSize = .bfOffBits + bmp_info.bmiHeader.biSizeImage End With WriteFile hFile, bmpfile_info.bfType, 2, lpBytesWritten, 0 WriteFile hFile, bmpfile_info.bfSize, 12, lpBytesWritten, 0 WriteFile hFile, bmp_info.bmiHeader, bmp_info.bmiHeader.biSize, lpBytesWritten, 0 WriteFile hFile, ByVal lpmemBits, bmp_info.bmiHeader.biSizeImage, lpBytesWritten, 0 CloseHandle hFile End If DeleteObject hmemBMP DeleteDC hmemDC End SubPrivate Sub Command1_Click() '修改 Dim strTxt As String strTxt = "风雨无阻 拍摄" Picture1.Line (0, Picture1.Height - 34)-(Picture1.Width, Picture1.Height), vbBlack, BF Picture1.CurrentY = Picture1.Height - 32 Picture1.CurrentX = Picture1.ScaleWidth / 2 - Picture1.TextWidth(strTxt) ') / 2 - Picture1.TextWidth(strTxt) Picture1.ForeColor = vbWhite Picture1.FontSize = 18 Picture1.Print strTxt End Sub Private Sub Form_Load() Picture1.AutoSize = True Picture1.AutoRedraw = True End Sub
修改部分代码:Private Sub Command1_Click() '修改 Dim strTxt As String strTxt = "风雨无阻 拍摄" Picture1.Line (0, Picture1.ScaleHeight - 30)-(Picture1.ScaleWidth, Picture1.ScaleHeight), vbBlack, BF Picture1.CurrentY = Picture1.ScaleHeight - 30 Picture1.CurrentX = Picture1.ScaleWidth / 2 - Picture1.TextWidth(strTxt) ') / 2 - Picture1.TextWidth(strTxt) Picture1.ForeColor = vbWhite Picture1.FontSize = 18 Picture1.Print strTxt End Sub
Dim str As String
str = "风雨无阻 拍摄"
With Picture1
.AutoSize = True
.ScaleMode = 3
.AutoRedraw = True
.Picture = LoadPicture("c:\1.bmp")
Picture1.Line (0, .ScaleHeight - 30)-(.ScaleWidth, .ScaleHeight), vbBlack, BF
.CurrentX = (.ScaleWidth - .TextWidth(str)) / 2
.CurrentY = .ScaleHeight - 30 + (30 - .TextHeight(str)) / 2
.ForeColor = vbWhite
Picture1.Print str
End With SavePicture Picture1.Image, "c:\2.bmp"
End Sub要改变 字体的话可以 直接更改Picture1的font属性
Option Explicit
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0
Private Const BITMAPTYPE = &H4D42
Private Const INVALID_HANDLE_VALUE = (-1)
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = 2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private 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 Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw 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 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 CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Sub CmdOpen_Click()
'打开文件并显示在Picture1中
On Error GoTo Err_handle
CmnDlg1.DialogTitle = "打开"
CmnDlg1.ShowOpen
Picture1.Picture = LoadPicture(CmnDlg1.FileName)
Picture1.Height = Picture1.Height + 30
Exit Sub
Err_handle:
Exit Sub
End SubPrivate Sub CmdSave_Click()
'保存转换后的图像
Dim hmemDC As Long
Dim hmemBMP As Long
Dim lpmemBits As Long
Dim bmp_info As BITMAPINFO
Dim hFile As Long
Dim bmpfile_info As BITMAPFILEHEADER
Dim lpBytesWritten As Long
Picture1.ScaleMode = vbPixels
With bmp_info.bmiHeader
.biSize = LenB(bmp_info.bmiHeader)
.biWidth = Picture1.ScaleWidth
.biHeight = Picture1.ScaleHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = .biHeight * (((.biWidth * .biBitCount + 31) And &HFFFFFFE0) \ 8)
End With
hmemDC = CreateCompatibleDC(Picture1.hdc)
hmemBMP = CreateDIBSection(Picture1.hdc, bmp_info, DIB_RGB_COLORS, lpmemBits, 0, 0)
SelectObject hmemDC, hmemBMP
BitBlt hmemDC, 0, 0, bmp_info.bmiHeader.biWidth, bmp_info.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy
'保存图片
hFile = CreateFile(App.Path & "\test.bmp", GENERIC_WRITE, 0, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
If hFile <> INVALID_HANDLE_VALUE Then
With bmpfile_info
.bfType = BITMAPTYPE
.bfOffBits = 14 + bmp_info.bmiHeader.biSize
.bfSize = .bfOffBits + bmp_info.bmiHeader.biSizeImage
End With
WriteFile hFile, bmpfile_info.bfType, 2, lpBytesWritten, 0
WriteFile hFile, bmpfile_info.bfSize, 12, lpBytesWritten, 0
WriteFile hFile, bmp_info.bmiHeader, bmp_info.bmiHeader.biSize, lpBytesWritten, 0
WriteFile hFile, ByVal lpmemBits, bmp_info.bmiHeader.biSizeImage, lpBytesWritten, 0
CloseHandle hFile
End If
DeleteObject hmemBMP
DeleteDC hmemDC
End SubPrivate Sub Command1_Click() '修改
Dim strTxt As String
strTxt = "风雨无阻 拍摄"
Picture1.Line (0, Picture1.Height - 34)-(Picture1.Width, Picture1.Height), vbBlack, BF
Picture1.CurrentY = Picture1.Height - 32
Picture1.CurrentX = Picture1.ScaleWidth / 2 - Picture1.TextWidth(strTxt) ') / 2 - Picture1.TextWidth(strTxt)
Picture1.ForeColor = vbWhite
Picture1.FontSize = 18
Picture1.Print strTxt
End Sub
Private Sub Form_Load()
Picture1.AutoSize = True
Picture1.AutoRedraw = True
End Sub
Dim strTxt As String
strTxt = "风雨无阻 拍摄"
Picture1.Line (0, Picture1.ScaleHeight - 30)-(Picture1.ScaleWidth, Picture1.ScaleHeight), vbBlack, BF
Picture1.CurrentY = Picture1.ScaleHeight - 30
Picture1.CurrentX = Picture1.ScaleWidth / 2 - Picture1.TextWidth(strTxt) ') / 2 - Picture1.TextWidth(strTxt)
Picture1.ForeColor = vbWhite
Picture1.FontSize = 18
Picture1.Print strTxt
End Sub
Private Sub CmdEdit_Click() '修改
Dim strTxt As String
strTxt = "风雨无阻 拍摄"
Picture1.FontSize = 18
Picture1.Height = Picture1.Height + 30
Picture1.Line (0, Picture1.ScaleHeight - 30)-(Picture1.ScaleWidth, Picture1.ScaleHeight), vbBlack, BF
Picture1.CurrentY = Picture1.ScaleHeight - 30
Picture1.CurrentX = Picture1.ScaleWidth / 2 - Picture1.TextWidth(strTxt) / 2
Picture1.ForeColor = vbWhite
Picture1.FontItalic = True
Picture1.Print strTxt
End Sub
*.JPG图片
图片保为JPG文件,可以用GDI+。
看看这里(VB源码):
http://www.cnblogs.com/wangminbai/archive/2008/03/23/1118638.html
特别感谢zdingyun ,
发现CSDN的好人越来越多了...