① 怎样在 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
运行效果如下：