'이미지 파일을 읽어와서 쉘에 붙여 넣는것
Public Sub GetPic()
Dim aWB As Excel.Workbook
Dim aSht As Excel.Worksheet
Dim aRng As Excel.Range
Dim rngA As Excel.Range
Dim rng8 As Excel.Range
Dim aShp As Excel.Shape
Dim isImgExist As String
Dim bmpName As String
Dim pathName As String
Dim nSize As Integer
On Error GoTo hErr:
Set aSht = ActiveSheet
' Set rngA = aSht.Range("기준열")
Set rngA = aSht.Range("B4")
Set rngA = aSht.Range(rngA, rngA.End(xlDown))
' pathName = "경로"
pathName = "d:\민용헌\GEN3\SYMBOL_130821\LOGO\"
' nSize = 이미지 사이즈(pixel단위)
nSize = 32
For Each aRng In rngA
' Set rng8 = aRng.Offset(기준열로부터의 오프셋)
Set rng8 = aRng.Offset(0, 5)
imgname = aRng.Value
' imgname = imgname & ".이미지 확장자"
imgname = imgname & ".png"
isImgExist = Dir(pathName & imgname)
If (isImgExist <> "") Then
aSht.Pictures.Insert(pathName & imgname).Select
Selection.ShapeRange.Left = (rng8.Width - nSize) / 2 + rng8.Left
Selection.ShapeRange.Top = (rng8.Height - nSize) / 2 + rng8.Top
Selection.ShapeRange.PictureFormat.TransparentBackground = True
Selection.ShapeRange.PictureFormat.TransparencyColor = RGB(255, 0, 255)
End If
Next
MsgBox "Complete"
Exit Sub
hErr:
' 예외처리
Resume
End Sub
'PSD의 파일을 읽어서 PPT로 붙히는것
Option Explicit
Private Sub btnConvert_Click()
Dim phtApp As Photoshop.Application
Dim phtDoc As Photoshop.Document
Dim phtSet As Photoshop.LayerSet
Dim phtLay As Photoshop.ArtLayer
Dim bmpSaveOpt As Photoshop.BMPSaveOptions ' 포토샵 저장 설정 Flag
Dim pptApp As PowerPoint.Application
Dim pptPrs As PowerPoint.Presentation
Dim pptView As PowerPoint.View
Dim pptSlide As PowerPoint.Slide
Dim pptRange As PowerPoint.SlideRange
Dim shtBase As Excel.Worksheet
Dim rngProg As Excel.Range
Dim fsoRef, dirRef, f As Object
Dim strScrPath As String
Dim strResPath As String
Dim strSetName As String
Dim strLayName As String
Dim strBmpPath As String
'포토샵 Application개체 생성
Set phtApp = CreateObject("Photoshop.Application")
Set bmpSaveOpt = New BMPSaveOptions
phtApp.DisplayDialogs = psDisplayNoDialogs ' for PsDialogModes 1 (psDisplayAllDialogs), 2 (psDisplayErrorDialogs), 3 (psDisplayNoDialogs
bmpSaveOpt.Depth = psBMP_X1R5G5B5
bmpSaveOpt.OSType = psWindows
'포토샵이 설치되지 않으면 포토샵개체를 만들수없다는 에러 발생(429)하므로
'에러 발생시 메시지와 함께 종료합니다.
If Err = 429 Then
MsgBox "포토샵이 제대로 설치되지 않았습니다.", vbCritical
Exit Sub
End If
On Error GoTo hErr '이 아래코드부터 에러가 발생하면 hErr레이블(끝부분)로 이동합니다.
Set shtBase = ActiveWorkbook.Worksheets("변환")
shtBase.Range("A1:B65535").Clear
Set rngProg = shtBase.Range("A1")
rngProg.Value = "작업 시작"
Set rngProg = rngProg.Offset(1, 0)
strScrPath = shtBase.Range("E3").Value
strResPath = shtBase.Range("E4").Value
Set fsoRef = CreateObject("Scripting.FileSystemObject")
Set dirRef = fsoRef.GetFolder(strScrPath)
'&& 파워포인트 활성화 &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoTrue
Set pptPrs = pptApp.Presentations.Add
For Each f In dirRef.Files
DoEvents
rngProg.Value = f.Name
rngProg.Offset(0, 1).Value = "진행중"
Set phtDoc = phtApp.Open(f.Path)
For Each phtSet In phtDoc.LayerSets
DoEvents
strSetName = phtSet.Name
If strSetName = "화살표" Then
phtSet.Visible = True
For Each phtLay In phtSet.Layers
DoEvents
If Right(phtLay.Name, 2) = "AI" Then
phtLay.Visible = True
Else
phtLay.Visible = False
End If
Next
ElseIf Left(strSetName, 2) = "주간" Then
phtSet.Visible = True
For Each phtLay In phtSet.Layers
phtLay.Visible = True
Next
ElseIf Left(strSetName, 2) = "메인" Then
phtSet.Visible = True
For Each phtLay In phtSet.Layers
If phtLay.Name = "도로면검정" Then
phtLay.Visible = False
Else
phtLay.Visible = True
End If
Next
Else
phtSet.Visible = False
End If
Next
strBmpPath = strResPath & Right(phtDoc.Name, InStr(phtDoc.Name, "_"))
strBmpPath = Replace(strBmpPath, ".psd", ".bmp")
phtApp.ActiveDocument.SaveAs strBmpPath, bmpSaveOpt, True, psLowercase
'&& 파워포인트에 사진 추가
Dim shpRange As Object
Dim txtRange As Object
Dim picRange As Object
Set pptSlide = pptPrs.Slides.Add(1, ppLayoutBlank)
Set picRange = pptSlide.Shapes.AddPicture(Filename:=strBmpPath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=90, Top:=68, Width:=540, Height:=405)
Set shpRange = pptSlide.Shapes.AddLabel(msoTextOrientationHorizontal, 70.75, 15, 14.5, 36#)
shpRange.TextFrame.WordWrap = msoFalse
Set txtRange = shpRange.TextFrame.TextRange.Characters(Start:=1, Length:=0)
With txtRange
.Text = phtDoc.Name
With .Font
.NameAscii = "굴림"
.NameFarEast = "굴림"
.NameOther = "Times New Roman"
.Size = 24
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoTrue
.Color.SchemeColor = ppForeground
End With
End With
' ActiveWindow.Selection.SlideRange.Shapes.AddLabel(msoTextOrientationHorizontal, 70.75, 1.625, 14.5, 36#).Select
' ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoFalse
' ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
' With ActiveWindow.Selection.TextRange
' .Text = "tjsaudrl"
' With .Font
' .NameAscii = "굴림"
' .NameFarEast = "굴림"
' .NameOther = "Times New Roman"
' .Size = 24
' .Bold = msoFalse
' .Italic = msoFalse
' .Underline = msoFalse
' .Shadow = msoFalse
' .Emboss = msoFalse
' .BaselineOffset = 0
' .AutoRotateNumbers = msoTrue
' .Color.SchemeColor = ppForeground
' End With
' End With
' ActiveWindow.Selection.ShapeRange.Select
' ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:="C:\Documents and Settings\Administrator\My Documents\My Pictures\1001.jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=174, Top:=139, Width:=372, Height:=263).Select
phtDoc.Close (psDoNotSaveChanges)
rngProg.Offset(0, 1).Value = "완 료"
Set rngProg = rngProg.Offset(1, 0)
Next
pptPrs.SaveAs strResPath & "사진3D확인용.ppt"
MsgBox "작업종료"
Exit Sub
hErr: '에러가 발생하면 이쪽으로 옵니다
MsgBox Err.Description, vbCritical, "에러발생"
Resume Next
End Sub
'통계내는것
Option Explicit
Public Sub 중분류_요약()
Dim shtOne As Excel.Worksheet
Dim shtTwo As Excel.Worksheet
Dim rngOne As Excel.Range
Dim rngTwo As Excel.Range
Dim rngAll As Excel.Range
Dim rngEnd As Excel.Range
Dim rngDat As Excel.Range
Dim rngSun As Excel.Range
Dim strName As String
Dim strSheet As String
Dim strFomula As String
Dim n As String
Dim b As String
Dim e As String
On Error GoTo hErr
Set shtOne = ActiveWorkbook.Worksheets("명칭")
Set shtTwo = ActiveWorkbook.Worksheets("명칭_중분류")
shtTwo.Range("D3").Value = Format(Now, "yyyy-mm-dd")
Set rngOne = shtOne.Range("B5")
Set rngTwo = shtTwo.Range("C10")
Set rngEnd = rngOne.End(xlDown)
Set rngAll = shtOne.Range(rngOne, rngOne.End(xlDown))
rngOne = Application.ConvertFormula(rngOne.Formula, xlA1, xlA1, xlRelative)
strSheet = "명칭"
For Each rngOne In rngAll
DoEvents
If strName = "" Then
strName = rngOne.Text
Set rngSun = rngOne
End If
If rngOne.Text <> strName Then
shtTwo.Activate
n = rngTwo.Row
b = rngSun.Row
e = rngOne.Offset(-1, 0).Row
' 건수 OLD
strFomula = FormatString("=SUM($s!G$s:G$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 3)
rngDat.Formula = strFomula
' 건수 NEW
strFomula = FormatString("=SUM($s!H$s:H$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 4)
rngDat.Formula = strFomula
strName = rngOne.Text
Set rngTwo = rngTwo.Offset(1, 0)
Set rngSun = rngOne.Offset(0, 0)
End If
If rngOne.Address = rngEnd.Address Then
shtTwo.Activate
n = rngTwo.Row
b = rngSun.Row
e = rngOne.Offset(-1, 0).Row
strFomula = FormatString("=SUM($s!G$s:G$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 3)
rngDat.Formula = strFomula
' 건수 NEW
strFomula = FormatString("=SUM($s!H$s:H$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 4)
rngDat.Formula = strFomula
End If
Next
Exit Sub
hErr:
MsgBox "중분류 요약 에러" & Err.Description
End Sub
Public Sub 대분류_요약()
Dim shtOne As Excel.Worksheet
Dim shtTwo As Excel.Worksheet
Dim rngOne As Excel.Range
Dim rngTwo As Excel.Range
Dim rngDat As Excel.Range
Dim rngAll As Excel.Range
Dim rngEnd As Excel.Range
Dim rngSun As Excel.Range
Dim strName As String
Dim strSheet As String
Dim strFomula As String
Dim n As String
Dim b As String
Dim e As String
On Error GoTo hErr
Set shtOne = ActiveWorkbook.Worksheets("명칭_중분류")
Set shtTwo = ActiveWorkbook.Worksheets("명칭_대분류")
shtTwo.Range("D3").Value = Format(Now, "yyyy-mm-dd")
Set rngOne = shtOne.Range("B10")
Set rngTwo = shtTwo.Range("B10")
Set rngEnd = rngOne.End(xlDown)
Set rngAll = shtOne.Range(rngOne, rngOne.End(xlDown))
rngOne = Application.ConvertFormula(rngOne.Formula, xlA1, xlA1, xlRelative)
strSheet = "명칭_중분류"
For Each rngOne In rngAll
DoEvents
If strName = "" Then
strName = rngOne.Text
Set rngSun = rngOne
End If
If rngOne.Text <> strName Then
shtTwo.Activate
n = rngTwo.Row
b = rngSun.Row
e = rngOne.Offset(-1, 0).Row
' 건수 OLD
strFomula = FormatString("=SUM($s!F$s:F$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 4)
rngDat.Formula = strFomula
' 건수 NEW
strFomula = FormatString("=SUM($s!G$s:G$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 5)
rngDat.Formula = strFomula
strName = rngOne.Text
Set rngTwo = rngTwo.Offset(1, 0)
Set rngSun = rngOne.Offset(0, 0)
End If
If rngOne.Address = rngEnd.Address Then
shtTwo.Activate
n = rngTwo.Row
b = rngSun.Row
e = rngOne.Offset(-1, 0).Row
' 건수 OLD
strFomula = FormatString("=SUM($s!F$s:F$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 4)
rngDat.Formula = strFomula
' 건수 NEW
strFomula = FormatString("=SUM($s!G$s:G$s)", strSheet, b, e)
strFomula = Replace(strFomula, "'", """")
Set rngDat = rngTwo.Offset(0, 5)
rngDat.Formula = strFomula
End If
Next
Exit Sub
hErr:
MsgBox "대분류 요약 에러" & Err.Description
End Sub
Public Function FormatString(ByVal src As String, ParamArray mRepStr())
' #VBIDEUtils#************************************************************
' *
' * Procedure Name : printf
' * Parameters :
' * ByVal src As String
' * ParamArray mRepStr()
' * *******************************************************************
' * Comments : $VBCR -> vbcrlf 으로 대체
' * $VBTAB -> vbTabl으로 대체
' *
' * *******************************************************************
Dim s As Variant
src = Replace(src, "$VBCR", vbCrLf)
src = Replace(src, "$VBTAB", vbTab)
For Each s In mRepStr
src = Replace(src, "$s", s, , 1, vbTextCompare)
Next
FormatString = src
End Function
