用 StretchBlt 處理影像有后黑邊，
原圖如下：
處理后保存的圖片如下（處理后的圖片超過2M 論壇上傳不了，故對圖片進行了QQ截圖，展示效果如下）：
代碼如下：
思路：以制作寬長比為： 102/152 的 的影像尺寸， picture2控制元件加載原始圖片，獲取原始圖片長寬像素值， 對此原始像素值按照102/152的比例進行計算，計算出長度或者寬度上需要增補的尺寸，以達到102/152這一比例。然后將picture1控制元件的長寬尺寸設定為 通過計算后的目標尺寸，然后用StretchBlt 函式將picture2控制元件的影像 加載打 picture1控制元件，然后再保存picture1控制元件上的目標圖片，即為保存到C盤的123.jpg 如原始碼。 奇怪的是 保存后的圖片，下面有黑邊，實在是不知道怎么處理了，求教各位高手！
'Form1上添加1個圖片框picture1
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function GetDC Lib "user32 " (ByVal hWND As Long) As Long
Private Const HALFTONE = 4
Private Const SRCCOPY = &HCC0020
Dim fs
Dim wScreen As Long
Dim hScreen As Long
Dim w As Long
Dim h As Long
Dim cw As Long
Dim ch As Long
Dim Dw As Long
Dim Dh As Long
Dim DifferenceH As Long
Dim DifferenceW As Long
Dim PIC As PictureBox
Dim rtn As Boolean
Dim rtm As Long
Dim Hdc1 As Long, Hdc2 As Long
Private Sub Form_Load()
Picture2.Picture = LoadPicture("C:\1.jpg")
Printer.ScaleMode = 3
Printer.ScaleWidth = 1181
Printer.ScaleHeight = 1772
Printer.ScaleLeft = 0
Printer.ScaleTop = 0
AllPrint
End Sub
Sub AllPrint() '此函式用來對圖片進行裁切列印
w = Picture2.Width
h = Picture2.Height
If w <= h Then '此判斷用來列印寬帶小于等等高度的圖片
Printer.Orientation = 1 '列印機縱向
ch = w * 152 \ 102
cw = 102 * h \ 152
DifferenceW = w - cw
DifferenceH = h - ch
Debug.Print DifferenceW
Debug.Print DifferenceH
If DifferenceW >= 0 And DifferenceH <= 0 Then
Picture1.Width = w
Picture1.Height = ch
Call SetStretchBltMode(Picture1.hDC, HALFTONE)
rtm = StretchBlt(Picture1.hDC, 0, Abs(DifferenceH / 2), w, ch, Picture2.hDC, 0, 0, w, ch, vbSrcCopy)
Picture1.Refresh
SavePicture Picture1.Image, "c:\123.jpg "
End If
End If
End Sub
uj5u.com熱心網友回復：
建議樓主還是用 PictureBox 的 PaintPicture方法來處理吧。參考下面這個代碼。但你要注意的是，
在設計視窗時，對 PictureBox 的幾個屬性進行如下設定（在 Form_Load()開頭加代碼也可）：
Picture1.Appearance = 0
Picture1.BorderStyle = 0
Picture1.AutoRedraw = True
Picture2.AutoSize = True
圖片縮放代碼：
Sub AllPrint()
w = Picture2.ScaleWidth
h = Picture2.ScaleHeight
If w <= h Then
ch = w * 152 / 102
cw = h * 102 / 152
' 這是原始高度不變，調整寬度適應比例
Picture1.Width = cw
Picture1.Height = h
Picture1.PaintPicture Picture2.Image, 0, 0, cw, h, 0, 0, w, h, vbSrcCopy
' 下面這個是寬度不變，調整高度來適應比例
'Picture1.Width = w
'Picture1.Height = ch
'Picture1.PaintPicture Picture2.Image, 0, 0, w, ch, 0, 0, w, h, vbSrcCopy
SavePicture Picture1.Image, "E:\Temp\123.bmp"
End If
End Sub
SavePicture 保存的格式是Bmp的。
你把擴展名寫成 .jpg 并沒有實際作用，如果要保存jpg格式圖片檔案，可以在網上搜索一下代碼。
uj5u.com熱心網友回復：
用API函式通過 PictureBox 的HDC操作，如果 PictureBox 被遮住（全部，或部分），往往會出現類似“花屏”的結果。
uj5u.com熱心網友回復：
謝謝Chen8013 的回復，可能是我表達的問題把，我現在再把我的意思說一下：裁切圖片來滿足比例，這種我已經解決了，但問題是這種裁切會導致圖片資訊丟失，
所以現在打算采用補償的方法來實作，這樣就不至于導致圖片資訊被裁切掉。
就是用原始圖片的像素尺寸 按照 一定的比例來進行計算，計算出 長度方向 或者 寬度方向需要補償的的像素寬度，
如我1樓我發的帖子的第二幅圖，處理完后，是需要在高度方向進行尺寸補償，這樣一來，圖片上方和下發就應該有留白，
但我現在處理的結果是 上邊留白正常， 下面就變成黑色的了。（上下補償都是白色就滿足需求了）
希望大俠給多指教！
uj5u.com熱心網友回復：
Sub x()
'假定原始圖片 1000 * 1000'
w = 1000
h = 1000
ch = w * 152 \ 102
cw = 102 * h \ 152
DifferenceW = w - cw
DifferenceH = h - ch
'StretchBlt(Picture1.hDC, 0, Abs(DifferenceH / 2), w, ch, Picture2.hDC, 0, 0, w, ch, vbSrcCopy)'
Debug.Print "目標", 0, Abs(DifferenceH / 2), w, ch
Debug.Print "源", 0, 0, w, ch
End Sub
目標 0 245 1000 1490
源 0 0 1000 1490
你從 1000*1000 上切 1000*1490，下面的 490 有什么內容？
uj5u.com熱心網友回復：
比如說 我的圖片像素尺寸是750 * 1000 按照102/152的像素比算下來的話如果按照750的寬度計算出來滿足比例的高度是：750*152/102=1117 大于 1000
如果按照1000的高度計算出來滿足比例的寬度是：1000*102/152=671 小于750
這樣就需要按照750 的寬度 1117 的高度 來重新生成圖片
這樣一來的話，重新生成的圖片 高度f上半部分留白像素尺寸為： （1117-1000)/2
高度下半部分留白像素尺寸也是： （1117-1000)/2
但是實際效果是 上半部分留白正常 下半部分不正常了， 如上我的第二個截圖，不曉得怎么處理了。
uj5u.com熱心網友回復：
@ Chen8013 ，你的回答是通過圖片縮放 我試了你的代碼 圖片會有壓碩訓者拉伸，造成了失真
@ Tiger_Zhao ，你的回答雖然沒解決問題，但是卻提醒了哦，
對于 'Picture1.PaintPicture Picture2.Image, 0, 0, w, ch, 0, 0, w, h, vbSrcCopy
StretchBlt(Picture1.hDC, 0, Abs(DifferenceH / 2), w, ch, Picture2.hDC, 0, 0, w, ch, vbSrcCopy)
paintpicture 和 stretchebit 這兩個函式 里面主要的八個引數 我的理解有誤，所以造成了黑邊問題。
可恨的是 我對這兩個函式里面的引數所代表的意義，一字一句的讀了不下10遍，還是沒理解對，這次算是理解了！！！
如下圖 ，已經可以得到想要的圖片了！
uj5u.com熱心網友回復：
在任意位置繪制圖形使用 PaintPicture 方法，可以在表單、圖片框和 Printer 物件上的任何地方，繪制圖形。PaintPicture 方法的語法是：
[object.]PaintPicture pic, destX, destY[, destWidth[, destHeight[, srcX _
[, srcY[, srcWidth[, srcHeight[, Op]]]]]]]
目標 object 指的是表單、圖片框或 Printer 物件，這些地方都是 pic 圖片表現的處所。如果 object 被忽略了，則認為指定的就是當前的表單。pic 引數必須是一個圖片物件，它是由表單或控制元件的 Picture 屬性決定。
destX 和 destY 引數，是按照 objec 的 ScaleMode，該圖象將出現的水平和垂直位置。destWidth 和 destHeight 引數是可選項，用來設定在 object 目標中該圖象的寬度和高度。
srcX 和 srcY 引數是可選項，用來定義 pic 中裁剪區左上角的 x 和 y 坐標。
可選的 Op 引數用來定義當在目標 object 上繪圖時，在圖片上執行的光柵操作（例如，AND 和 XOR）。
PaintPicture 方法可代替 BitBlt Windows API 函式，在將矩形圖形塊從一個地方移到任意另一地方時，它可執行廣泛的各種操作。
例如，可以使用 PaintPicture 方法生成同一位圖的多份副本，并將它們平鋪在表單上。使用這種方法，比在表單上移動圖片控制元件要快。下列代碼是用來平鋪圖片控制元件的 100 份拷貝，并且通過給 destWidth 設定一個負值，可以使每張圖片進行水平翻轉。
For i = 0 To 10
For j = 0 To 10
Form1.PaintPicture picF.Picture, j * _
picF.Width, i * picF.Height, _
picF.Width, -picF.Height
Next j, i
詳細資訊 請參閱《語言參考》的“PaintPicture 方法”。
uj5u.com熱心網友回復：
@趙4老師，謝謝你的回復，不過在你回復之前問題已經解決了！下面我對 paintpicture 函式 說說我的理解
object.PaintPicturepicture, x1, y1, width1, height1, x2, y2, width2, height2, opcode
uj5u.com熱心網友回復：
算了，還是不是了，怕說錯了讓大家見笑！！！！！！
uj5u.com熱心網友回復：
我沒理解你的目的是“留白”來實作等比縮放。
當然如果用PaintPicture實作也是可以的。
如果你要實作“留白”部分真正的為白色，應該明確指定Picture1的BackColor為白色。
否則，留白部分有可能是黑色，或者為系統的“視窗背景”或“按鈕表面”的顏色，不一定是白色。
uj5u.com熱心網友回復：
請問樓主是如何解決的，我也 遇到了同樣的問題，希望賜教轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/52824.html
標籤：VBA
上一篇：vb6 與 as3 互通