Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPFILEHEADER
bfType(0 To 1) As Byte
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
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 Declare Function SetBkMode Lib "gdi32" (ByVal
hdc As Long, ByVal nBkMode 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd 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 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
GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitMap
As Long, ByVal nStartScan As Long, ByVal nNumScans As
Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal
wUsage As Long) As Long
Private Declare Function
GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal
uObjectType As Long) As Long
Private Declare
Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal
hObject As Long, ByVal nCount As Long, lpObject As
Any) As Long
Public Function SaveBMP(ByVal hdc As Long, FileName As String) As Boolean '這是zyl910的代碼
Dim hBitMap As Long
hBitMap = GetCurrentObject(hdc, OBJ_BITMAP) '取得位元影像
If hBitMap = 0 Then Exit Function
Dim bm As BITMAP
If GetObject(hBitMap, Len(bm), bm) = 0 Then Exit Function '得到位元影像資訊
Dim bmih As BITMAPINFOHEADER
bmih.biSize = Len(bmih)
bmih.biWidth = bm.bmWidth
bmih.biHeight = bm.bmHeight
bmih.biBitCount = 24
bmih.biPlanes = 1
bmih.biSizeImage = ((bmih.biWidth * 3 + 3) And &H7FFFFFFC) * bmih.biHeight '計算大小
ReDim MapData(1 To bmih.biSizeImage) As Byte
If GetDIBits(hdc, hBitMap, 0, bmih.biHeight,
MapData(1), bmih, DIB_RGB_COLORS) = 0 Then Exit Function
'取得位元影像資料
Dim hF As Integer
hF = FreeFile(1)
On Error Resume Next
Open FileName For Binary As hF
If Err.Number Then hF = -1
On Error GoTo 0
If hF = -1 Then Exit Function
Dim bmfh As BITMAPFILEHEADER
bmfh.bfType(0) = Asc("B")
bmfh.bfType(1) = Asc("M")
bmfh.bfOffBits = Len(bmfh) + Len(bmih)
Put hF, , bmfh
Put hF, , bmih
Put hF, , MapData
Close hF
SaveBMP = True
End Function
Private Sub Command1_Click()
Dim mDC As Long, mBitmap As Long
mDC = CreateCompatibleDC(GetDC(0))
Dim pic As StdPicture
Set pic = LoadPicture("e:/mc.bmp") '改為你的圖片路徑
mBitmap = pic.Handle
SelectObject mDC, mBitmap
SetBkMode mDC, TRANSPARENT '如果不需要文字透明，把這句注釋掉
Dim mstr As String
mstr = "hello世界 1234" '改為你想寫入的文字
Dim strlen As Long
Dim s As String
s = StrConv(mstr, vbFromUnicode)
strlen = LenB(s)
TextOut mDC, 10, 10, mstr, strlen
SaveBMP mDC, "e:/mc1.bmp"
DeleteDC mDC
End Sub
