① 怎樣在 VB 程序中實現圖象掃描功能
VB以知控制項暫無此功能! 可以考慮自己編程實現. 簡單機理: 1.圖片放大:掃描圖象,利用Piont和Pset方法,用n*n的點掙代替原來每一個點的顏色. 2.圖片縮小:按比例獲取圖片nq*nq的點的顏色(n為原來點的數量,q為小於1
② VB如何拍照後自動將圖片保存到資料庫
（1）你需要把Command1_Click裡面的代碼單獨提出來寫成一個過程(或者函數)，類似於這樣的形式：
Private Sub SavePicToDB(ByVal PicFilename as String)
'這裡面是你的代碼，直接復制進來
'需要稍做修改，把"C:\aa.JPG" 改為 PicFileName
End Sub
（2）然後在cmdStartPhoto_Click方法中，先加兩句：
Dim picFileName as String
picFileName = App.Path & "DataBase/PIctures" XXXXXXXXXXXXXXXXXXX '這里我不寫全了，你自己復制你那一長串代碼
SavePicture XXXXXXXX的行改為：
SavePicture picPhoto.Picture picFileName
並且在下一行加一句：
SavePicToDB(PicFilename)
③ 如何利用VB代碼調用WORD文檔中的插入圖片來源掃描儀功能
只是要界面的話很簡單 打開VC，選擇文件/新建/MFC APPWIZARD[exe]，輸入工程名，位置自己選，確定。 然後選擇基本對話框，確定。 後面的比較麻煩，只說大概: 使用控制項對界面進行操作，用屬性修改。 建立類向導進行關聯
④ VB圖像保存程序代碼
因為默認的保存無論你選擇什麼格式後綴，其實都是bmp點陣圖，你看文件尺寸就知道了。
通常保存圖片代碼：(默認pictrebox名稱)
dim filepath as string
SavePicture Picture1.Image,filepath
當然，filepath路徑的獲得你可以用對話框確定一下。
我要給你的代碼是可以保存多種格式的。需要添加一個模塊，模塊代碼最後貼
調用示範：
'先正常保存文件
DimfileStrAsString
fileStr=App.Path&" empmymp.gif"'定義臨時文件，並檢查是否有同名文件，有則清除
IfDir(fileStr)<>""ThenKillfileStr
SavePicturePicture1.Image,fileStr
'再轉換格式，這里轉成gif
DimstdpicAsStdPicture
Setstdpic=LoadPicture(fileStr)
CallSavePic(stdpic,fileStr,".gif")
Setstdpic=Nothing
'模塊代碼：
PrivateTypeGUID
Data1AsLong
Data2AsInteger
Data3AsInteger
Data4(0To7)AsByte
EndType
GdiplusVersionAsLong
DebugEventCallbackAsLong
SuppressExternalCodecsAsLong
EndType
PrivateTypeEncoderParameter
GUIDAsGUID
NumberOfValuesAsLong
typeAsLong
ValueAsLong
EndType
PrivateTypeEncoderParameters
countAsLong
ParameterAsEncoderParameter
EndType
"GDIPlus"(tokenAsLong,inputbufAsGdiplusStartupInput,OptionalByValoutputbufAsLong=0)AsLong
"GDIPlus"(ByValtokenAsLong)AsLong
"GDIPlus"(ByValhbmAsLong,ByValhPalAsLong,BITMAPAsLong)AsLong
"GDIPlus"(ByValImageAsLong)AsLong
"GDIPlus"(ByValImageAsLong,ByValFileNameAsLong,clsidEncoderAsGUID,encoderParamsAsAny)AsLong
"ole32"(ByValStrAsLong,idAsGUID)AsLong
"kernel32"Alias"RtlMoveMemory"(DestAsAny,SrcAsAny,ByValcbAsLong)AsLong
'*************************************************************************
'**作者：laviewpbt
'**函數名：SavePic
'**輸入：pic(StdPicture)-圖象句柄
'**：FileName(String)-保存路徑
'**：Quality(Byte)-JPG圖象質量
'**：TIFF_ColorDepth(Long)-TTF格式的顏色深度
'**：TIFF_Compression(Long)-TTF格式的壓縮比
'**輸出：無
'**功能描述：把圖象保存為JPG、TIFF、PNG、GIF、BMP格式
'**日期：
'**修改人：laviewpbt
'**日期：2005-10-2314.43.52
'**版本：Version1.2.1
'*************************************************************************
PublicSubSavePic(ByValpictAsStdPicture,ByValFileNameAsString,PicTypeAsString,_
OptionalByValQualityAsByte=80,_
OptionalByValTIFF_ColorDepthAsLong=24,_
OptionalByValTIFF_CompressionAsLong=6)
Screen.MousePointer=vbHourglass
DimtSIAsGdiplusStartupInput
DimlResAsLong
DimlGDIPAsLong
DimlBitmapAsLong
DimaEncParams()AsByte
OnErrorGoToErrHandle:
tSI.GdiplusVersion=1'初始化GDI+
lRes=GdiplusStartup(lGDIP,tSI)
IflRes=0Then'從句柄創建GDI+圖像
lRes=GdipCreateBitmapFromHBITMAP(pict.Handle,0,lBitmap)
IflRes=0Then
DimtJpgEncoderAsGUID
DimtParamsAsEncoderParameters'初始化解碼器的GUID標識
SelectCasePicType
Case".jpg"
CLSIDFromStringStrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
tParams.count=1'設置解碼器參數
WithtParams.Parameter'Quality
CLSIDFromStringStrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"),.GUID'得到Quality參數的GUID標識
.NumberOfValues=1
.type=4
.Value=VarPtr(Quality)
EndWith
ReDimaEncParams(1ToLen(tParams))
CallCopyMemory(aEncParams(1),tParams,Len(tParams))
Case".png"
CLSIDFromStringStrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
ReDimaEncParams(1ToLen(tParams))
Case".gif"
CLSIDFromStringStrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
ReDimaEncParams(1ToLen(tParams))
Case".tiff"
CLSIDFromStringStrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
tParams.count=2
ReDimaEncParams(1ToLen(tParams)+Len(tParams.Parameter))
WithtParams.Parameter
.NumberOfValues=1
.type=4
CLSIDFromStringStrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"),.GUID'得到ColorDepth參數的GUID標識
.Value=VarPtr(TIFF_Compression)
EndWith
CallCopyMemory(aEncParams(1),tParams,Len(tParams))
WithtParams.Parameter
.NumberOfValues=1
.type=4
CLSIDFromStringStrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"),.GUID'得到Compression參數的GUID標識
.Value=VarPtr(TIFF_ColorDepth)
EndWith
CallCopyMemory(aEncParams(Len(tParams)+1),tParams.Parameter,Len(tParams.Parameter))
Case".bmp"'可以提前寫保存為BMP的代碼，因為並沒有用GDI+
SavePicturepict,FileName
Screen.MousePointer=vbDefault
ExitSub
EndSelect
lRes=GdipSaveImageToFile(lBitmap,StrPtr(FileName),tJpgEncoder,aEncParams(1))'保存圖像
GdipDisposeImagelBitmap'銷毀GDI+圖像
EndIf
GdiplusShutdownlGDIP'銷毀GDI+
EndIf
Screen.MousePointer=vbDefault
EraseaEncParams
ExitSub
ErrHandle:
Screen.MousePointer=vbDefault
MsgBox"在保存圖片的過程中發生錯誤:"&vbCrLf&vbCrLf&"錯誤號:"&Err.Number&vbCrLf&"錯誤描述:"&Err.Description,vbInformationOrvbOKOnly,"錯誤"
EndSub
⑤ VB如何讀取一個圖片，保存到位元組數組中
VB6.0可以Open 語句來打開需要讀到位元組數組的圖片文件，並用Get 語句將一個已打開的磁碟文件讀入一個變數之中。
Open 語句，能夠對文件輸入/輸出 (I/O)。
實例代碼，獲取任何文件儲存在位元組數組aryContent中：
Private Sub Command1_Click()
Dim aryContent() As Byte
CommonDialog1.CancelError = True ' 設置「CancelError」為 True
On Error GoTo ErrHandler
CommonDialog1.Flags = cdlOFNHideReadOnly ' 設置標志
' 設置過濾器
CommonDialog1.Filter = "All Files (*.*)|*.*|Text Files" & "(*.txt)|*.txt|Batch Files (*.bat)|*.bat"
CommonDialog1.FilterIndex = 2 ' 指定預設的過濾器
CommonDialog1.ShowOpen ' 顯示「打開」對話框
' 顯示選定文件的名字
'MsgBox CommonDialog1.FileName
Open CommonDialog1.FileName For Binary As #1
ReDim aryContent(LOF(1) - 1)
Get #1, , aryContent
Close #1
Exit Sub
ErrHandler:
' 用戶按了「取消」按鈕
Exit Sub
End Sub
⑥ 用VB怎麼讀取一張圖然後識別出圖上唯一紅點的位置並以坐標形式保存下來圖是攝像頭拍出來的，可以處理全
VB6還是VB.NET？這倆區別還不小呢。
給你個通用的思路吧，純API實現。不管是VB6還是VB.NET，都可以使用。
另外，可以看見的紅點，不會是一個像素吧？需要自己構建個判斷的演算法。
打開點陣圖那些的操作我就不說了。
核心API：
COLORREF GetPixel(
HDC hdc, // handle to DC
int nXPos, // x-coordinate of pixel
int nYPos // y-coordinate of pixel
);
返回值是特定像素點的RGB值。
大致思路：
建立一個數組，裡面存放的是坐標型數據。
然後循環的讀取圖像中的每個像素，如果接近紅色，將改點坐標保持進數組。
最後分析數組，將坐標相近的像素點記錄下來，再根據需要折中一點。
再提供另一條思路：
讀取點陣圖以後，建立一張和點陣圖尺寸完全相同的點陣圖內存，並且建立的點陣圖像素值全為紅色。
最後將兩張點陣圖的數據進行相減運算。
然後判斷運算的結果中接近0的部分，這部分就是紅點的位置了。
其中需要用到的別的API函數可以在MSDN中索引。
⑦ 如何在VB中保存圖片
VB6.0可使用SavePicture 語句來保存窗體或圖像框中經修改的圖片。
1）SavePicture 語句，從對象或控制項（如果有一個與其相關）的 Picture 或 Image 屬性中將圖形保存到文件中。
PrivateSubCommand3_Click()'保存為.jpg圖片
'設置「CancelError」為True
CommonDialog1.CancelError=True
OnErrorGoToErrHandler
'設置標志
CommonDialog1.Flags=cdlOFNHideReadOnly
'設置過濾器
CommonDialog1.Filter="JPEGFiles"&"(*.jpg)|*.jpg"
'指定預設的過濾器
CommonDialog1.FilterIndex=2
'顯示「打開」對話框
CommonDialog1.ShowSave
'顯示選定文件的名字
'MsgBoxCommonDialog1.fileName
SetPicture2.Picture=Picture1.Image'轉移Picture1所繪圖為Picture2.Picture賦值
DimretAsBoolean
ret=PictureBoxSaveJPG(Picture2,CommonDialog1.fileName)'保存壓縮後的圖片
Ifret=FalseThen
MsgBox"保存失敗"
EndIf
ExitSub
ErrHandler:
'用戶按了「取消」按鈕
ExitSub
EndSub
⑧ VB 修改圖片的尺寸並保存，比如現有圖片256*128，我要修改成15*15的尺寸，要源碼！
首先，聲明以下核心代碼部分完全照抄，由CSDN上laviewpbt提供，我在之前一篇VB常見問題里給出過鏈接。當時提到VB的效率問題，我舉
出圖片縮放的例子，用VB寫的圖片縮放，效率居然很高，以此證明演算法的重要性。laviewpbt又是受到了CSDN上zyl910，本名好像叫周岳靈的
激發，結果做出的程序效率更加驚人。有興趣的可以看看我這篇文章里給出的論壇鏈接。
所以，我這里用的解決方法就是從他們這里得來。不過這些高人們關注的是效率，程序裡面有很大篇幅是不同演算法比較，已經時間測試。而對於更加關心使用的人來說，代碼需要裁剪。我粗略的篩選了下，對模塊內容沒有改動，而只是從主程序里撥出我們需要的內容。
那麼，就開始吧。
首先，用到三個模塊和一個類模塊，這部分代碼我們不用重寫了。程序搭建時候添加進去。需要說明的是，如果你已經有一個在做的項目，那麼簡單的導入模塊可能是不行的。laviewpbt給我們做了一個很好的示範，他的API聲明都是在一個模塊裡面的，那麼你的項目最好也這樣，然後，把他的API聲明貼在後面，運行程序時候如果有重復，會自動找到，然後你就停掉他，注釋掉或者刪除。這幾個模塊的內容我最後貼出，這里到現在也不能上傳附件。
那麼，我們重點要介紹怎麼用。
Private DIBData As CImagePrivate DIBWork As CImage
首先要聲明兩個類變數。這個是我們自定義的類。在模塊里。
接著兩段代碼，一個載入圖片，一個改變圖片大小。
我們要打開圖片，初始化上面這兩個量，初始化過程寫在 form_load裡面
Set DIBData = New CImage
Set DIBWork = New CImage
scaNum = 1 '這個是比例
scaWidth = Me.Width '這個是窗體寬度的初始參照值
Picture1.Picture = LoadPicture(App.Path & "\手球場地小圖.jpg")
Dim DIBTemp As New CImage
If DIBTemp.LoadPictureFromFile(App.Path & "\手球場地小圖.jpg") = True Then
Set DIBData = DIBTemp
DIBWork.DisposeResource
Picture1.Width = DIBData.Width
Picture1.Height = DIBData.Height
DIBData.Render Picture1.Hdc
Picture1.Refresh
Else
MsgBox "錯誤的圖像文件", vbCritical
End If
Set DIBTemp = Nothing
當窗體大小變化的時候，我們再寫一段代碼改變圖片大小已經PictureBox大小任務就完成了。
需要說明的是，以下調用的代碼，對尺寸的計量單位是pixel，而VB窗體默認的計量單位是Tiwp，顯示器上一個pixel裡面可以有很多twip，如果你做出來的程序，圖像順暢顯示了，但是就是很小，那麼，恭喜你，你成功了，只是需要將尺寸轉換成vb裡面的tiwp，
乘以 Screen.TwipsPerPixelX
這段代碼如下：
Dim W As Long, H As Long
W = DIBData.Width * scaNum
H = DIBData.Height * scaNum
If W < 1 Then W = 1 If H < 1 Then H = 1
Dim DIBTemp As New CImage
Dim t As Currency
Me.MousePointer = vbHourglass
t = Utility.GetCurrentTime
Set DIBTemp = Resample(DIBData, W, H, 2) '這里固定選擇一個演算法，雙線性內插值
' t = GetCurrentTime - t
Me.MousePointer = vbDefault
' Me.Caption = " 處理時間：" & Format(t / 1000, "##,###,##0.000") & "秒"
Set DIBWork = DIBTemp
Set DIBTemp = Nothing
PicData.Width = DIBWork.Width * Screen.TwipsPerPixelX
PicData.Height = DIBWork.Height * Screen.TwipsPerPixelX
DIBWork.Render PicData.Hdc
' SolNum
PicData.Refresh
代碼被我注釋掉一部分，原代碼中有時間測試內容。
把這段代碼獨立成一個Sub，然後在form_reSize裡面調用，當然，調用之前首先要計算變化比例scaNum
下面開貼模塊代碼
模塊一、ImageResize模塊：
Option Explicit
Public Enum ResizeModeConst
SMC_Nearest = 0 '最鄰近插值
SMC_StretchBlt = 1 'StretchBlt
SMC_BiliNear = 2 '雙線性內插值
End Enum
Public
Function Resample(Img As CImage, NewWidth As Long, NewHeight As Long,
Optional Method As ResizeModeConst = SMC_BiliNear) As CImage
Dim X As Long, Y As Long
Dim XX As Long, YY As Long
Dim OldYY As Long
Dim Width As Long, Height As Long
Dim Sa As SAFEARRAY, SaN As SAFEARRAY
Dim ImageData() As Byte, NewImageData() As Byte
Dim Stride As Long, NewStride As Long
Dim Offset As Long
Dim Speed As Long, SpeedN As Long
Dim NewImg As New CImage
If NewImg.CreateNewImage(NewWidth, NewHeight) = True Then
With Sa
.Element = 1
.Dimension = 1
.Bounds.Elements = Img.Stride * Img.Height
.Pointer = Img.Pointer
End With
CopyMemory ByVal VarPtrArray(ImageData()), VarPtr(Sa), 4
With SaN
.Element = 1
.Dimension = 1
.Bounds.Elements = NewImg.Stride * NewImg.Height
.Pointer = NewImg.Pointer
End With
CopyMemory ByVal VarPtrArray(NewImageData()), VarPtr(SaN), 4
Width = Img.Width: Height = Img.Height
Stride = Img.Stride: NewStride = NewImg.Stride
ReDim LinearRow(NewWidth - 1) As Long
Select Case Method
Case ResizeModeConst.SMC_Nearest
OldYY = -1
For X = 0 To NewWidth - 1
LinearRow(X) = (X * Width \ NewWidth) * 3
Next
For Y = 0 To NewHeight - 1
SpeedN = Y * NewStride
YY = Y * Height \ NewHeight
Offset = YY * Stride
If YY = OldYY Then
CopyMemory NewImageData(SpeedN), NewImageData(SpeedN - NewStride), NewStride
Else
OldYY = YY
For X = 0 To NewWidth - 1
Speed = Offset + LinearRow(X)
NewImageData(SpeedN) = ImageData(Speed)
NewImageData(SpeedN + 1) = ImageData(Speed + 1)
NewImageData(SpeedN + 2) = ImageData(Speed + 2)
SpeedN = SpeedN + 3
Next
End If
Next
Case ResizeModeConst.SMC_StretchBlt
Img.Render NewImg.Hdc, 0, 0, NewImg.Width, NewImg.Height, 0, 0, Img.Width, Img.Height
Case ResizeModeConst.SMC_BiliNear
Dim PartXX As Long, PartYY As Long
Dim InvertXX As Long, InvertYY As Long
Dim NewX As Long, NewY As Long
Dim SpeedP As Long, ColOffset As Long
Dim Pos As Double
ReDim RowOffset(NewWidth - 1) As Long
ReDim RowPartXX(NewWidth - 1) As Long
For X = 0 To NewWidth - 1
Pos = X * (Width - 1) / NewWidth
RowOffset(X) = Int(Pos) * 3
RowPartXX(X) = (Pos - Int(Pos)) * 2048
Next
For Y = 0 To NewHeight - 1
SpeedN = Y * NewStride
Pos = Y * (Height - 1) / NewHeight
PartYY = (Pos - Int(Pos)) * 2048
InvertYY = 2048 - PartYY
ColOffset = Int(Pos) * Stride
For X = 0 To NewWidth - 1
PartXX = RowPartXX(X)
InvertXX = 2048 - PartXX
Speed = ColOffset + RowOffset(X)
SpeedP = Speed + Stride
NewImageData(SpeedN + 2) = ((ImageData(Speed + 2) * InvertXX +
ImageData(Speed + 5) * PartXX) * InvertYY + (ImageData(SpeedP + 2) *
InvertXX + ImageData(SpeedP + 5) * PartXX) * PartYY) \ 4194304
NewImageData(SpeedN + 1) = ((ImageData(Speed + 1) * InvertXX +
ImageData(Speed + 4) * PartXX) * InvertYY + (ImageData(SpeedP + 1) *
InvertXX + ImageData(SpeedP + 4) * PartXX) * PartYY) \ 4194304
NewImageData(SpeedN) = ((ImageData(Speed) * InvertXX + ImageData(Speed +
3) * PartXX) * InvertYY + (ImageData(SpeedP) * InvertXX +
ImageData(SpeedP + 3) * PartXX) * PartYY) \ 4194304
SpeedN = SpeedN + 3
Next
Next
End Select
CopyMemory ByVal VarPtrArray(ImageData()), 0&, 4
CopyMemory ByVal VarPtrArray(NewImageData()), 0&, 4
End If
Set Resample = NewImg
End Function
模塊2、可以忽略的和時間測試有關部分，內容不多，也貼出
Private SystemFrequency As Currency
Public Function GetCurrentTime() As Currency
If SystemFrequency = 0 Then '未初始化
If QueryPerformanceFrequency(SystemFrequency) = 0 Then
SystemFrequency = ERRORINDEX '無高精度計數器
End If
End If
If SystemFrequency <> ERRORINDEX Then
Dim CurCount As Currency
QueryPerformanceCounter CurCount
GetCurrentTime = CurCount * 1000@ / SystemFrequency
Else
GetCurrentTime = GetTickCount()
End If
End Function
模塊3、API聲明部分，需要你自己解決沖突問題。
Option Explicit
Public Const ERRORINDEX As Long = -1
Public Const DIB_RGB_COLORS As Long = 0
Public Const BI_RGB As Long = 0 '正常
Public Const STRETCH_ANDSCANS As Long = 1
Public Const STRETCH_DELETESCANS As Long = 3
Public Const STRETCH_HALFTONE As Long = 4
Public Const STRETCH_ORSCANS As Long = 2
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Type RGBQUAD
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Public Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As RGBQUAD
End Type
Public Type SAFEARRAYBOUND
Elements As Long
lLbound As Long
End Type
Public Type SAFEARRAY2D
Dimension As Integer
Features As Integer
Element As Long
Locks As Long
Pointer As Long
Bounds(1) As SAFEARRAYBOUND
End Type
Public Type SAFEARRAY
Dimension As Integer
Features As Integer
Element As Long
Locks As Long
Pointer As Long
Bounds As SAFEARRAYBOUND
End Type
Public Type BITMAPINFOHEADER
Size As Long
Width As Long
Height As Long
Planes As Integer
BitCount As Integer
Compression As Long
SizeImage As Long
XPelsPerMeter As Long
YPelsPerMeter As Long
ClrUsed As Long
ClrImportant As Long
End Type
Public Type BITMAPINFO
Header As BITMAPINFOHEADER
Palette(255) As RGBQUAD
End Type
Public Type Bitmap
Type As Long
Width As Long
Height As Long
WidthBytes As Long
Planes As Integer
BitsPixel As Integer
Bits As Long
End Type
'
'內存操作相關API
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, ByVal numBytes As Long)
Public
Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef
Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
'VB本體API
Public
Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal
lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As
Long
Public Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
'GDI系統API函數
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal Hdc As Long) As Long
Public
Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal Hdc As Long,
ByRef pBitmapInfo As Any, ByVal un As Long, ByRef Pointer As Long, ByVal
Handle As Long, ByVal Dw As Long) As Long
Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal Hdc As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Public
Declare Function SetDIBColorTable Lib "gdi32" (ByVal Hdc As Long, ByVal
un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Public
Declare Function GetDIBColorTable Lib "gdi32" (ByVal Hdc As Long, ByVal
un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQUAD) As Long
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Public
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
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal Hdc As Long, ByVal nStretchMode As Long) As Long
Public
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
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal Hdc
As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy
As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long,
ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal
wUsage As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
類模塊、CImage；文件名CImage.cls
Option Explicit
Private m_Width As Long '層的寬度
Private m_Height As Long '層的高度
Private m_Stride As Long '層數據每個掃描行的大小
Private m_Hdc As Long '層的內存DC
Private m_Pointer As Long '層數據在內存的首地址w
Private m_Handle As Long 'DIBSection的句柄
Private m_OldHandle As Long '原始設備環境的句柄
Public Property Get Width() As Long
Width = m_Width
End Property
Public Property Get Height() As Long
Height = m_Height
End Property
Public Property Get Stride() As Long
Stride = m_Stride
End Property
Public Property Get Hdc() As Long
Hdc = m_Hdc
End Property
Public Property Get Handle() As Long
Handle = m_Handle
End Property
Public Property Get Pointer() As Long
Pointer = m_Pointer
End Property
Private Sub Class_Terminate()
DisposeResource
End Sub
Public Function CreateNewImage(ByVal Width As Long, _ ByVal Height As Long) As Boolean
Dim ScreenDC As Long, BmpInfo As BITMAPINFOHEADER
If Width <= 0 Or Height <= 0 Then Exit Function
DisposeResource '刪除原始的內存資源
With BmpInfo
.BitCount = 24
.Height = -Height '為了和GDI對象的坐標系統（起點坐標在左上角），建立一個倒序的DIB
.Width = Width
.Planes = 1
.Size = 40
m_Stride = ((Width * 3 + 3) And &HFFFFFFFC)
.SizeImage = m_Stride * Height
End With
ScreenDC = GetDC(0) '得到屏幕DC
m_Hdc = CreateCompatibleDC(ScreenDC)
ReleaseDC 0, ScreenDC '釋放屏幕DC
m_Handle = CreateDIBSection(m_Hdc, BmpInfo, DIB_RGB_COLORS, m_Pointer, 0, 0)
If m_Handle <> 0 Then '希望系統能夠讓我們成功創建DIB吧
m_OldHandle = SelectObject(m_Hdc, m_Handle)
m_Width = Width: m_Height = Height
CreateNewImage = True
End If
End Function
Public Sub DisposeResource()
If m_Hdc <> 0 Then
SelectObject m_Hdc, m_OldHandle
DeleteDC m_Hdc
DeleteObject m_Handle
m_Width = 0: m_Height = 0 '重置其他的圖像相關屬性
m_Handle = 0: m_OldHandle = 0
m_Pointer = 0: m_Hdc = 0
End If
End Sub
Public Function Render(ByVal DestDC As Long, _
Optional ByVal DestX As Long, _
Optional ByVal DestY As Long, _
Optional ByVal DestWidth As Long, _
Optional ByVal DestHeight As Long, _
Optional ByVal SrcX As Long, _
Optional ByVal SrcY As Long, _
Optional ByVal SrcWidth As Long, _
Optional ByVal SrcHeight As Long) As Boolean
If m_Handle = 0 Then Exit Function
If DestWidth = 0 Then DestWidth = m_Width
If DestHeight = 0 Then DestHeight = m_Height
If SrcX < 0 Then SrcX = 0 ' 源X,Y不能為負，但目的X,Y可以
If SrcY < 0 Then SrcY = 0
If SrcWidth = 0 Then
SrcWidth = m_Width
ElseIf SrcWidth < 0 Then
DestWidth = -DestWidth
SrcWidth = -SrcWidth
End If
If SrcHeight = 0 Then
SrcHeight = m_Height
ElseIf SrcHeight < 0 Then
DestHeight = -DestHeight
SrcHeight = -SrcHeight
End If
SetStretchBltMode DestDC, STRETCH_HALFTONE
StretchBlt DestDC, DestX, DestY, DestWidth, DestHeight, m_Hdc, SrcX, SrcY, SrcWidth, SrcHeight, vbSrcCopy
End Function
Public Function LoadPictureFromFile(FileName As String) As Boolean
Dim Width As Long, Height As Long
Dim StdPic As StdPicture
On Error GoTo Errhandle:
Set StdPic = LoadPicture(FileName)
Width = ConvertHimetrixToPixels(StdPic.Width, True)
Height = ConvertHimetrixToPixels(StdPic.Height, False)
If CreateNewImage(Width, Height) = True Then
StdPic.Render m_Hdc + 0&, 0&, 0&, Width + 0&, Height +
0&, 0, StdPic.Height, StdPic.Width, -StdPic.Height, ByVal 0
'類似於BMP的逆序存儲，所以用-StdPic.Height
LoadPictureFromFile = True
End If
Errhandle:
End Function
Private Function ConvertHimetrixToPixels(HiMetrix As Long, Horizontally As Boolean) As Long
If Horizontally Then
ConvertHimetrixToPixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelX
Else
ConvertHimetrixToPixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelY
End If
End Function
Private Function ConvertPixelsToHimetrix(Pixels As Long, Horizontally As Boolean) As Long
If Horizontally Then
ConvertPixelsToHimetrix = Pixels * Screen.TwipsPerPixelX * 2540 / 1440
Else
ConvertPixelsToHimetrix = Pixels * Screen.TwipsPerPixelY * 2540 / 1440
End IfEnd Function
⑨ VB保存圖片代碼
我有這樣的一個程序了，你要的話加我，我發給你對照參考一下把，或者還沒發現問題的話，我在幫你看看你的代碼，行不36
1789
273
⑩ 求vb代碼：抓取滑鼠選定區域圖片並按序號自動保存到一個文件夾
根據你的要求,我用一晚上的時間做了這個示例,一個窗體上有兩個picturebox控制項，一個顯示原始圖片，一個顯示裁減的圖片，可動態顯示拖動框，具體代碼如下：
PublicClassForm1
DimbeginPointAsPoint
DimendPointAsPoint
DimbeginMoveAsBoolean
Dimgm1AsGraphics
Dimgm2AsGraphics
DimpicnumAsInteger
DimpicPathAsString="C:UsersXiansrPictures隨拍夏.JPG"
PrivateSubForm1_Load(ByValsenderAsSystem.Object,ByValeAsSystem.EventArgs)HandlesMyBase.Load
PictureBox1.Load(picPath)
EndSub
PrivateSubPictureBox1_MouseDown(ByValsenderAsObject,ByValeAsSystem.Windows.Forms.MouseEventArgs)HandlesPictureBox1.MouseDown
beginPoint=e.Location
beginMove=True
EndSub
PrivateSubPictureBox1_MouseMove(ByValsenderAsObject,ByValeAsSystem.Windows.Forms.MouseEventArgs)HandlesPictureBox1.MouseMove
PictureBox1.Load(picPath)
gm1=Graphics.FromImage(PictureBox1.Image)
IfbeginMoveThen
gm1.DrawRectangle(Pens.White,beginPoint.X,beginPoint.Y,(e.X-beginPoint.X),(e.Y-beginPoint.Y))
PictureBox1.Refresh()
EndIf
EndSub
PrivateSubPictureBox1_MouseUp(ByValsenderAsObject,ByValeAsSystem.Windows.Forms.MouseEventArgs)HandlesPictureBox1.MouseUp
beginMove=False
endPoint=e.Location
DimnewfileAsNewBitmap(endPoint.X-beginPoint.X,endPoint.Y-beginPoint.Y,gm1)
gm2=Graphics.FromImage(newfile)
gm2.DrawImage(PictureBox1.Image,NewRectangle(NewPoint(0,0),NewSize(endPoint.X-beginPoint.X,endPoint.Y-beginPoint.Y)),NewRectangle(beginPoint,NewSize(endPoint.X-beginPoint.X,endPoint.Y-beginPoint.Y)),GraphicsUnit.Pixel)
newfile.Save("d:abc"&picnum&".jpg",System.Drawing.Imaging.ImageFormat.Jpeg)
PictureBox2.Load("d:abc"&picnum&".jpg")
picnum+=1
EndSub
EndClass
運行效果如下：