برنامج الكتابه على الصور حلوووووو

حاولت اني اصنع برنامج الكتابه على الصور

ولكن برمجتي محدودة جدا ولكن ان تكرمتوا

تحطوا لي بس مثال على قد الي اقوله لو سمحتوا

لا اريد برنامج الرسام لاني ماافهم به شي

ولكن لو تحط برنامج برنامج الكتابه على الصور ويحفظ الصور (يعرض نافذه الحفظ) فقط

الزبدة : برنامج الكتابه على الصور ويحفظ الصور (يعرض نافذه الحفظ) فقط فقط فقط فقط

لكي تعلموا (انتم مدرسيني)

ممكن يا Ghost2010 وانت يا VB_Rocket وانت يا BashaMohands

اريده بسرعه

لو تكرمتوا

Public Function annotateimage() As Long
   Dim rcode As Long
   Dim resimg As imgdes
   Dim text As String
   Dim filedata As TiffData
   Dim filename As String

   Dim HFONT As Long
   Dim hOldFont As Long
   Dim hOldBitmap As Long
   Dim hdc As Long
   Dim hMemDC As Long
   Dim caps As Long
   Dim rc As RECT
   Dim dummy As Long
   Dim lf As LOGFONT
      
   filename = "test.tif"  
   rcode = tiffinfo(filename, filedata)
   If (rcode = NO_ERROR) Then
        rcode = allocimage(resimg, filedata.width, filedata.length, filedata.vbitcount)
        If (rcode = NO_ERROR) Then
            rcode = loadtif(filename, resimg)
            If (rcode <> NO_ERROR) Then
                GoTo bottom
            End If
        End If
    End If
    
    ' Successfully loaded the tiff image, ready to add text to it 
    text = "Your name here"

   lf.lfHeight = 20
   lf.lfWidth = 0
   lf.lfEscapement = 0     ' Set lfEscapement and lfOrientation to 10 * angle to rotate text 
   lf.lfOrientation = 0    ' for example, to rotate 45 degrees set the values to 450         
   lf.lfWeight = FW_NORMAL
   lf.lfItalic = 0
   lf.lfUnderline = 0
   lf.lfStrikeOut = 0
   lf.lfCharSet = ANSI_CHARSET
   lf.lfOutPrecision = OUT_DEFAULT_PRECIS
   lf.lfClipPrecision = CLIP_DEFAULT_PRECIS
   lf.lfQuality = DEFAULT_QUALITY
   lf.lfPitchAndFamily = 32  ' FF_SWISS
   
   HFONT = CreateFontIndirect(lf) ' Create the font
   hdc = GetDC(0)
   hMemDC = CreateCompatibleDC(hdc)
   dummy = SetBkMode(hMemDC, TRANSPARENT) ' Set background to transparent (or opaque)
   hOldFont = SelectObject(hMemDC, HFONT) ' Select font into memory DC
   
   ' Select bitmap into the memory DC
   hOldBitmap = SelectObject(hMemDC, resimg.hBitmap)
   
   resimg.stx = 10  ' Position for text (10, 20)
   resimg.sty = 20
   
   imageareatorect resimg, rc
   
   resimg.stx = 0   ' Restore position to (0,0) for future operations 
   resimg.sty = 0
   
   ' Write the text into the image area for the annotation
   dummy = DrawText(hMemDC, text, -1, rc, DT_LEFT)
   
   ' Restore the original bitmap and font and delete the new font
   dummy = SelectObject(hMemDC, hOldBitmap)
   DeleteObject (SelectObject(hMemDC, hOldFont))
   DeleteDC (hMemDC)    ' Delete memory DC
   dummy = ReleaseDC(hwnd, hdc)
   
   rcode = savetif("testover.tif", resimg, 0)
   freeimage resimg

bottom:
   annotateimage = rcode
End Function

........... Add these defines and declarations  ...........

Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type

'  Image descriptor
Type imgdes
   ibuff As Long
   stx As Long
   sty As Long
   endx As Long
   endy As Long
   buffwidth As Long
   palette As Long
   colors As Long
   imgtype As Long
   bmh As Long
   hBitmap As Long
End Type

Type TiffData
   ByteOrder As Long
   width As Long
   length As Long
   BitsPSample As Long
   comp As Long
   SamplesPPixel As Long
   PhotoInt As Long
   PlanarCfg As Long
   vbitcount As Long
End Type

'........... declarations for annotate
Declare Function allocimage Lib "VIC32.DLL" (image As imgdes, ByVal wid As Long, ByVal leng As Long, ByVal BPPixel As Long) As Long
Declare Sub freeimage Lib "VIC32.DLL" (image As imgdes)
Declare Sub imageareatorect Lib "VIC32.DLL" (image As imgdes, RECT As RECT)
Declare Function loadtif Lib "VIC32.DLL" (ByVal filename As String, resimg As imgdes) As Long
Declare Function savetif Lib "VIC32.DLL" (ByVal filename As String, srcimg As imgdes, ByVal cmp As Long) As Long
Declare Function tiffinfo Lib "VIC32.DLL" (ByVal filename As String, tdat As TiffData) As Long

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteObject Lib "GDI32.DLL" (ByVal hpal As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

'................ definitions for annotate
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

Public Const FW_NORMAL = 400
Public Const ANSI_CHARSET = 0
Public Const OUT_DEFAULT_PRECIS = 0
Public Const CLIP_DEFAULT_PRECIS = 0
Public Const DEFAULT_QUALITY = 0
Public Const DEFAULT_PITCH = 0
Public Const FF_DONTCARE = 0    '  Don't care or don't know.

Public Const DT_LEFT = &H0

Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName(LF_FACESIZE) As Byte
End Type

انا مااعرف شي وش اسوي بالكود هذا

ممكن

مشكور جدا يا استاذي

هذا الكود حق شنو انا بس طلبت برنامج يعرض صوره(يعرض له نافذ الفتح showopen) ويكتب عليها مستخدم برنامجي اي كلام يريده

ويحفظها (يعرض له نافذه الحفظshowsave)

بس

ارجوكم بسرعه

ممكن يا Ghost2010 وانت يا VB_Rocket وانت يا BashaMohands

وكان الله في عونكم في التعليم