参考下面的吧,应该可以解决你的问题: Option Explicit Private validUser As BooleanPrivate Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc 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 BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long Private Type PicBmp Size As Long Type As Long hBMP As Long hPal As Long Reserved As Long End TypePrivate Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Function CreateBitmapPicture(ByVal hBMP As Long, ByVal hPal As Long) As Picture On Error Resume Next Dim R As Long Dim pic As PicBmp Dim IPic As IPicture Dim IID_IDispatch As GUID With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With pic .Size = Len(pic) .Type = vbPicTypeBitmap .hBMP = hBMP .hPal = hPal End With '建立Picture图象 R = OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic) Set CreateBitmapPicture = IPic End Function Private Sub Command3_Click() Dim x As Long, y As Long Dim W As Long, H As Long Dim s As String Dim R As Single If validUser = False Then MsgBox "Invalid user!", vbInformation + vbOKOnly, "Invalid User" Exit Sub End If Picture1.AutoRedraw = True Dim hwndDeskTop As Long, hdcDesktop As Long Me.ScaleMode = vbPixels R = 0.9 'hwndDeskTop = GetDesktopWindow() 'hdcDesktop = GetWindowDC(hwndDeskTop) Dim hDc As Long, hBMP As Long hDc = CreateCompatibleDC(Me.hDc) hBMP = CreateCompatibleBitmap(Me.hDc, CLng(Picture1.Width * R), Picture1.Height) SelectObject hDc, hBMP BitBlt hDc, 0, 0, CLng(Picture1.Width * R), Picture1.Height, Me.hDc, Picture1.Left, Picture1.Top, vbSrcCopy'BitBlt Picture1.hDc, 0, 0, CLng(Picture1.Width * 9 / 10), Picture1.Height, Me.hDc, Picture1.Left, Picture1.Top, vbSrcCopy 'ReleaseDC hwndDeskTop, hdcDesktop s = App.Path & "\BC" & Text1.Text & ".bmp" 'SavePicture Picture1.Image, s SavePicture CreateBitmapPicture(hBMP, 0), s DeleteObject hBMP DeleteDC hDc
MsgBox "保存成功!" & vbCrLf & vbCrLf & "文件名为:" & s & vbCrLf & vbCrLf & "Copyright by Leo Xudong", vbOKOnly, "条形码保存"End Sub
printer.scalemode=3
printer.paintpicture picture1.image ,0,0,picture1.width,picture.height
scale=3并不重要,不过一定要让printer.scalemode的值和picture1.scalemode的值相同,printer默认的打印单位为缇,1缇=1/20英寸
Option Explicit
Private validUser As BooleanPrivate Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc 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 BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
Private Type PicBmp
Size As Long
Type As Long
hBMP As Long
hPal As Long
Reserved As Long
End TypePrivate Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Function CreateBitmapPicture(ByVal hBMP As Long, ByVal hPal As Long) As Picture
On Error Resume Next
Dim R As Long Dim pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With pic
.Size = Len(pic)
.Type = vbPicTypeBitmap
.hBMP = hBMP
.hPal = hPal
End With '建立Picture图象
R = OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
Set CreateBitmapPicture = IPic
End Function
Private Sub Command3_Click()
Dim x As Long, y As Long
Dim W As Long, H As Long
Dim s As String
Dim R As Single
If validUser = False Then
MsgBox "Invalid user!", vbInformation + vbOKOnly, "Invalid User"
Exit Sub
End If
Picture1.AutoRedraw = True
Dim hwndDeskTop As Long, hdcDesktop As Long
Me.ScaleMode = vbPixels
R = 0.9
'hwndDeskTop = GetDesktopWindow()
'hdcDesktop = GetWindowDC(hwndDeskTop)
Dim hDc As Long, hBMP As Long
hDc = CreateCompatibleDC(Me.hDc)
hBMP = CreateCompatibleBitmap(Me.hDc, CLng(Picture1.Width * R), Picture1.Height)
SelectObject hDc, hBMP
BitBlt hDc, 0, 0, CLng(Picture1.Width * R), Picture1.Height, Me.hDc, Picture1.Left, Picture1.Top, vbSrcCopy'BitBlt Picture1.hDc, 0, 0, CLng(Picture1.Width * 9 / 10), Picture1.Height, Me.hDc, Picture1.Left, Picture1.Top, vbSrcCopy
'ReleaseDC hwndDeskTop, hdcDesktop
s = App.Path & "\BC" & Text1.Text & ".bmp"
'SavePicture Picture1.Image, s
SavePicture CreateBitmapPicture(hBMP, 0), s
DeleteObject hBMP
DeleteDC hDc
MsgBox "保存成功!" & vbCrLf & vbCrLf & "文件名为:" & s & vbCrLf & vbCrLf & "Copyright by Leo Xudong", vbOKOnly, "条形码保存"End Sub