Çözüldü Yazının sonundan sonra hep aynı mesafede imza hanesinin açılması

[By.TRabZonLutm]

İmza kaşe bloku ile ilgili 3 adet örnek daha ekliyorum. Mümkün olduğunca font çeşitliliği eklendi. Bunlar üzerinde oynanarak kendi stilimizi elde edebiliriz.

Örnek 1
Hücreye düz yazı yazar gibi imza bloku eklemek:

Sub imza_Duz_Yazi()
Dim imz As Range

Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
With imz
    .Offset(0, 0).Resize(3, 3).Merge
    .Value = "ABC FİRMASI LTD. ŞTİ." & vbLf & "Ali Veli Selami" & vbLf & "Gn.Md."
    .Characters(1, 21).Font.Color = vbRed
    .Characters(1, 21).Font.Bold = True
    .Characters(22, Len(imz)).Font.Color = vbBlack
End With
End Sub

Örnek 2
Hücreye imza blokunu metin kutusu olarak eklemek:

Sub imza_Kutu_Ekle2()
Dim imz As Range
Dim sh As Shape

With ActiveSheet
    On Error Resume Next
    .Shapes("imzam").Delete
    On Error GoTo 0

    Set sh = .Shapes.AddTextbox(msoTextOrientationHorizontal, 30, 50, 150, 50)
    With sh
        .Select
        .Line.Visible = msoFalse
        .TextFrame.Characters.Text = "ABC FİRMASI LTD. ŞTİ." & Chr(13) & "Ali Veli Selami" & Chr(13) & "Gn.Md."
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame.Characters.Font.Name = "Tahoma"
        .TextFrame.Characters.Font.Size = 10
        .TextFrame.Characters.Font.Bold = msoTrue
        .TextFrame2.TextRange.Paragraphs(2).Font.Size = 12
        .TextFrame2.TextRange.Paragraphs(2).Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Name = "imzam"
        Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
        .Top = imz.Top
        .Left = imz.Left
        imz.Select
    End With
End With
End Sub

Örnek 3
Hücreye imza blokunu daha önceden klasöre kaydedilen kaşe resmi olarak eklemek:

Sub imza_Resim()
Dim hcr As Range, PicFile As String, resim As Shape
Dim PicTop As Integer, PicLeft As Integer, PicW As Integer, PicH As Integer

With ActiveSheet
    On Error Resume Next
    .Shapes("imzam").Delete
    On Error GoTo 0
'imza resminin bulunduğu konum
    PicFile = ThisWorkbook.Path & "\" & "imzam.jpg"
   
    If Dir(PicFile) = Empty Then
        MsgBox "Resim bulunamadı..!", vbCritical
        Exit Sub
    End If
'Son satırdan 10 satır aşağıda ve 7. sütun hizasında
    Set hcr = .Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
    PicTop = hcr.Top
    PicLeft = hcr.Left
    PicW = 150  'imza genişliği
    PicH = 90   'imza yüksekliği
    Set resim = .Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
    resim.Name = "imzam"
End With

End Sub

Hocam denedim çok güzel çalışıyor. Tek bir eksiği kaldı. Ben sırayla yazdiracagim zaman , yazdirmadan önce hep makro çalıştırmam gerekiyor ki belirttiğimiz bölüme gelsin. Ben hiç uğraşmadan sürekli aktif olsa otomatik olarak o bölüme kendisi gelse

 

[necati]

Excelin yazdırmadan önce otomatik çalışan prosedürü var. Onu kullanabilirsiniz. Mesela "Thisworkbook" koduna aşağıdaki gibi bir kod yazarsanız, "imza_Resim" adlı makro otomatikman devreye girer. "imza_Resim" çalışacak makronun ismidir. Siz dilediğiniz makro ismini buraya yazın.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
imza_Resim
End Sub

 

[By.TRabZonLutm]

Excelin yazdırmadan önce otomatik çalışan prosedürü var. Onu kullanabilirsiniz. Mesela "Thisworkbook" koduna aşağıdaki gibi bir kod yazarsanız, "imza_Resim" adlı makro otomatikman devreye girer. "imza_Resim" çalışacak makronun ismidir. Siz dilediğiniz makro ismini buraya yazın.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
imza_Resim
End Sub

çok teşekkür ederim ilginiz için muazzam oldu.

 

[By.TRabZonLutm]

Excelin yazdırmadan önce otomatik çalışan prosedürü var. Onu kullanabilirsiniz. Mesela "Thisworkbook" koduna aşağıdaki gibi bir kod yazarsanız, "imza_Resim" adlı makro otomatikman devreye girer. "imza_Resim" çalışacak makronun ismidir. Siz dilediğiniz makro ismini buraya yazın.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
imza_Resim
End Sub

Hocam işyerinde denedim fakat şöyle bir hata alıyorum. Thisworkbook adında sol tarafta bir isim yok. BuCalismaKitabi bölümüne aşağıdaki kodu ekledim ama hata alıyorum yazdirmadan önce. Makro da çalışmıyor.

 

[necati]

Thisworkbook ile BuCalismaKitabi aynı şeydir.
Kullandığınız imza makrosunu işyerindeki bilgisayarda bir modül içine kopyalamalısınız. Sanırım bu işlemi yapmadınız.

 

[By.TRabZonLutm]

Thisworkbook ile BuCalismaKitabi aynı şeydir.
Kullandığınız imza makrosunu işyerindeki bilgisayarda bir modül içine kopyalamalısınız. Sanırım bu işlemi yapmadınız.

Kesinlikle öyle yapmamisim.

İmza kısmını adı soyadı, unvanı, ve görevi bölümünü excelde bir yerden çekmesi için kutucuklu kodu nasıl düzeltmem gerekir. ( İmza atan farklı olunca her seferinde kodu düzeltmem gerekiyor)

 

[necati]

Ben bir örnek veriyorum, buna benzer şekilde yapabilirsiniz. M1 de firma adı, M2 de isim, M3 de ünvan varsa:
.TextFrame.Characters.Text = Trim(Range("M1")) & Chr(13) & Trim(Range("M2")) & Chr(13) & Trim(Range("M3"))

 

[By.TRabZonLutm]

Ben bir örnek veriyorum, buna benzer şekilde yapabilirsiniz. M1 de firma adı, M2 de isim, M3 de ünvan varsa:
.TextFrame.Characters.Text = Trim(Range("M1")) & Chr(13) & Trim(Range("M2")) & Chr(13) & Trim(Range("M3"))

sonsuz teşekkür ederim, tüm işim çözülmüş oldu. Helal olsun !

 

[necati]

Rica ederim.