Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Temmuz 2011 Cuma

Comment Report



'Module1

'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'B. Available Tools List
'1) Sheet1\Picture 1; Insert\Picture\From File... and select some your picture on the Insert Picture Dialog Frame.
'2) Sheet1\WordArt 1; Insert\Picture\WordArt... and select some your WordArt on the WordArt Gallery Dialog Frame.
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private GD As GUID
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private PD As uPicDesc
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Tablo As Long
Private Tip As Long
Private Kopya As Long
Private IP As IPictureDisp
Private Alan, Resim, Nesne
Sub Resimli_Not_Yap()
On Error Resume Next
Call Resim_Getir(InputBox("Coment içini resimlendirmek için seçim yapınız." & VBA.vbLf & "Alan" & VBA.vbLf & "Resim" & VBA.vbLf & "Nesne", "[PBİD®] Resimli Comment Raporu","Alan"))
Set IP = Nothing
End Sub
Private Sub Resim_Getir(ByVal Tip As String)
On Error Resume Next
Select Case Tip
Case "Alan"
Set Alan = ActiveSheet.Range("A1:D11")
SavePicture Resim_Yap(Alan), ThisWorkbook.Path & "\Alan1.jpg"
Case "Resim"
Set Resim = ActiveSheet.Pictures("Picture 1")
SavePicture Resim_Yap(Resim), ThisWorkbook.Path & "\Resim1.bmp"
Case "Nesne"
Set Nesne = ActiveSheet.Shapes("WordArt 1")
SavePicture Resim_Yap(Nesne), ThisWorkbook.Path & "\Nesne1.gif"
Case Else
MsgBox "Geçerli bir seçim yapmadınız, veya dosyanız henüz uygun bir sürücüde [c/d/f] kayıtlı değil.", vbInformation, "[PBİD®] Lütfen dikkat"
Exit Sub
End Select
With ActiveSheet.Range("F1")
.Comment.Delete
.AddComment
.Comment.Visible = False
.Comment.Shape.Name = "ResimliNot"
.Comment.Text Text:=""
.Comment.Shape.TextFrame.AutoSize = True
With ActiveSheet.Shapes("ResimliNot")
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 255)
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.ForeColor.RGB = RGB(255, 255, 255)
.BackColor.SchemeColor = 80
Select Case Tip
Case "Alan": .UserPicture ThisWorkbook.Path & "\Alan1.jpg"
Case "Resim": .UserPicture ThisWorkbook.Path & "\Resim1.bmp"
Case "Nesne": .UserPicture ThisWorkbook.Path & "\Nesne1.gif"
End Select
.Visible = msoTrue
End With
.Width = 4 * 8.43 * 6.4
.Height = 11 * 12.75 / 0.748
.Visible = False
End With
.Comment.Visible = False
End With
Select Case Tip
Case "Alan": VBA.Kill ThisWorkbook.Path & "\Alan1.jpg"
Case "Resim": VBA.Kill ThisWorkbook.Path & "\Resim1.bmp"
Case "Nesne": VBA.Kill ThisWorkbook.Path & "\Nesne1.gif"
End Select
End Sub
Private Function Resim_Yap(Kaynak) As IPictureDisp
On Error GoTo Hata
Kaynak.CopyPicture
Tip = IIf(IsClipboardFormatAvailable(2) <> 0, 2, 14)
If IsClipboardFormatAvailable(Tip) <> 0 Then
If OpenClipboard(0) > 0 Then
Tablo = GetClipboardData(Tip)
If Tip = 2 Then
Kopya = CopyImage(Tablo, 0, 0, 0, &H4)
Else
Kopya = CopyEnhMetaFile(Tablo, vbNullString)
End If
CloseClipboard
If Tablo <> 0 Then
With GD
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With PD
.Size = Len(PD)
.Type = IIf(Tip = 2, 1, 4)
.hPic = Kopya
End With
OleCreatePictureIndirect PD, GD, True, IP
Set Resim_Yap = IP
End If
End If
End If
Exit Function
Hata:
Set Resim_Yap = Nothing
End Function
'Sub References_List()
' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References
' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1
' Next Eleman
'End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul