تصغير حجم الصورة

دور في البرنامج (مكتبة الاكواد ) راح تحصل الي تبغه المشكلة انا ما عندي اكسس الان بس دور واكيد راح تحصل

البرنامج موجود في المرفقات ادا مو عندك

CODLIBRARY.rar

حولها JPG ;)

Option Explicit
'By : Tmax
'http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=66454&lngWId=1
Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   Type As Long
   Value As Long
End Type

Private Type EncoderParameters
   Count As Long
   Parameter As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "GdiPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GdiPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GdiPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

Public Sub SaveJPG(ByVal pict As StdPicture, ByVal FileName As String, Optional ByVal quality As Byte = 80)
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long

tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)

If lRes = 0 Then
   lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
   If lRes = 0 Then
	  Dim tJpgEncoder As GUID
	  Dim tParams As EncoderParameters
	  CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
	  tParams.Count = 1
	  With tParams.Parameter
		 CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
		 .NumberOfValues = 1
		 .Type = 4
		 .Value = VarPtr(quality)
	  End With
	 lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
	  GdipDisposeImage lBitmap
   End If
   GdiplusShutdown lGDIP
End If
If lRes Then
   Err.Raise 17, , Error(17) & " " & lRes
End If
End Sub

أخي الكريم msayed2004 أنا لا زلت مبتدأ لو توضح لي وين أحط الكود وكيف أطبق الكود على الصورة أتمنى أني ما أكون تعبتك.

أخي HNo0O0oCH لقد بحثت ووجدت لكن أن لا أريد تغيير الصيغة بدون تغير الأسم فلهذة الحالة لم أستفد فلقد غير لي الشكل الظاهري فقط!!

ضع الكود بـ Module ثم نادى الوظيفة :

Public Sub SaveJPG(ByVal pict As StdPicture, ByVal FileName As String, Optional ByVal quality As Byte = 80)

حيث pict هو أداة الـ PictureBox اللى فيها الصورة.

و FileName مسار الحفظ متضدمن أسم الملف و الأمتداد (jpg)

و الـ quality هو جودة الصورة و أن لم تذكر سيتم أعتبارها 80

أخي الكريم msayed2004 أنا لم أعرف كيف أفعلة فهل تستطيع لو سمحت أن ترفق مثال

مرفق : To_JPG.rar

المثال ناجح ولك الشكر الجزيل أخي وجعلة في موازين حسناتك.